U.S. Department

of Commerce |

I National Bureau

of Standards

NBS

PUBLICATIONS

NATL INST OF STAND & TECH

A11107 5bD033

Computer Science

and Technology

NBS Special Publication 500-117, Volume 2

Selection and Use of

General-Purpose Programming

Languages — Program Examples
he National Bureau of Standards' was established by an act of Congress on March 3, 1901. The

_ Bureau's overall goal is to strengthen and advance the nation's science and technology and facilitate their effective application for public benefit. To this end, the Bureau conducts research and provides: (1) a

basis for the nation's physical measurement system, (2) scientific and technological services for industry and

government, (3) a technical basis for equity in trade, and (4) technical services to promote public safety.

The Bureau's technical work is performed by the National Measurement Laboratory, the National

Engineering Laboratory, the Institute for Computer Sciences and Technology, and the Center for Materials

Science.

The National Measurement Laboratory

Provides the national system of physical and chemical measurement;

coordinates the system with measurement systems of other nations and

furnishes essential services leading to accurate and uniform physical and

chemical measurement throughout the Nation's scientific community, in- dustry, and commerce; provides advisory and research services to other Government agencies; conducts physical and chemical research; develops,

produces, and distributes Standard Reference 'Materials; and provides

calibration services. The Laboratory consists of the following centers:

• Basic Standards^

• Radiation Research

• Chemical Physics

• Analytical Chemistry

The National Engineering Laboratory

Provides technology and technical services to the public and private sectors to address national needs and to solve national problems; conducts research in engineering and applied science in support of these efforts; builds and maintains competence in the necessary disciplines required to carry out this research and technical service; develops engineering data and measurement

capabilities; provides engineering measurement traceability services; develops

test methods and proposes engineering standards and code changes; develops

and proposes new engineering practices; and develops and improves

mechanisms to transfer results of its research to the ultimate user. The

Laboratory consists of the following centers:

Applied Mathematics

Electronics and Electrical Engineering^

Manufacturing Engineering

Building Technology

Fire Research

Chemical Engineering^

The Institute for Computer Sciences and Technology

Conducts research and provides scientific and technical services to aid Federal agencies in the selection, acquisition, application, and use of computer technology to improve effectiveness and economy in Government

operations in accordance with Public Law 89-306 (40 U.S.C. 759), relevant Executive Orders, and other directives; carries out this mission by managing

the Federal Information Processing Standards Program, developing Federal ADP standards guidelines, and managing Federal participation in ADP

voluntary standardization activities; provides scientific and technological advisory services and assistance to Federal agencies; and provides the technical foundation for computer-related policies of the Federal Government. The Institute consists of the following centers:

Programming Science and

Technology

Computer Systems

Engineering

The Center for Materials Science

Conducts research and provides measurements, data, standards, reference

materials, quantitative understanding and other technical information fundamental to the processing, structure, properties and performance of materials; addresses the scientific basis for new advanced materials technologies; plans

research around cross-country scientific themes such as nondestructive

evaluation and phase diagram development; oversees Bureau-wide technical programs in nuclear reactor radiation research and nondestructive evaluation; and broadly disseminates generic technical information resulting from

its programs. The Center consists of the following Divisions:

Inorganic Materials Fracture and Deformation^

Polymers

Metallurgy Reactor Radiation

'Headquarters and Laboratories at Gaithersburg, MD, unless otherwise noted; mailing address Gaithersburg, MD 20899. ^Some divisions within the center are located at Boulder, CO 80303. ^Located at Boulder, CO, with some elements at Gaithersburg, MD.
llTATIONAt BUREAql

OF STANDARDa UBRART Clcioo

Computer Science

and Technology

Vou ^ NBS Special Publication 500-117, Volume 2

c y Selection and Use of

General-Purpose Programming

Languages — Program Examples

John V. Cugini

Center for Programming Science and Technology

Institute for Computer Sciences and Technology

National Bureau of Standards

Gaithersburg, MD 20899

U.S. DEPARTMENT OF COMMERCE

Malcolm Baldrige, Secretary

National Bureau of Standards

Ernest Ambler, Director

Issued October 1984
Reports on Computer Science and Technology

The National Bureau of Standards has a special responsibility within the Federal

Government for computer science and technology activities. The programs of the

NBS Institute for Computer Sciences and Technology are designed to provide ADP

standards, guidelines, and technical advisory services to improve the effectiveness

of computer utilization in the Federal sector, and to perform appropriate research

and development efforts as foundation for such activities and programs. This

publication series will report these NBS efforts to the Federal computer community as

well as to interested specialists in the academic and private sectors. Those wishing

to receive notices of publications in this series should complete and return the form

at the end of this publication.

Library of Congress Catalog Card Number: 84-601120

National Bureau of Standards Special Publication 500-117, Volume 2

Natl. Bur Stand. (U.S.), Spec. Publ. 500-117, Vol. 2, 178 pages (Oct. 1984)

CODEN: XNBSAV

U.S. GOVERNMENT PRINTING OFFICE WASHINGTON: 1984

For sale by Ihe Superintendent ol Documents, U S Government Printing Office, Washington. DC 20402
Selection and Use of General-Purpose Programming Languages

Volume 2 - Program Examples

John V. Cugini

Institute for Computer Sciences and Technology

National Bureau of Standards

ABSTRACT

Programming languages have been and will continue to be an

important instrument for the automation of a wide variety of

functions within industry and the Federal Government. Other

instruments, such as program generators, application packages,

query languages, and the like, are also available and their use

is preferable in some circumstances.

Given that conventional programming is the appropriate

technique for a particular application, the choice among the

various languages becomes an important issue. There are a great

number of selection criteria, not all of which depend directly on

the language itself. Broadly speaking, the criteria are based on

1) the language and its implementation, 2) the application to be

programmed, and 3) the user's existing facilities and software.

This study presents a survey of selection factors for the

major general-purpose languages: Ada*, BASIC, C, COBOL, FORTRAN,

Pascal, and PL/I. The factors covered include not only the

logical operations within each language, but also the advantages

and disadvantages stemming from the current computing

environment, e.g.f software packages, microcomputers, and

standards. The criteria associated with the application and the

user-'s facilities are explained. Finally, there is a set of

program examples to illustrate the features of the various

languages

.

This volume includes the program examples. Volume 1 contains the discussion of language selection criteria.

Ke y words ; Ada; alternatives to programming; BASIC; C;

COBOL; FORTRAN; Pascal; PL/I; programming language

features; programming languages; selection of programming

language

.

• Ada is a registered trademark of the U. S. Government,

Ada Joint Project Office.

ill
TABLE OF CONTENTS: Volume 2 - Program Examples

1.0 INTRODUCTION

.

1 2.0 ADA 9

3.0 BASIC 33

4.0 C 52

5.0 COBOL 74

6.0 FORTRAN 99

7.0 PASCAL 135

8.0 PL/I 155

FIGURES:

Figure 1 - Algorithm for Program Examples 2

Figure 2 - Input Data 3

Figure 3 - Queries and Output ^

iv
Page 1

1.0 INTRODUCTION

In this volume, we shall illustrate the general style of

each of the languages with a program. These programs are only

examples; they do not attempt to demonstrate the full capability

of each language. On the other hand, the application chosen is

complex enough that the programs do make significant use of

several important language features, such as reading a file,

interacting with a user, recursion, data abstraction,

manipulation of arrays, pointers, and character strings, and some

numeric calculation. Of particular note are the language

features for modularizing a program of moderate size (about 1000

lines). While no application can be completely lang uag e - ne u t r a 1

,

this variety of requirements implies a relatively unbiased

example. Finally, the application deals with a well-known realm

(family relationships) in order to facilitate understanding of

the programs

.

All of the programs solve the same problem, i.e., they

accept the same input and produce output as nearly equivalent as possible. The input is a file of people, one person per record,

and a series of user queries. In the file, each person's father

and mother (if known), and spouse (if any) are identified. Given

this information, the user may then specify any two persons in

the file, and the program computes and displays the relationship

(e.g., brother-in-law, second cousin) between those two. Also,

based on the number and degree of common ancestors, the expected

value for the proportion of common genetic material between the

two is computed and displayed.

The algorithms and data structures employed are roughly

equivalent, but differ in detail owing to the language

differences being illustrated. Generally, user-defined names are

capitalized and language-defined keywords and identifiers are

written in lower-case. In all the programs a directed graph is

simulated, with the vertices representing people and the edges

representing different types of direct relationships. The only

direct relationships are parent, child, and spouse. Starting at

one vertex, a search is conducted to find the shortest path to

the other vertex. The types of edges encountered along the path,

together with some additional information, determine the

relationship. For instance, if the shortest path between XI and

X4 is that XI is child of X2 , X2 is spouse of X3 , and X3 is

parent of X4, this would show that XI and X4 are step-siblings.

It is assumed that the input file has already been validated and

is correct. The user's requests, however, are checked. The

algorithm to determine the shortest path is adapted from

[Baas78]. The overall algorithm is expressed by the pseudo-code

below.

All of the programs, except the one in BASIC, have compiled

and executed on at least one language processor which implements

the corresponding standard or base document. The COBOL program,

while conforming to both COBOL-74 and C0B0L-8x, is essentially a COBOL-74 program, since it does not exploit any of the new

COBOL-Sx features.
Page 2

Figure 1 - Algorithm for Program Examples

for each record in input PEOPLE file do

establish entry in PERSON array

for all previous entries do

compare this entry to previous, looking for

i mm ediate relationships: parent, child, or spouse

if relationship found

establish link (edge) between these two persons

end if

end for

end for

graph is now built

while not request to stop

prompt and read next request

exit while-block if request to stop

if syntax of request OK

search for requested persons

if exactly one of each person found

if 1st person = 2nd person

display "identical to self"

else

find shortest path between the two persons

if no such path

display "unrelated"

else

analyze path for named relationships:

path initially composed of parent, child,

spouse edges

resolve child-parent and child-spouse-parent

to sibling

resolve child-child-... and parent-parent-...

to descendant (child*) or ancestor (parent'

resolve child*-sibling-parent* to cousin,

chi Id*- s ibl ing to nephew,

sibling-parent* to uncle

display consolidated relationships

compute proportion of common genetic material:

traverse ancestors of personl, zeroing out

traverse ancestors of personl, marking and

accumulating genetic contribution

traverse ancestors of person2, accumulating

overlap with personl

display results

end if

end i f

else

display "duplicate name" or "not found"

end if

else

display "invalid request"

end if

end while

display "done"
Page 3

This figure

program examples

Position

1-20

21-23

24

25-21

28-30

31-33

Figure 2 - Input Data

shows some of

were tested.

Contents

the Input data with which

The format of each record is:

the

Name of person

Unique 3-digit identifier

Gender of person

Identifier of father (000

Identifier of mother (000

Identifier of spouse (000

of person

if unknown)

if unknown)

if none or unknown)

Example of Input Data

John Smith

Mary Smith

Wilbur Finnegan

Mary Finnegan

James Smith

Wilma Smith

Marvin Hamlisch

Melvln Hamlisch

Martha Hamlisch

Murgatroyd Whatsis

Bentley Whatsis

Myrna Whozat

Bosworth Whatsis

K48

K43

K41

K42

K46

K45

K47

K44

Velorus Davis

Goldle Beacon

Ross Beacon

Velma Davis

Floyd Davis

Cindy Davis

David Beacon

Norma Cousins

Carmine Cousins

Maria Cousins

James Cousins

C. John Cousins

John Cousins

Janet Cousins

Richard Cousins

Paul Cousins

Marie Cousins

001M000000002

002F003000001

OlOMOOOOOOOll

OllFOOOOOOOlO

020M001002022

022F010011020

031M000032000

033M000032000

032F048043034

034M000000032

035M034036000

036F000000000

037M034036000

048M000000043

043F041042048

041M000000042

042F000000041

046M045000000

045M048043000

047M044000000

044M041042000

085M000000086

083F085086082

082M000000083

086F000000085

088M085084087

084F000000000

121M081 120000

053F082083055

051M000000052

052F000000051

054M051052000

055M051052053

073M055053074

074F140141073

077M073074000

078M073074000

079F073074000
Page 4

Figure 3 - Queries and Output

This figure gives some examples of the results of running

the programs

.

Enter two person-identifiers (name or number),

separated by semicolon. Enter "stop" to stop.

Incorrect request format: null field preceding semicolon.

Enter two pe r s on- i den t i f ie r s (name or number),

separated by semicolon. Enter "stop" to stop.

X ; X ; X

Incorrect request format: must be exactly one semicolon.

Enter two pe r s on- i den t i f i e r s (name or number),

separated by semicolon. Enter "stop" to stop.

X ; X

First person not found.

Second person not found.

Enter two person-identifiers (name or number),

separated by semicolon. Enter "stop" to stop.

Ill ; 111

Christopher Delmonte is identical to himself.

Enter two per s on- i den t i f i e r s (name or number),

separated by semicolon. Enter "stop" to stop.

G6;John Smith

G6 i s not re lated to John Sm

Enter two person-identi f ie rs ( name or number )

,

separated by semicolon. Enter "stop to stop.

Carmine Cousins;lll

Duplicate names for fir St per son - use nume r i

c

Enter two person-identi f ie r s ( name or number )

,

separated by semicolon. Enter "stop to stop.

163 ; 145

Shortest path between identifi ed persons:

Linda Lackluster i s child of

Millie Lackluster i s child of

Anna Pittypat i s parent of

Margaret Madison i s spouse of

Richard Madison i s child of

Victoria Pisces i s parent of

Maria Gotsocks is parent of

Elzbieta Gotsocks

Condensed path

:

Linda Lackluster i s niece of

Richard Madison is uncle of

Elzbieta Gotsocks

Proportion of common genetic material = O.OOOOOE+00
Figure 3 - Queries and Output (continued)

Enter two pe r s on- id en t i f i e r s (name or number)

separated by semicolon. Enter "stop" to stop.

094 ; 145

Shortest path between persons

Nancy Powers

Maxine Powers

Floyd Davis

Velorus Davis

Goldie Beacon

Norma Cousins

John Cousins

Janet Cousins

Richard Madison

Victoria Pisces

Maria Gotsocks

Elzbieta Gotsocks

Condensed path:

Nancy Powers

Janet Cousins

Elzbieta Gotsocks

Proportion of common genetic material =

id en t i f i ed

is child of

i s child of

is child of

is parent of

is parent of

i s parent of

is spouse of

is child of

is child of

i s parent of

is parent of

i s 2nd halfi s cousin of

of

0. OOOOOE+00

Enter two

separated

036;033

Shortest path

Myrna Whozat

Bentley Whatsis

Murgatroyd Whatsis

Martha Hamlisch

Melvin Hamlisch

Condensed path:

Myrna Whozat

Bentley Whatsis

Melvin Hamlisch

Proportion of common

pe r s on- i den t i f ie r s (name or number),

by semicolon. Enter "stop" to stop.

between identified persons

is parent of

1 s is

is

1 s is

child of

spouse of

parent of

mother of

step-brother of

genetic material = O.OOOOOE+00

Enter two person-identifiers (name or number),

separated by semicolon. Enter "stop" to stop.

031 ; 033

Shortest path between identified persons:

Marvin Hamlisch is child of

Martha Hamlisch is parent of

Melvin Hamlisch

Condensed path:

Marvin Hamlisch is half-brother of

Melvin Hamlisch

Proportion of common genetic material = 2.50000E-01
Page 6

Figure 3 - Queries and Output (continued)

Enter two pe r s on- i den t i f i e r s (name or number),

separated by semicolon. Enter "stop" to stop.

145 ; 090

Shortest path between identif

i

ed

Elzbieta Gotsocks is child of

Maria Gotsocks i s child of

U . Pisces is parent of

Richard Madison i s parent of

Janet Cousins is spouse of

John Cousins i s child of

Norma Cousins is child of

Goldie Beacon i s child of

Velorus Davis i s parent of

Floyd Davis i s parent of

Maxine Powers is spouse of

Tim Powers

Condensed path:

Elzbieta Gotsocks is cousin-in-law of

John Cousins is hal f - co u s in- in- la w once removed of

Tim Powers

Proportion of common genetic material = O.OOOOOE+00

Enter two pe r s on- i den t i f ie r s (name or number),

separated by semicolon. Enter "stop" to stop.

L6 ;R9

Shortest path between identifi ed persons

L6 is child of

L5 i s child of

L4 i s child of

L3 i s child of

L2 i s child of

LI i s child of

LO is parent of

Rl i s parent of

R2 i s parent of

R3 i s parent of

R4 is parent of

R5 i s parent of

R6 is parent of

R7 i s parent of

R8 is parent of

R9

Condensed path

:

L6 is 5th half-cousin 3 times removed of

R9

Proportion of common genetic material = 3.05176E-05
Page 7

Figure 3 - Queries and Output (continued)

Enter two pers

separated by s Wl : R14

o n- id e n t i f i e r s (name or number),

emicolon. Enter "stop" to stop.

personsSlhor te s t path between identified

Wl i s spouse of

LO Is parent of

Rl is parent of

R2 i s parent of

R3 is parent of

R4 is parent of

R5 is parent of

R6 i s parent of

R7 is parent of

R8 i s parent of

R9 is parent of

RIO is parent of

Rll is parent of

R12 is parent of

R13 is parent of

R14

Condensed path

Wl i s great*12-

R14

Proportion of common genetic material = O.OOOOOE+00

Enter two pe r s on- i den t i f ie rs (name

separated by semicolon

Enter "st

X8 ;L6

Shortest path between i dent if ied

X8 is child of

X7 i s child of

X6 i s child of

X5 i s child of

X4 is child of

X3 is spouse of

R4 is child of

R3 is child of

R2 is child of

Rl i s child of

LO i s parent of

LI i s parent of

L2 is parent of

L3 i s parent of

L4 is parent of

L5 is parent of

L6

or number )

,

I " to stop.

persons

Condensed

X8

R4

L6

Proportion

path

is great*3-grand-step-son of

is 3rd half-cousin 2 times removed of

of common genetic material = O.OOOOOE+00
Page 8

Figure 3 - Queries and Output (continued)

Enter two person-identifiers (name or number),

separated by semicolon. Enter "stop" to stop.

G5 ;G6

Shortest path between identified persons:

G5 is parent of

06

Condensed path:

G5 is mother of

G6

Proportion of common genetic material = 5.62500E-01

Enter two person-identifiers (name or number),

separated by semicolon. Enter "stop" to stop,

stop

End of re la t ion- f inde r .
Page 9

2.0 ADA

first compilation-unit #1 is package of global types and objects

package RELATION TYPES AND DATA is

MAX_PERSONS

NAME LENGTH

constant integer := 300;

constant integer := 20; — every PERSON has a unique 3-digit IDENTIFIER

IDENTIF IER_LENGTH

BUFFER LENGTH

constant integer := 3;

constant integer := 60;

subtype NAME RANGE is

subtype IDENTIFIER RANGE is

subtype BUFFER_RANGE is

subtype NAME TYPE is

subtype BUFFER TYPE is

subtype MESSAGE TYPE is

subtype INDEX TYPE is

subtype COUNTER is

subtype DIGIT TYPE is

type REAL is

type IDENTIFIER TYPE is

IDENTIFIER LENGTH;

range 0. .MAX_PERSONS

;

range 0. . integer'last

;

ranee '0' .

. '9'

;

— each person's record in the file identifies at most three — others directly related: father, mother, and spouse

type GIVEN_IDENTIFIERS is (FATHER_IDENT, MOTHER_IDENT, SPOUSE_IDENT )

;

type RELATIVE ARRAY is array (GIVEN IDENTIFIERS) of IDENTIFIER TYPE;

NULL_IDENT

REQUESTJDK

"Request OK

REQUEST_TO_STOP

"stop

constant IDENTIF lERJTYPE := constant MESSAGEJTYPE :=

constant BUFFER TYPE :=

•OOO'

type GENDERJTYPE

type RELATION TYPE

is (MALE, FEMALE);

is (PARENT, CHILD, SPOUSE, SIBLING, UNCLE,

NEPHEW, COUSIN, NULL_RELATION)

;

— directed edges in the graph are of a given subtype

subtype EDGE_TYPE is RELATION_TYPE range PARENT. . SPOUSE

;

— A node in the graph (= PERSON) has either already been reached, — is immediately adjacent to those reached, or farther away,

type REACHEDJTYPE is (REACHED, NEARBY, NOT_SEEN); — each PERSON has a linked list of adjacent nodes, called neighbors

type NEIGHBOR_RECORD;

type NEIGHBOR_POINTER is access NEIGHBOR_RECORD;

type NEIGHBOR_RECORD is

record

NEIGHBOR_INDEX : INDEX_TYPE;

NEIGHBOR_EDGE : EDGE_TYPE;

NEXT_NEIGHBOR : NEIGHBOR_POINTER;

end record;
Page 10 — All relationships are captured in the directed graph of which — each record is a node,

type PERSON_RECORD is

record — static information - filled from PEOPLE file:

NAME : NAME_TYPE;

IDENTIFIER : IDENTIFIERJTYPE

;

GENDER : GENDERJTYPE

;

— IDENTIFIERS of immediate relatives - father, mother, spouse

RELATIVE_IDENTIFIER : RELATIVE_ARRAY; — head of linked list of adjacent nodes

NEIGHBOR_LIST_HEADER : NEIGHBOR_POINTER; — data used when traversing graph to resolve user request

:

REAL;

INDEX_TYPE;

EDGE_TYPE

;

REACHED TYPE;

DI S TANCE_FROM_S OURCE

PATH_PREDECESSOR

EDGE_TO_PREDECESSOR

REACHED_STATUS — data used to compute common genetic material

DESCENDANT_IDENTIFIER : IDENTIFIERJTYPE;

DESCENDANT_GENES : REAL;

end record; — the PERSON array is the central repository of information — about inter-relationships.

PERSON : array (INDEX_TYPE) of PERSON_RECORD; — utility to truncate or fill with spaces

procedure COERCE_STRING (SOURCE : in string; TARGET : in out string);

end RELATION_TYPES_AND_DATA;

END SPECIFICATION BEGIN BODY

package body RELATION_TYPES_AND_DATA is

procedure COERCE_STRING (SOURCE : in string; TARGET : in out string) is

MANY SPACES : constant string (1..100) :=

begin

if SOURCE'length < TARGET'length then

TARGET (TARGET' first ..TARGET' first + SOURCE' length - 1) := SOURCE

TARGET (TARGET'first + SOURCE 'length .. TARGET'last) := MANY_SPACES ( 1 .. TARGET'length - SOURCE' length)

;

else — SOURCE longer than TARGET

TARGET := SOURCE (SOURCE 'first .. SOURCE 'first + TARGET'length - 1);

end if

;

end COERCE_STRING;

end RELATION TYPES AND DATA;
— new compilation-unit #2: main line of execution RELATE

with RELATION_TYPES_AND_DATA, text_io, sequent ial_io

;

use RELATION_TYPES_AND_DATA, text_io;

procedure RELATE is — this is the format of records in the file to be read in

type FILE_GENDER is ('M', 'F');

type FILE_PERSON_RECORD is

record

NAME : NAMEJTYPE;

IDENTIFIER : IDENTIFIER_TYPE

;

— 'M' for MALE and 'F' for FEMALE

GENDER : FILE_GENDER;

RELATIVE_IDENTIFIER : RELATIVE_ARRAY;

end record; — Instantiate generic package for file 10.

package PEOPLE_IO is new sequential_io (ELEMENTJTYPE => FILE_PERSON_RECORD)

;

— These variables are used when establishing the PERSON array — from the PEOPLE file.

PEOPLE : PEOPLE_IO . FILEJTYPE;

PEOPLE_RECORD : FILE_PERSON_RECORD;

C URRENT , NUMBER_OF_PERSONS

: INDEX_TYPE;

PREVIOUS_IDENT, CURRENT_IDENT

: "rDENTIFIER_TYPE;

RELATIONSHIP : GIVEN_IDENTIFIERS

;

— These variables are used to accept and resolve requests for — RELATIONSHIP information.

BUFFER_INDEX, SEMICOLON_LOCATION

: BUFFER_RANGE

;

REQUEST_BUFFER : BUFFERJTYPE

;

PERS0N1_IDENT, PERS0N2_IDENT

: NAMEJTYPE;

PERS0N1_F0UND, PERS0N2_F0UND

: COUNTER;

ERROR_MESSAGE : MESSAGE_TYPE

;

PERS0N1_INDEX, PERS0N2_INDEX

: INDEX TYPE;
Page 12 — declare procedures directly Invoked from RELATE:

procedure LINK_RELATIVES (FROM_INDEX : in INDEXJTYPE

;

RELATIONSHIP : in GIVEN_IDENTIFIERS

;

TO_INDEX : in INDEXJTYPE)

is separate;

procedure PROMPT_AND_READ is separate;

procedure CHECK_REQUEST (REQUEST_STATUS : out MESSAGE_TYPE

;

SEMICOLON_LOCATION : out BUFFER_RANGE

)

is separate;

procedure BUFFER_TO_PERSON (PERSON_ID : in out NAME_TYPE

;

START_LOCATION,

STOP_LOCATION : in BUFFER_RANGE

)

is separate;

procedure SEARCH_F OR_REQUE S TED_PERS ONS

(PERS0N1_IDENT, PERS0N2_IDENT : in NAMEJTYPE

;

PERS0N1_INDEX, PERS0N2_INDEX : out INDEX_TYPE;

PERS0N1_F0UND, PERS0N2_F0UND : in out COUNTER)

is separate;

procedure FIND_RELATIONSHIP ( TARGET_INDEX, SOURCE_INDEX : in INDEX_TYPE)

is separate; — *** execution of main sequence begins here *** —

begin

PEOPLE_IO . open (PEOPLE, PEOPLE_IO . IN_FILE, "PEOPLE.DAT"); — CURRENT location in array being filled

CURRENT := 0; — This loop reads in the PEOPLE file and constructs the PERSON — array from it (one PERSON = one record = one array entry). — As records are read in, links are constructed to represent the — PARENT-CHILD or SPOUSE RELATIONSHIP. The array then implements — a directed graph which is used to satisfy subsequent user — requests. The file is assumed to be correct - no validation — is performed on it.

READ_IN_PEOPLE:

while not PEOPLE_IO . end_of_file (PEOPLE) loop

PEOPLE_IO . read (PEOPLE, PEOPLE_RECORD )

;

CURRENT := CURRENT+1

;

— copy direct information from file to array

PERSON (CURRENT) . NAME := PEOPLE_RECORD . NAME;

PERSON (CURRENT) . IDENTIFIER := PEOPLE_RECORD . IDENTIFIER;

if PEOPLE_RECORD . GENDER = 'M' then

PERSON (CURRENT) . GENDER := MALE;

else

PERSON (CURRENT) . GENDER := FEMALE;

end if

;

PERSON (CURRENT) . RELATIVE_IDENTIFIER := PEOPLE_RECORD . RELATIVE_IDENTIFIER;

-- Location of adjacent persons as yet undetermined

PERSON (CURRENT) . NEIGHBOR_LIST_HEADER := null; ~ Descendants as yet undetermined

PERSON (CURRENT) . DESCENDANT_IDENTIFIER := NULL_IDENT;

CURRENT IDENT := PERSON (CURRENT) . IDENTIFIER;
— Compare this PERSON against all previously entered PERSONS — to search for RELATIONSHIPS.

COMPARE_TO_PRE VIOUS

:

for PREVIOUS in 1..CURRENT-1 loop

PREVIOUS_IDENT := PERSON (PREVIOUS) . IDENTIFIER;

RELATIONSHIP := FATHER_IDENT

;

— Search for father, mother, or spouse relationship in — either direction between this and PREVIOUS PERSON. — Assume at most one RELATIONSHIP exists.

TRY_ALL_RELATIONSHIPS

:

loop

if PERSON (CURRENT) . RELATIVE_IDENTIFIER (RELATIONSHIP) = PREVIOUS_IDENT

then

LINK_RELATIVES (CURRENT, RELATIONSHIP, PREVIOUS);

exit TRY_ALL_RELATIONSHIPS

;

else

if CURRENT_IDENT = PERSON (PREVIOUS) . RELATIVE_IDENTIFIER (RELATIONSHIP)

then

LINK_RELATIVES (PREVIOUS, RELATIONSHIP, CURRENT);

exit TRY_ALL_RELATIONSHIPS

;

end if

;

end if

;

if RELATIONSHIP < SPOUSE_IDENT then

RELATIONSHIP := GIVEN_IDENTIFIERS'succ(RELATIONSHIP)

;

else

exit TRY_ALL_RELATIONSHIPS

;

end if

;

end loop TRY_ALL_RELATIONSHIPS

;

end loop COMPARE_TO_PREVIOUS

;

end loop READ_IN_PEOPLE

;

NUMBER_OF_PERSONS := CURRENT;

PEOPLE_IO . close (PEOPLE); — PERSON array is now loaded and edges between immediate relatives — (PARENT-CHILD or SPOUSE-SPOUSE) are established. — While-loop accepts requests and finds RELATIONSHIP (if any) — between pairs of PERSONS

.
Page 14

READ_AND_PROCESS_REQUEST

:

loop

PROMPT_AND_READ

;

exit READ_AND_PROCESS_REQUEST when REQUEST_BUFFER = REQUEST_TO_STOP;

CHECK_REQUEST (ERROR_MESSAGE, SEMICOLON_LOCATION)

;

— Syntax check of request completed. Now either display error — message or search for the two PERSONS.

if ERROR_MESSAGE = REQUEST_OK then — Request syntactically correct - — search for requested PERSONS.

BUFFER_TO_PERSON (PERS0N1_IDENT, 1, SEMICOLON_LOCATION - 1);

BUFFER_TO_PERSON (PERS0N2_IDENT , SEMICOLON_LOCATION + 1, BUFFER_LENGTH)

;

SEARCH_FOR_REQUESTED_PERSONS (PERS0N1_IDENT, PERS0N2_IDENT,

PERS0N1_INDEX, PERS0N2_INDEX,

PERS0N1_F0UND, PERS0N2_F0UND)

;

if (PERS0N1_F0UND = 1) and (PERS0N2_F0UND = 1) then — Exactly one match for each PERSON - proceed to — determine RELATIONSHIP, if any.

if PERS0N1_INDEX = PERS0N2_INDEX then

put (' ' & PERSON (PERS0N1_INDEX) . NAME & is identical to ");

if PERSON (PERS0N1_INDEX) . GENDER = MALE then

put_line( "himself . " )

;

else

put_line( "herself . " )

;

end if

;

else

FIND_RELATIONSHIP (PERS0N1_INDEX, PERS0N2_INDEX)

;

end if

;

else — either not found or more than one found

if PERS0N1_F0UND = 0 then

put_line (" First person not found.");

elsif PERS0N1_F0UND > 1 then

put_line (" Duplicate names for first person - use" & numeric identifier.");

end if

;

if PERS0N2_F0UND = 0 then

put_line (" Second person not found.");

elsif PERS0N2_F0UND > 1 then

put_line (" Duplicate names for second person - use" & numeric identifier.");

end if

;

end if; — processing of syntactically legal request

else

put_line (" Incorrect request format: " & ERROR_MESSAGE )

;

end if

;

end loop READ_AND_PROCESS_REQUEST

;

put_line (" End of relation-finder.");

end RELATE;
Page 15

new compilation-unit #3: procedures under RELATE

separate (RELATE)

procedure LINK_RELATIVES (FROM_INDEX : in INDEXJTYPE

;

RELATIONSHIP : in GIVEN_IDENTIFIERS

;

TO_INDEX : in INDEXJTYPE) is — establishes cross-indexing between immediately related PERSONS.

procedure LINK_ONE_WAY (FROM_INDEX : in INDEX_TYPE;

THIS_EDGE : in EDGE_TYPE

;

TO_INDEX : in INDEXJTYPE) is ~ Establishes the NEIGHBOR_RECORD from one PERSON to another

NEW_NEIGHBOR : NEIGHBORJPOINTER

;

beg in

NEW_NEIGHBOR := new NEIGHBOR_RECORD

'(NEIGHBOR_INDEX => TO_INDEX,

NEIGHBOR_EDGE => THIS_EDGE,

NEXTJIEIGHBOR => PERSON (FROM_INDEX) . NEIGHBORJLIST_HEADER)

;

PERSON (FROM_INDEX) . NEIGHBOR_LIST_HEADER := NEW_NEIGHBOR;

end;

begin — execution of LINK_RELATIVES

if RELATIONSHIP = SPOUSE_IDENT then

LINKJDNEJWAY (FROM_INDEX, SPOUSE, TO_INDEX);

LINK_ONE_WAY (TO_INDEX, SPOUSE, FROM_INDEX);

else — RELATIONSHIP is father or mother

LINK_ONE_WAY (FROM_INDEX, PARENT, TO_INDEX);

LINKJ3NE_WAY (TO_INDEX, CHILD, FROM_INDEX);

end if

;

end LINK_RELATIVES;

separate (RELATE)

procedure PROMPT_AND_READ is — Issues prompt for user-request, reads in request, — blank-fills buffer, and skips to next line of input.

LAST_FILLED : natural;

begin

put_line (" ");

put_line (" ");

put_line (" Enter two person-identifiers (name or number),");

put_line (" separated by semicolon. Enter ""stop"" to stop.");

get~line (REQUEST_BUFFER, LAST_F ILLED )

;

COERCE_STRING (" ", REQUEST_BUFFER (LAST_FILLED+1 . . BUFFER_LENGTH) )

;

end PROMPT AND READ;
Page 16

separate (RELATE)

procedure CHECK_REQUEST (REQUEST_STATUS : out MESSAGE_TYPE

;

SEMICOLON_LOCATION : out BUFFER_RANGE ) is — Performs syntactic check on request in buffer.

SEMICOLONJCOUNT : COUNTER;

PERS0N1_F IELD_EXISTS , PERS0N2_F IELD_EXI STS

: boolean;

beg in

REQUEST_STATUS := REQUEST_OK;

SEMICOLON_LOCATION := 1; PERS0N1_FIELD_EXISTS := false;

PERS0N2_FIELD_EXISTS := false;

SEMICOLON_COUNT := 0;

for BUFFER_INDEX in BUFFER_RANGE loop

if REQUEST_BUFFER (BUFFER_INDEX) /= ' ' then

if REQUEST_BUFFER (BUFFER_INDEX) = ';' then

SEMICOLON_LOCATION := BUFFER_INDEX;

SEMICOLON_COUNT := SEMICOLONJCOUNT + 1; else — Check for non-blanks before/after semicolon,

if SEMICOLONJCOUNT < 1 then

PERS0N1_FIELD_EXISTS := true;

else

PERS0N2_FIELD_EXISTS := true;

end if

;

end if;

end if

;

end loop; — set REQUEST_STATUS, based on results of scan of REQUEST_BUFFER.

if SEMICOLON_COUNT /= 1 then

REQUEST_STATUS := "must be exactly one semicolon. "; elsif not PERS0N1_FIELD_EXISTS then

REQUEST_STATUS := "null field preceding semicolon. "; elsif not PERS0N2_FIELD_EXISTS then

REQUEST_STATUS := "null field following semicolon. "; end if

;

end CHECK_REQUEST;

separate (RELATE)

procedure BUFFER_TO_PERSON (PERSON_ID : in out NAMEJIYPE

;

START_LOCATION,

STOPJ.OCATION : in BUFFERJIANGE ) is — fills in the PERSON_ID from the designated portion — of the REQUEST_BUFFER.

FIRST_NON_BLANK : BUFFER_RANGE

;

begin

FIRST_NON_BLANK := STARTJ.OCATION;

while REQUEST_BUFFER (FIRST_NON_BLANK) = ' ' loop

FIRSTJJON_BLANK := FIRSTJS10N_BLANK + 1; end loop

;

COERCE_STRING (REQUEST_BUFFER (FIRST_NON_BLANK. . STOP_LOCATION)

,

PERSON_ID);

end BUFFER TO PERSON;
separate (RELATE)

procedure SEARCH_FOR_REQUESTED_PERSONS

(PERS0N1_IDENT, PERS0N2_IDENT : in NAME_TYPE

PERS0N1_INDEX, PERS0N2_INDEX : out INDEX_TYPE;

PERS0N1_F0UND, PERS0N2_F0UND : in out COUNTER) is — SEARCH_FOR_REQUESTED_PERSONS scans through the PERSON array, — looking for the two requested PERSONS. Match may be by NAME — or unique IDENTIFIER-number

THIS_IDENT : NAMEJTYPE

begin

PERSON 1_F0UND := 0;

PERS0N2_F0UND := 0;

PERS0N1_INDEX := 0;

PERS0N2_INDEX := 0;

SCAN_ALL_PERSONS

for CURRENT in 1. .NUMBER_OF_PERSONS loop — THIS_IDENT contains CURRENT PERSON'S numeric IDENTIFIER — left- justified , padded with blanks.

COERCE_STRING ( " "

, THIS_IDENT);

for IDENTIFIER_INDEX in IDENTIFIER_RANGE loop

THIS_IDENT (IDENTIFIER_INDEX) := PERSON (CURRENT) . IDENTIFIER (IDENTIFIER_INDEX)

end loop; — allow identification by name or number,

if (PERS0N1_IDENT = THIS_IDENT) or (PERS0N1_IDENT = PERSON (CURRENT) . NAME)

then

PERS0N1_F0UND := PERS0N1_F0UND + 1; PERS0N1_INDEX := CURRENT;

end if

if (PERS0N2_IDENT = THIS_IDENT) or (PERS0N2_IDENr = PERSON (CURRENT) . NAME)

then

PERS0N2_F0UND := PERS0N2_F0UND + 1; PERS0N2_INDEX := CURRENT;

end if;

end loop SCAN_ALL_PERSONS

end SEARCH FOR REQUESTED PERSONS;
Page 18

separate (RELATE)

procedure FIND_RELATIONSHIP ( TARGET_INDEX, SOURCE_INDEX : in INDEXJTYPE) — Finds shortest path (if any) between two PERSONS and — determines their RELATIONSHIP based on immediate relations — traversed in path. PERSON array simulates a directed graph, — and algorithm finds shortest path, based on following — weights: PARENT-CHILD edge = 1.0

SPOUSE-SPOUSE edge = 1.8

type SEARCH TYPE is (SEARCHING, SUCCEEDED, FAILED);

SEARCH_STATUS : SEARCH_TYPE

;

THIS_NODE, ADJACENT_NODE, BEST_NEARBY_INDEX, LAST_NEARBY_INDEX

INDEX_TYPE;

array (INDEX_TYPE) of INDEX_TYPE

;

EDGE_TYPE

;

NEIGHBOR_POINTER;

GIVEN_IDENTIFIERS

;

REAL;

NEARBY_NODE

THIS_EDGE

THIS_NEIGHBOR

RELATIONSHIP

MINIMAL DISTANCE

procedure PROCESS ADJACENT NODE (BASE NODE, NEXT NODE : in INDEX TYPE;

NEXT_BASE_EDGE

is separate;

procedure RESOLVE_PATH_TO_ENGLISH is separate;

procedure COMPUTE_COMMON_GENES (INDEXl, INDEX2 : is separate;

in EDGE TYPE)

in INDEX TYPE)

begin — execution of FIND_RELATIONSHIP — initialize PERSON-array for processing - — mark all nodes as not seen

for PERSON_INDEX in 1 . . NUMBER_OF_PERSONS loop

PERSON (PERSON_INDEX) . REACHED_STATUS := NOT_SEEN;

end loop;

THIS_NODE := SOURCE_INDEX; — mark source node as REACHED

PERSON (THIS_NODE) . REACHED_STATUS := REACHED;

PERSON (THIS_NODE) . DISTANCE_FROM_SOURCE := 0.0; — no NEARBY nodes exist yet

LAST_NEARBY_INDEX := 0;

if THIS_NODE = TARGE T_INDEX then

SEARCH_STATUS := SUCCEEDED;

else

SEARCH_STATUS := SEARCHING;

end if

;
Page 19 — Loop keeps processing closest-to-source , unREACHED node — until target REACHED, or no more connected nodes.

SEARCH_FOR_TARGET

:

while SEARCH_STATUS = SEARCHING loop — Process all nodes adjacent to THIS_NODE

THIS_NEIGHBOR := PERSON (THIS_NODE) . NEIGHBOR_LIST_HEADER

;

while THIS_NEIGHBOR /= null loop

PROCESS_ADJACENT_NODE (THIS_NODE

,

THIS_NEIGHBOR . NEIGHBOR_INDEX,

THIS_NEIGHBOR . NEIGHBOR_EDGE )

;

THISJJEIGHBOR := THIS_NEIGHBOR . NEXT_NEIGHBOR

;

end loop; — All nodes adjacent to THIS_NODE are set. Now search for — shortest-distance unREACHED (but NEARBY) node to process next.-

if LAST_NEARBY_INDEX = 0 then

SEARCH_STATUS := FAILED;

else — determine next node to process

MINIMAL_DI STANCE := l.Oe+18;

for PERSON_INDEX in 1 . . LAST_NEARBY_INDEX loop

if PERSON (NEARBY_NODE (PERSON_INDEX) ) . DISTANCE_FROM_SOURCE

< MINIMALJDISTANCE

then

BEST_NEARBY_INDEX := PERSON_INDEX;

MINIMAL_DISTANCE := PERSON (NEARBY_NODE (PERSON_INDEX) ) . DISTANCE_FROM_SOURCE

;

end if

;

end loop; — establish new THIS_NODE

THIS_NODE := NEARBY_NODE (BEST_NEARBY_INDEX)

;

— change THIS_NODE from being NEARBY to REACHED

PERSON (THIS_NODE) . REACHED_STATUS := REACHED; — remove THIS_NODE from NEARBY list

NEARBY_NODE (BEST_NEARBY_INDEX) := NEARBY_NODE ( LAST_NEARBY_INDEX )

;

LAST_NEARBY_INDEX := LAST_NEARBY_INDEX - 1; if THIS_NODE = TARGET_INDEX then

SEARCH_STATUS := SUCCEEDED;

end if

;

end if

;

end loop SEARCH_FOR_TARGET

;

— Shortest path between PERSONS now established. Next task is — to translate path to English description of RELATIONSHIP.

if SEARCH_STATUS = FAILED then

put_line (' ' & PERSON ( TARGET_INDEX) . NAME &

" is not related to " & PERSON (SOURCE_INDEX) . NAME);

else — success - parse path to find and display RELATIONSHIP

RESOLVE_PATH_TO_ENGLISH

;

COMPUTE_COMMON_GENES (SOURCE_INDEX, TARGET_INDEX)

;

end if

;

end FIND RELATIONSHIP;

I
;e 20

new compilation-unit #4: procedures under FIND_RELATIONSHIP

separate (RELATE . FIND_RELATIONSHIP)

procedure PROCESS_ADJACENT_NODE (BASEJJODE, NEXT_NODE : in INDEXJTYPE;

NEXT_BASE_EDGE : in EDGEJTYPE) is — NEXT_NODE is adjacent to last-REACHED node (= BASE_NODE)

.

— if NEXT_NODE already REACHED, do nothing. — If previously seen, check whether path thru BASE_NODE is — shorter than current path to NEXT_NODE, and if so re-link — next to base

.

— If not previously seen, link next to base node.

WEIGHT_THIS_EDGE, DISTANCE_THRU_BASE_NODE : REAL;

procedure LINK_NEXT_NODE_TO_BASE_NODE is — link next to base by re-setting its predecessor index to — point to base, note type of edge, and re-set distance — as it is through base node.

begin ~ execution of LINK_NEXT_NODE_TO_BASE_NODE

PERSON (NEXT_NODE) . DISTANCE_FROM_SOURCE := DISTANCE_THRU_BASE_NODE

PERSON (NEXTJJODE) . PATH_PREDECESSOR := BASE_NODE

;

PERSON (NEXT_NODE) . EDGE_TO_PREDECESSOR := NEXT_BASE_EDGE

;

end LINK_NEXT_NODE_TO_BASE_NODE

;

begin — execution of PROCESS_ADJACENT_NODE

if PERSON (NEXT_NODE) . REACHED_STATUS /= REACHED then

if NEXT_BASE_EDGE = SPOUSE then

WEIGHT_THIS_EDGE := 1.8;

else

WEIGHT_THIS_EDGE := 1.0;

end if

;

DISTANCE_THRU_BASE_NODE := WEIGHT_THIS_EDGE +

PERSON (BASE_NODE) . DISTANCE_FROM_SOURCE

;

if PERSON (NEXTJJODE) . REACHED_STATUS = NOT_SEEN then

PERSON (NEXT_NODE) . REACHED_STATUS := NEARBY;

LAST_NEARBY_INDEX := LAST_NEARBY_INDEX + 1; NEARBY_NODE (LAST_NEARBY_INDEX) := NEXT_NODE;

LINK_NEXT_NODE_TO_BASE_NODE

;

else ~ REACHED_STATUS = NEARBY

if DISTANCE_THRU_BASE_NODE

< PERSON (NEXT_NODE) . DISTANCE_FROM_SOURCE

then

LINK_NEXr_NODE_TO_BASE_NODE

;

end if

;

end if

;

end if

;

end PROCESS ADJACENT NODE;
Page 21

separate (RELATE . FIND_RELATIONSHIP

procedure RESOLVE_PATH_TO_ENGLISH is -- RESOLVE_PATH_TO_ENGLISH condenses the shortest path to a — series of RELATIONSHIPS for which there are English — descriptions. — Key persons are the ones in the RELATIONSHIP path which remain — after the path is condensed.

type SIBLINGJIYPE is (STEP, HALF, FULL);

type KEY_PERSON_RECORD (RELATION_TO_NEXT : RELATION_TYPE := PARENT) is

record

PERSON_INDEX : INDEXJIYPE ; GENERATION_GAP : COUNTER;

PROXIMITY : SIBLINGJTYPE

case RELATION_TO_NEXT is

when COUSIN => COUSIN_RANK : COUNTER;

when others => null;

end case;

end record; — these variables are used to generate KEY_PERSONs

GENERATION_COUNT : COUNTER; ~

THIS_COUSIN_RANK : COUNTER;

THIS_PROXIMITY : SIBLINGJTYPE; — these variables are used to condense the path

KEY_PERSON : array (INDEXJTYPE) of KEY_PERSON_RECORD

KEY_RELATION, LATER_KEY_RELATION, PRIMARY_RELATION,

NEXT_PRIMARY_RELATION : RELATION_TYPE

KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX

: INDEXJIYPE;

ANOTHER_ELEMENT_POSSIBLE : boolean;

function FULL_SIBLING (INDEXl, INDEX2 : in INDEXJTYPE)

return boolean is — Determines whether two PERSONS are full siblings, i.e., — have the same two parents

begin

return

PERSON (INDEXl) . RELATIVE_IDENTIFIER (FATHER_IDENT) /= NULL_IDENT and

PERSON (INDEXl) . RELATIVE_IDENTIFIER (MOTHER_IDENT) /= NULL_IDENT and

PERSON (INDEXl) . RELATIVE_IDENTIFIER (FATHER_IDENT) = PERSON (INDEX2) . RELATIVE_IDENTIFIER ( FATHER_IDENT) and

PERSON (INDEXl) . RELATIVE_IDENTIFIER (MOTHER_IDENT) = PERSON (INDEX2) . RELATIVE_IDENTIFIER (MOTHER_IDENT )

end FULL SIBLING;
Page 22

procedure CONDENSE_KEY_PERSONS (AT_INDEX : in INDEXJTYFE;

GAP_SIZE : in COUNTER) is — CONDENSE_KEY_PERSONS condenses superfluous entries from the — KEY_PERSON array, starting at AT_INDEX.

RECEIVE_INDEX, SEND_INDEX : INDEXJTYPE;

begin

RECEIVE_INDEX := AT_INDEX;

loop

RECEIVE_INDEX := RECEIVE_INDEX + 1; SEND_INDEX := RECEIVE_INDEX + GAP_SIZE;

KEY_PERSON (RECEIVE_INDEX) := KEY_PERSON (SEND_INDEX)

;

exit when KEY_PERSON (SEND_INDEX) . RELAXION_TO_NEXT = NULL_RELATION;

end loop;

end CONDENSE_KEY_PERSONS;

procedure DISPLAY_RELATION (FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX

: in INDEXJIYPE)

is separate;

begin — execution of RESOLVE_PATH_TO_ENGLISH

put_line (" Shortest path between identified persons: ");

THIS_NODE := TARGET_INDEX;

KEY_INDEX := 1; — Display path and initialize KEY_PERSON array from path elements.

TRAVERSE_SHORTEST_PATH: ~

while THIS_NODE /= SOURCE_INDEX loop

put (' ' & PERSON (THIS_NODE) . NAME &

" is "); case PERSON (THIS_NODE) . EDGE_TO_PREDECESSOR is

when PARENT => put_line ("parent of");

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => THIS_NODE,

GENERATION_GAP => 1,

PROXIMITY => FULL,

RELATION_TO_NEXT => PARENT);

when CHILD => put_line ("child of");

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => THIS_NODE,

GENERATION_GAP => 1,

PROXIMITY => FULL,

RELATION_TO_NEXT => CHILD);

when SPOUSE => put_line ("spouse of");

KEY_PERSON (KEY_INDEX) := (PERSON_INDEX => THIS_NODE,

GENERATION_GAP => 0,

PROXIMITY => FULL,

RELATION_TO_NEXT => SPOUSE);

end case

;

KEY_INDEX := KEY_INDEX + 1; THIS_NODE := PERSON (THIS_NODE) . PATH_PREDECESSOR;

end loop TRAVERSE SHORTEST PATH;
Page 23

put_line(' ' & PERSON (THIS_NODE) . NAME);

KEY_PERSON (KEY_INDEX) := (PERSON_INDEX => THIS_NODE,

GENERATION_GAP => 0,

PROXIMITY => FULL,

RELATION_TO_NEXT => NULL_RELATION)

;

KEY_PERSON (KEY_INDEX +1) := (PERSON_INDEX => 0,

GENERATION_GAP => 0,

PROXIMITY => FULL,

RELATION_TO_NEXT => NULL_RELATION)

;

— Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations — to SIBLING relations.

KEY_INDEX := 1; FIND_SIBLINGS:

while KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT /= NULL_RELATION loop

if KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD then

LATER_KEY_RELATION := KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT

;

if LATER_KEY_RELATION = PARENT then — found either full or half SIBLINGS

if FULL_SIBLING (KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

KEY_PERSON (KEY_INDEX + 2) . PERSON_INDEX)

then

THIS_PROXIMITY := FULL;

else

THIS_PROXIMITY := HALF;

end if

;

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

GENERATION_GAP => 0,

PROXIMITY => THIS_PROXIMITY,

RELATION_TO_NEXT => SIBLING);

CONDENSE_KEY_PERSONS (KEY_INDEX, 1);

elsif (LATER_KEY_RELATION = SPOUSE) and

(KEY_PERSON (KEY_INDEX + 2) . RELATION_TO_NEXT = PARENT)

then — found step-SIBLINGs

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

GENERATION_GAP => 0,

PROXIMITY => STEP,

RELATION_TO_NEXT => SIBLING);

CONDENSE_KEY_PERSONS (KEY_INDEX, 2);

end if; ~ LATER_KEY_RELATION = PARENT

end if; ~ RELATION_TO_NEXT = CHILD

KEY_INDEX := KEY_INDEX + 1; end loop FIND_SIBLINGS

;
Page 24— Resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to —- direct descendant or ancestor relations.

KEY_INDEX := 1; FIND_ANCESTORS_OR_DESCENDANTS

:

while KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT /= NULL_RELATION loop

if (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD) or (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = PARENT)

then

LATER_KEY_INDEX := KEY_INDEX + 1; while KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXr = KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT loop

LATER_KEY_INDEX := LATER_KEY_INDEX + 1;

end loop;

GENERATION_COUNT := LATER_KEY_INDEX - KEY_INDEX;

if GENERATION_COUNT > 1 then — compress generations

KEY_PERSON (KEY_INDEX) . GENERATION_GAP := GENERATION_COUNT

;

CONDENSE_KEY_PERSONS (KEY_INDEX, GENERATIONjCOUNT - 1);

end if;

end if; ~ if RELATION_TO_NEXT = CHILD or PARENT

KEY_INDEX := KEY_INDEX + 1; end loop FIND ANCESTORS OR DESCENDANTS;
Page — Resolve CHILD-SIBLING-PARENT to COUSIN,

CHILD-SIBLING to NEPHEW,

SIBLING-PARENT to UNCLE.

KEY_INDEX := 1; F IND_C OUS INS_NE PHEWS_UNCLE S

while KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT /= NULL_RELATION loop

LATER_KEY_RELATION := KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT

;

if (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD) and

(LATER_KEY_RELATION = SIBLING)

then ~ COUSIN or NEPHEW

if KEY_PERSON (KEY_INDEX + 2) . RELATION_TO_NEXT = PARENT then — found COUSIN

if KEYJPERSON (KEY_INDEX) . GENERATION_GAP < KEY_PERSON (KEY_INDEX + 2) . GENERATION_GAP

then

THIS_COUSIN_RANK := KEY_PERSON (KEY_INDEX) . GENERATION_GAP;

else

THIS_COUSIN_RANK := KEY_PERSON (KEY_INDEX + 2) . GENERATION_GAP;

end if

;

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

GENERATION_GAP => abs (KEY_PERSON (KEY_INDEX) . GENERATION_GAP - KEY_PERSON (KEY_INDEX + 2) . GENERATION_GAP)

,

PROXIMITY => KEY_PERSON (KEY_INDEX + 1) . PROXIMITY,

RELATION_TO_NEXT => COUSIN,

COUSINJRANK => THIS_COUSIN_RANK)

;

CONDENSE_KEY_PERSONS (KEY_INDEX, 2);

else — found NEPHEW

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

GENERATION_GAP => KEY_PERSON (KEY_INDEX) . GENERATION_GAP,

PROXIMITY => KEY_PERSON (KEY_INDEX + 1) . PROXIMITY,

RELATION_TO_NEXT => NEPHEW);

CONDENSE_KEY_PERSONS (KEY_INDEX, 1);

end if

;

elsif KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = SIBLING and

LATER_KEY_RELATION = PARENT

then — found UNCLE

KEY_PERSON (KEY_INDEX) : = (PERSON_INDEX => KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

GENERATION_GAP => KEY_PERSON (KEY_INDEX + 1) . GENERATION_GAP,

PROXIMITY => KEY_PERSON (KEY_INDEX) . PROXIMITY,

RELATION_TO_NEXT => UNCLE);

CONDENSE_KEY_PERSONS (KEY_INDEX, 1);

end if

;

KEY_INDEX := KEY_INDEX + 1; end loop FIND COUSINS NEPHEWS UNCLES;
Page 26— Loop below will pick out valid adjacent strings of elements — to be displayed. KEY_INDEX points to first element, — LATER_KEY_INDEX to laFt element, and PRIMARY_INDEX to the — element which determines the primary English word to be used. — Associativity of adjacent elements in condensed table — is based on English usage.

KEY_INDEX := 1; put_line (" Condensed path:");

CONSOLIDATE_ADJACENT_PERSONS

:

while KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT /= NULL_RELATION loop

KEY_RELATION := KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT

;

LATER_KEY_INDEX :=KEY_INDEX;

PRIMARY_INDEX := KEY_INDEX;

if KEYJPERSON (KEY_INDEX + 1) . RELATION_TO_NEXT /= NULL_RELATION then

' — seek multi-element combination

' ANOTHER_ELEMENT_POSSIBLE := true;

if KEY_RELATION = SPOUSE then

LATER_KEY_INDEX := LATER_KEY_INDEX + 1; PRIMARY_INDEX := LATER_KEY_INDEX;

if (KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = SIBLING) or (KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = COUSIN)

then — Nothing can follow SPOUSE-SIBLING or SPOUSE-COUSIN

ANOTHER_ELEMENT_POSSIBLE := false;

end if

;

end if

;

— PRIMARY_INDEX is now correctly set. Next if-statement — determines if a following SPOUSE relation should be — appended to this combination or left for the next

•— combination.

if ANOTHER_ELEMENT_POSSIBLE and

(KEY_PERSON (PRIMARY_INDEX + 1) . RELATION_TO_NEXT = SPOUSE) — Only a SPOUSE can follow a Primary

then— check primary preceding and following SPOUSE.

PRIMARY_RELATION : = KEY_PERSON (PRIMARY_INDEX) . RELATION_TO_NEXT

;

NEXT_PRIMARY_RELATION : = KEY_PERSON (PRIMARY_INDEX + 2) . RELATION_TO_NEXT

;

if (NEXT_PRIMARY_RELATION = NEPHEW or NEXT_PRIMARY_RELATION = COUSIN or NEXT_PRIMARY_RELATION = NULL_RELATION)

or (PRIMARY_RELATION = NEPHEW)

or ( (PRIMARY_RELATION = SIBLING or PRIMARY_RELATION = PARENT)

and NEXT_PRIMARY_RELATION /= UNCLE ) then — append following SPOUSE with this combination.

LATER_KEY_INDEX := LATER_KEY_INDEX + 1; end if

;

end if

;

end if; — multi-element combination

DISPLAY_RELATION (KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX)

;

KEY_INDEX := LATER_KEY_INDEX + 1; end loop CONSOLIDATE_ADJACENT_PERSONS

;

put_line (' ' & PERSON (KEY_PERSON (KEY_INDEX) . PERSON_INDEX) . NAME);

end; — RESOLVE PATH TO ENGLISH
new compilation-unit #5: procedures under RESOLVE_PATH_TO_ENGLISH

separate (RELATE . FIND_RELATIONSHIP . RESOLVE_PATH_TO_ENGLISH)

procedure DISPLAY_RELATION (FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX

: in INDEX_TYPE) is — DISPLAY_RELATION takes 1, 2, or 3 adjacent elements in the — condensed table and generates the English description of — the relation between the first and last + 1 elements.

INLAW : boolean;

THIS_PROXIMITY : SIBLINGJTYPE

THIS_GENDER : GENDERJTYPE

FIRST_RELATION, LAST_RELATION, PRIMARY_RELATION

: RELATION_TYPE

THIS_GENERATION_GAP , THIS_C OUS IN_RANK

: COUNTER; — need to instantiate package to display integer values

package COUNTER_IO is

new integer io (COUNTER);
Page 28

begin — execution of DISPLAY_RELATION

FIRST_RELATION := KEY_PERSON (FIRST_INDEX) . RELATION_TO_NEXT

;

LAST_RELATION := KEY_PERSON (LAST_INDEX) . RELATION_TO_NEXT

;

PRIMARY_RELATION := KEY_PERSON (PRIMARY_INDEX) . RELATION_TO_NEXT

;

— set THIS_PROXIMITY

if ((PRIMARY_RELATION = PARENT) and (FIRST_RELATION = SPOUSE)) or ((PRIMARY_RELATION = CHILD) and (LAST_RELATION = SPOUSE))

then

THIS_PROXIMITY := STEP;

elsif PRIMARY_RELATION = SIBLING or PRIMARY_RELATION = UNCLE or PRIMARY_RELATION = NEPHEW or PRIMARY_RELATION = COUSIN

then

THISJPROXIMITY := KEY_PERSON (PRIMARY_INDEX) . PROXIMITY;

else

THIS_PROXIMITY := FULL;

end if

;

— set THIS_GENERATION_GAP

if PRIMARY_RELATION = PARENT or PRIMARY_RELATION = CHILD or PRIMARY_RELATION = UNCLE or PRIMARY_RELATION = NEPHEW or PRIMARY_RELATION = COUSIN

then

THIS_GENERATION_GAP := KEY_PERSON (PRIMARY_INDEX) . GENERATION_GAP;

else

THIS_GENERATION_GAP := 0;

end if

;

— set INLAW

INLAW := false;

if (FIRST_RELATION = SPOUSE) and

(PRIMARY_RELATION = SIBLING or PRIMARY_RELATION = CHILD or PRIMARY_RELATION = NEPHEW or PRIMARY_RELATION = COUSIN)

then

INLAW := true;

elsif (LAST_RELATION = SPOUSE) and

(PRIMARY_RELATION = SIBLING or PRIMARY_RELATION = PARENT or PRIMARY_RELATION = UNCLE or PRIMARY_RELATION = COUSIN)

then

INLAW := true;

end if

;

— set THIS_COUSIN_RANK

if PRIMARY_RELATION = COUSIN then

THIS_COUSIN_RANK := KEYJPERSON (PRIMARY_INDEX) . COUSIN_RANK;

end if

;
Page 29 — parameters are set - now generate display.

put (" " & PERSON (KEY_PERSON (FIRST_INDEX) . PERSON_INDEX) . NAME &

" is ");

if PRIMARY_RELATION = PARENT or PRIMARY_RELATION = CHILD or PRIMARY_RELATION = UNCLE or PRIMARY_RELATION = NEPHEW

then— display generation-qualifier

if THIS_GENERATION_GAP >= 3 then

put ("great");

if THIS_GENERATION_GAP > 3 then

put ("*");

COUNTER_IO . put (THIS_GENERATION_GAP - 2, width => 1);

end if

;

put ("-");

end if

;

if THIS_GENERATION_GAP >= 2 then

put ("grand-");

end if

;

elsif (PRIMARY_RELATION = COUSIN) and then (THIS_COUSIN_RANK > 1) then

COUNTER_IO . put (THIS_COUSIN_RANK, width => 1 )

;

case THIS_COUSIN_RANK mod 10 is

when 1 => put ("st ");

when 2 => put ("nd ");

when 3 => put ("rd ");

when others => put ("th ");

end case

;

end if

;

if THIS_PROXIMITY = STEP then

put ("step-");

elsif THIS_PROXIMITY = HALF then

put ("half-");

end if

;
Page 30

THIS_GENDER := PERSON (KEY_PERSON (FIRST_INDEX)

case PRIMARY_RELATION is

when PARENT

when CHILD

PERSON INDEX) . GENDER;

when SPOUSE

when UNCLE

when NEPHEW

. when COUSIN

when others

end case;

if THIS GENDER = MALE then put ('"father");

else put (

' "mother" )

;

end if

;

if THIS_GENDER = MALE then put (' "son")

;

else put ([ "daughter" )

;

end if

;

if THIS GENDER = MALE then put ([ "husband" )

;

else put ([ "wife" )

;

end if

;

if THIS_GENDER = MALE then put <[ "brother" )

;

else put (^"sister");

end if

;

if THIS_GENDER = MALE then put ([ "uncle" )

;

else put ([ "aunt" )

;

end if

;

if THIS GENDER = MALE then put ([ "nephew" )

;

else put ([ "niece" )

;

end if

;

put ("cousin");

put ("null");

if INLAW then

put ("-in-law");

end if

;

if (PRIMARY_RELATION = COUSIN) and (THIS_GENERATION_GAP > 0) then

if THIS_GENERATION_GAP > 1 then

put (" ");

COUNTER_IO , put (THIS_GENERATION_GAP, width => 1);

put (" times removed");

else

put (" once removed");

end if

;

end if;

put_line (" of");

end DISPLAY RELATION;
new compilation-unit #5: procedures under FIND_RELATIONSHIP

eparate (RELATE . FIND_RELATIONSHIP)

rocedure COMPUTE_COMMON_GENES (INDEXl, INDEX2 : in INDEX_TYPE) i ~ COMPUTE_COMMON_GENES assumes that each ancestor contributes — half of the genetic material to a PERSON. It finds common — ancestors between two PERSONS and computes the expected — value of the PROPORTION of common material.

COMMON_PROPORTION : REAL;

package REAL_IO is new FLOAT_rO (REAL);

procedure ZERO_PROPORTION (ZERO_INDEX : in INDEXJTYPE) is — ZERO_PRO PORTION recursively seeks out all ancestors and — zeros them out.

THIS_NEIGHBOR : NEIGHBOR_POINTER

;

begin

PERSON (ZERO_INDEX) . DESCENDANT_GENES := 0.0;

THIS_NEIGHBOR := PERSON (ZERO_INDEX) . NEIGHBOR_LIST_HEADER

;

while THIS_NEIGHBOR /= null loop

if THIS_NEIGHBOR . NEIGHBOR_EDGE = PARENT then

ZERO_PROPORTION (THIS_NEIGHBOR . NEIGHBOR_INDEX)

;

end if

;

THIS_NEIGHBOR := THIS_NEIGHBOR . NEXTJJEIGHBOR;

end loop;

end ZERO_PR0P0RTION;

procedure MARK_PROPORTION (MARKER : in IDENTIFIER_TYPE

;

PROPORTION : in REAL;

MARKED_INDEX : in INDEXJTYPE) is — MARK_PROPORTION recursively seeks out all ancestors and — markJ them with the sender's PROPORTION of shared — genetic material. This PROPORTION is diluted by one-half — for each generation.

THIS_NEIGHBOR : NEIGHBOR_POINTER;

begin

PERSON (MARKED_INDEX) . DESCENDANT_IDENTIFIER := MARKER;

PERSON (MARKED_INDEX) . DESCENDANT_GENES := PERSON (MARKED_INDEX) . DESCENDANT_GENES + PROPORTION;

THIS_NEIGHBOR := PERSON (MARKED_INDEX) . NEIGHBOR_LIST_HEADER

while THIS_NEIGHBOR /= null loop

if THIS_NEIGHBOR . NEIGHBOR_EDGE = PARENT then

MARK_PROPORTION (MARKER, PROPORTION / 2.0,

THIS_NEIGHBOR . NEIGHBOR_INDEX)

;

end if

;

THISJJEIGHBOR := THIS_NEIGHBOR . NEXT_NEIGHBOR;

end loop;

end MARK PROPORTION;
Page 32

procedure CHECK_COMMON_PROPORTION

(COMMON_PRO PORTION : in out REAL;

MATCH_IDENTIFIER : in IDENTIFIERJCYPE

;

PROPORTION : in REAL;

ALREADYJCOUNTED : in REAL;

CHECK_INDEX : in INDEXJTYPE) is — CHECK_COMMON_PROPORTION searches all the ancestors of — CHECK INDEX to see if any have been marked, and if so — adds the appropriate amount to COMMON_PROPORTION.

THIS_NEIGHBOR : NEIGHBOR_POINTER;

THIS CONTRIBUTION : REAL;

beg in

if PERSON (CHECK_INDEX) . DESCENDANT_IDENTIFIER = MATCH_IDENTIFIER then — Increment COMMON_PROPORTION by the contribution of — this common ancestor, but discount for the contribution — of less remote ancestors already counted.

THIS_CONTRIBUTION := PERSON (CHECK_INDEX) . DESCENDANT_GENES

* PROPORTION;

COMMON_PROPORTION := COMMON_PROPORTION + THIS_CONTRIBUTION - ALREADY_COUNTED;

else

THIS_CONTRIBUTION := 0.0;

end if

;

THISJJEIGHBOR := PERSON (CHECK_INDEX) . NEIGHBOR_LIST_HEADER;

while THIS_NEIGHBOR /= null loop

if THISJJEIGHBOR . NEIGHBOR_EDGE = PARENT then

CHECK_COMMON_PRO PORTION (COMMON_PROPORTION,

MATCH_IDENTIFIER, PROPORTION / 2.0,

THIS_CONTRIBUTION / 4.0,

THIS_NEIGHBOR . NEIGHBOR_INDEX)

;

end if;

THISJJEIGHBOR := THISJJEIGHBOR . NEXTJJEIGHBOR;

end loop;

end CHE CK_COMMONJ>ROPORTION;

begin — COMPUTEj:OMMON_GENES — First zero out all ancestors to allow adding. This is necessary — because there might be two paths to an ancestor.

ZERO_PROPORTION (INDEXl); — now mark with shared PROPORTION

MARKJ'ROPORTION (PERSON (INDEXl) . IDENTIFIER, 1.0, INDEXl);

COMMON_PROPORTION := 0.0;

CHECK_COMMON_PROPORTION (COMMONJ>ROPORTION,

PERSON (INDEXl) . IDENTIFIER, 1.0, 0.0, INDEX2);

put (" Proportion of common genetic material = ");

REAL_IO . put (COMMON_PROPORTION, fore => 1, aft => 5, exp => 3 )

;

put_line (" ");

end COMPUTE COMMON GENES;
Page 33

3.0 BASIC

Because of the unavailability of a standard implementation, the BASIC program

could not be tested directly. However, a syntactically non-standard version,

which is believed to be logically equivalent, was tested.

10000 ! program-unit number 1 10010 ! 10020 program RELATE

10030 ! 10040 ! declare subs to be used by this program-unit

10050 ! 10060 declare external sub FIND_RELATIONSHIP

10070 declare sub LINKJIELATIVES", LINK_0NE_WAY, PROMPT_AND_READ

10080 declare sub CHECK_REQUEST, SEARCH_FOR_REQUESTED_PERSONS

10090 ! 10100 option base 1 10110 ! 10120 ! Define global objects

10130 ! 10140 data 300

10150 read MAX_PERS0NS

10160 ! 10170 data 1, 2 ! for truth values

10180 read TRUE, FALSE

10190 ! 10200 ! each PERSON'S record in the file identifies at most three

10210 ! others directly related: father, mother, and spouse

10220 data 1, 2, 3

10230 read FATHER_IDENT, M0THER_IDENT, SP0USE_IDENT

10240 ! 10250 data M, F

10260 read MALE$, FEMALE $

10270 ! 10280 data 000

10290 read NULL_IDENT$

10300 ! 10310 data 1, 2, 3, 4, 5, 6, 7, 8

10320 read PARENT, CHILD, SPOUSE, SIBLING, UNCLE, NEPHEW

10325 read COUSIN, NULL_RELATI0N

10330 ! 10340 ! A node in the graph (= PERSON) has either already been reached,

10350 ! is immediately adjacent to those reached, or farther away.

10360 data 1, 2, 3

10370 read REACHED, NEARBY, N0T_SEEN

10380 !
Page 34

10390

10400

10410

10420

10430

10440

10450

10460

10470

10480

10490

10500

10505

10510

10520

10530

10540

10550

10560

10570

10580

10590

10600

10610

10620

10630

I dim

I

! dim

I

I dim

dim

!

I dim

dim

I

I dim

!

The following data arrays are the central repository of information

about inter-relationships. All relationships are captured in the

directed graph of which each record is a node.

static information - filled from PEOPLE file:

NAME$ (300), IDENTIFIER$ (300), GENDER$ (300)

IDENTIFIER$s of immediate relatives

RELATIVE IDENTIFIER$ (300,3)

father, mother, spouse

pointers to immediate neighbors in graph

NEIGHBORJCOUNT (300)

NEIGHBOR_INDEX (300,20), NEIGHB0R_EDGE (300,20)

data used when traversing graph to resolve user request:

DISTANCE_FR0M_S0URCE (300), PATH_PREDECESSOR (300)

EDGE_T0_PREDECESS0R (300), REACHED_STATUS (300)

data used to compute common genetic material

DESCENDANT IDENTIFIER$ (300), DESCENDANT GENES (300)

stop. Request OK

REQUEST TO STOP$, REQUEST 0K$

data

read

!

! end initialization

I

I
Page 35

10640 ! begin main line of execution

10650 ! 10660 open #1: name "PE0PLE.DAT", access input, rectype native, & & organization sequential

10670 ! 10680 ! This loop reads in the PEOPLE file and constructs the person

10690 ! array from it (one person = one set of array entries).

10700 ! As records are read in, links are constructed to represent the

10710 ! PARENT-CHILD or SPOUSE RELATIONSHIP. The array then implements

10720 ! a directed graph which is used to satisfy subsequent user

10730 ! requests. The file is assumed to be correct - no validation

10740 ! is performed on it.

10750 ! 10760 for CURRENT = 1 to MAX_PERS0NS

10770 read #1, if missing then exit for, & & with "string*20, string*3, string*l, 3 of string*3": & & NAME$ (CURRENT), IDENTIFIER$ (CURRENT), GENDER$ (CURRENT), & & RELATIVE_IDENTIFIER$ (CURRENT, FATHER_IDENT) , &

& RELATIVE_IDENTIFIER$ (CURRENT, M0THER_IDENT) , &

& RELATIVE_IDENTIFIER$ (CURRENT, SPOUSE_IDENT

)

10780 let NAME$ (CURRENT) = rtrim$ (NAME$ (CURRENT))

10790 ! Location of adjacent persons as yet undetermined

10800 let NEIGHB0R_C0UNT (CURRENT) = 0

10810 ! Descendants as yet undetermined

10820 let DESCENDANT_IDENTIFIER$ (CURRENT) = NULL_IDENT$

10830 let CURRENT_IDENT$ = IDENTIFIER$ (CURRENT)

10840 ! Compare this PERSON against all previously entered PERSONS

10850 ! to search for RELATIONSHIPS.

10860 for PREVIOUS = 1 to CURRENT - 1 10870 let PREVIOUS_IDENT$ = IDENTIFIER$ (PREVIOUS)

10880 ! Search for father, mother, or spouse relationship in

10890 ! either direction between this and PREVIOUS person.

10900 ! Assume at most one RELATIONSHIP exists.

10910 for RELATIONSHIP = FATHER_IDENT to SP0USE_IDENT

10920 if RELATIVE_IDENTIFIER$ (CURRENT, RELATIONSHIP) & & = PREVIOUS_IDENT$ then

10930 call LINK_RELATIVES (CURRENT, RELATIONSHIP, PREVIOUS)

10940 exit for

10950 elseif RELATIVE_IDENTIFIER$ (PREVIOUS, RELATIONSHIP) &

& = CURRENT_IDENT$ then

10960 call LINK_RELATIVES (PREVIOUS, RELATIONSHIP, CURRENT)

10970 exit for

10980 end if

10990 next RELATIONSHIP

11000 next PREVIOUS

11010 next CURRENT

11020 let NUMBER_OF_PERSONS = CURRENT - 1 11030 close #1

11040 ! 11050 ! Person arrays are now loaded and edges between immediate relatives

11060 ! (PARENT -CHILD or SPOUSE-SPOUSE) are established.

11070 !
Page 36

11080 ! Do-loop accepts requests and finds relationship (if any)

11090 ! between pairs of PERSONS.

11110 do

11120 call PROMPT_AND_READ

11130 if REQUEST_BUFFER$ = REQUEST_T0_ST0P$ then exit do

11140 call CHECK_REQUEST (ERR0R_MESSAGE$, PERS0N1_IDENT$, PERS0N2_IDENT$

)

11150 ! 11160 ! Syntax check of request completed. Now either display error

11170 ! message or search for the two PERSONS.

11180 ! 11190 if ERR0R_MESSAGE$ = REQUEST_0K$ then

11200 ! request syntactically correct

11210 call SEARCH_F0R_REQUESTED_PERS0NS(PERS0N1_IDENT$, PERS0N2_IDENT$, & & PERS0N1_INDEX, PERS0N2_INDEX, &

& PERS0N1_F0UND, PERS0N2_F0UND)

11220 if PERS0N1_F0UND = 1 and PERS0N2_F0UND = 1 then

11230 ! Exactly one match for each PERSON - proceed to

112A0 ! determine RELATIONSHIP, if any.

11250 if PERS0N1_INDEX = PERS0N2_INDEX then

11260 print " "; NAME$ (PERS0N1_INDEX) ; " is identical to "; 11270 if GENDER$ ( PERSON 1_INDEX) = MALE$ then

11280 print "himself."

11290 else

11300 print "herself."

11310 end if

11320 else

11330 call FIND_RELATIONSHIP &

& (PERS0N1_INDEX, PERS0N2_INDEX, NUMBER_0F_PERS0NS, & & NAME$, IDENTIFIER$, GENDER$, RELATIVE_IDENTIFIER$, & & NEIGHB0R_C0UNT, NEIGHBOR_INDEX, NEIGHB0R_EDGE , & & DISTANCE_FR0M_S0URCE, PATH_PREDECESSOR, &

& EDGE_T0_PREDECESS0R , REACHED_STATUS , &

& DESCENDANT_IDENTIFIER$, DESCENDANT_GENES

)

11340 end if

11350 else ! either not found or more than one found

11360 if PERS0N1_F0UND = 0 then

11370 print " First person not found."

11380 elseif PERS0N1_F0UND > 1 then

11390 print " Duplicate names for first person -";

11400 print " use numeric identifier."

11410 end if

11420 if PERS0N2_F0UND = 0 then

11430 print " Second person not found."

11440 elseif PERS0N2_F0UND > 1 then

11450 print " Duplicate names for second person -";

11460 print " use numeric identifier."

11470 end if

11480 end if

11490 else

11500 print " Incorrect request format: "; ERR0R_MESSAGE$

11510 end if

11520 loop

11530 print " End of relation-finder."

11540 stop

11550 ! 11560 ! end of main line of execution; internal subs follow
Page 37

11570 ! 11580 sub LINK_RELATIVES (FROM_INDEX, RELATIONSHIP, TO_INDEX)

11590 ! establishes cross-indexing between immediately related PERSONS.

11600 ! 11610 if RELATIONSHIP = SPOUSE_IDENT then

11620 call LINK_ONE_WAY (FROM_INDEX, SPOUSE, TO_INDEX)

11630 call LINK_ONE_WAY (TO_INDEX, SPOUSE, FROM_INDEX)

11640 else ! RELATIONSHIP is father or mother

11650 call LINK_ONE_WAY (FROM_INDEX, PARENT, TO_INDEX)

11660 call LINK_ONE_WAY (TO_INDEX, CHILD, FROM_INDEX)

11670 end if

11680 end sub

11690 ! 11700 sub LINK_ONE_WAY (FROM_INDEX, THIS_EDGE, TO_INDEX)

11710 ! Establishes the neighbor entries from one person to another

11720 ! 11730 let NEXT_NEIGHBOR = NEIGHBOR_COUNT (FROM_INDEX) + 1 11 740 let NEIGHBOR_COUNT (FROM_INDEX) = NEXT_NEIGHBOR

11750 let NEIGHBOR_INDEX (FROM_INDEX, NEXT_NEIGHBOR) = TO_INDEX

11760 let NEIGHBOR_EDGE (FROM_INDEX, NEXT_NEIGHBOR) = THIS_EDGE

11770 end sub

11780 ! 11790 sub PROMPT_AND_READ

11800 ! Issues prompt for user-request, reads in request,

11810 ! blank-fills buffer, and skips to next line of input.

11820 ! 11830 print

11840 print " " 11850 print " Enter two person-identifiers (name or number),"

11860 print " separated by semicolon. Enter ""stop"" to stop."

11870 line input REQUEST_BUFFER$

11880 end sub

11890 ! 11900 sub CHECK_REQUEST (REQUEST_STATUS $ , PERS0N1_IDENT$ , PERS0N2_IDENT$)

11910 ! Performs syntactic check on request in buffer

11920 ! and fills in identifiers of the two requested persons.

11930 ! 11940 let SEMICOLON_LOCATION = pos (REQUEST_BUFFER$ , ";")

11950 let PERS0N1_IDENT$ = ltrim$ (rtrim$ &

& (REQUEST_BUFFER$ (1 : SEMICOLONJLOCATION - 1)))

11960 let PERS0N2_IDENT$ = ltrim$ (rtrim$ & & (REQUEST_BUFFER$ (SEMICOLON_LOCATION + 1 : len (REQUEST_BUFFER$ ) ) )

)

11970 if SEMICOLON LOCATION = 0 or pos (PERS0N2 IDENT$, ";") <> 0 then

11980 let REQUEST_STATUS$

11990 el self PERSON1_I DENT

$

12000 let REQUEST_STATUS$

12010 elseif PERS0N2 IDENT$

must be exactly one semicolon."

then

null field preceding semicolon.'

" then

12020 let REQUEST_STATUS$ = "null field following semicolon.'

12030 else

12040 let REQUEST_STATUS$ = REQUEST_OK$

12050 end if

12060 end sub

12070 !
Page 38

12080 sub SEARCH FOR REQUESTED_PERSONS (PERSON 1_IDENT$, PERS0N2 IDENT$, &

& PERS0N1_INDEX, PERS0N2_INDEX, & & PERS0N1_F0UND, PERS0N2_F0UND)

12090 ! SEARCH_FOR_REQUESTED_PERSONS scans through the PERSON array,

12100 ! looking for the two requested PERSONS. Match may be by NAME

12110 ! or unique IDENTIFIER-number

12120 ! 12130 let PERSON 1_F0UND = 0

12140 let PERS0N2_F0UND = 0

12150 let PERS0N1_INDEX = 0

12160 let PERS0N2_INDEX = 0

12170 for CURRENT = 1 to NUMBER_OF_PERSONS

12180 ! allow identification by name or identifier

12190 if IDENTIFIER$ (CURRENT) = PERS0N1_IDENT$ & & or NAME$ (CURRENT) = PERS0N1_IDENT$ then

12200 let PERS0N1_INDEX = CURRENT

12210 let PERS0N1_F0UND = PERS0N1_F0UND + 1 12220 end if

12230 if IDENTIFIER$ (CURRENT) = PERS0N2_IDENT$ & & or NAME$ (CURRENT) = PERS0N2_IDENT$ then

12240 let PERS0N2_INDEX = CURRENT

12250 let PERS0N2_F0UND = PERS0N2_F0UND + 1 12260 end if

12270 next CURRENT

12280 end sub

12290 end ! of main program unit - external procedures follow

12300 I
Page 39

12310 ! program-unit number 2 12320 ! 12330 external sub FIND_RELATIONSHIP & & (TARGET_INDEX, S0URCE_INDEX, NUMBER_OF_PERSONS , & & NAME$ (), IDENTIFIER$ (), GENDER$ (), RELATIVE_IDENTIFIER$ (,), & & NEIGHB0R_COUNT (), NEIGHBOR_INDEX (,), NEIGHBOR_EDGE (,), & & DISTANCE_FROM_SOURCE (), PATH_PREDECESSOR (), & & EDGE_TO_ PREDECESSOR (), REACHED STATUS (), & & DESCENDANT_IDENTIFIER$ (), DESCENDANT_GENES ())

12340 ! 12350 ! Finds shortest path (if any) between two PERSONS and

12360 ! determines their RELATIONSHIP based on immediate relations

12370 ! traversed in path. PERSON array simulates a directed graph,

12380 ! and algorithm finds shortest path, based on following

12390 ! weights: PARENT-CHILD edge =1.0

12400 ! SPOUSE -SPOUSE edge = 1.8

12410 ! 12420 ! declare subs and functions to be used by this program-unit

12430 ! 12440 declare external sub COMPUTE_COMMON_GENES

12450 declare sub PROCESS_ADJACENT_NODE, LINK_NEXT_NODE_TO_BASE_NODE

12460 declare sub RESOLVE_PATH_TO_ENGLISH, CONDENSE_KEY_PERSONS

12465 declare sub DISPLAY_RELATION

12470 declare function SIBLING_PROXIMITY

12480 ! 12483 option base 1 12487 ! 12490 ! Define global objects

12500 ! 12510 data 300

12520 read MAX_PERS0NS

12530 ! 12540 data 1, 2 ! for truth values

12550 read TRUE, FALSE

12560 ! 12570 ! each PERSON'S record in the file identifies at most three

12580 ! others directly related: father, mother, and spouse

12590 data 1, 2, 3

12600 read FATHER_IDENT, MOTHER_IDENT, SPOUSE_IDENT

12610 ! 12620 data M, F

12630 read MALE$, FEMALE $

12640 ! 12650 data 000

12660 read NULL_IDENT$

12670 ! 12680 data 1, 2, 3, 4, 5, 6, 7, 8

12690 read PARENT, CHILD, SPOUSE, SIBLING, UNCLE, NEPHEW

12695 read COUSIN, NULL_RELATION

12700 ! 12710 ! A node in the graph (= PERSON) has either already been reached,

12720 ! is immediately adjacent to those reached, or farther away.

12730 data 1, 2, 3

12740 read REACHED, NEARBY, NOT_SEEN

12750 !
Page 40

12760

12770

12780

12790

12800

12810

12820

12830

12840

12850

12860

12870

12880

12890

12900

12910

12920

12930

12940

12950

12960

12970

12980

12990

13000

13010

13020

13030

13040

13050

13060

13070

13080

13090

13100

13110

data 1, 2, 3 ! values for search status

read SEARCHING, SUCCEEDED, FAILED

Idata 1, 2, 3 ! values for sibling proximity

read STEP, HALF, FULL

The following arrays contain information on key persons.

Key persons are the ones in the RELATIONSHIP path which remain

after the path is condensed.

RELATI0N_T0_NEXT (300), PERS0N_INDEX (300), GENERATION_GAP (300)

PROXIMITY (300), C0USIN_RANK (300)

keeps track of current NEARBY nodes in graph search

NEARBY NODE (300)

dim

dim

I

j dim

begin main line of execution of FIND_RELATIONSHIP

initialize PERSON-array for processing - mark all nodes as not seen

for THIS_NODE = 1 to NUMBER_OF_PERSONS

let REACHED_STATUS (THIS_NODE) = NOT_SEEN

next THIS_NODE

!let THIS_NODE = SOURCE_INDEX

! mark source node as REACHED

let REACHED_STATUS (THIS_NODE) = REACHED

let DISTANCE_FROM_SOURCE (THIS_NODE) = 0

! no nearby nodes exist yet

let LAST_NEARBY_INDEX = 0

if THIS_NODE = TARGET_INDEX then

let SEARCH_STATUS = SUCCEEDED

else

let SEARCH_STATUS = SEARCHING

end if

I
Page 41

13120 ! Loop keeps processing closest-to-source , unREACHED node

13130 ! until target REACHED, or no more connected nodes.

13140 do while SEARCH_STATUS = SEARCHING

13150 ! Process all nodes adjacent to THIS_NODE

13160 for THIS_NEIGHBOR = 1 to NEIGHB0R_C0UNT (THIS_N0DE)

13170 call PROCESS_ADJACENT_NODE (THIS_N0DE, &

& NEIGHBOR_INDEX (THIS_N0DE, THIS_NEIGHBOR) , &

& NEIGHB0R_EDGE (THIS_N0DE, THIS_NEIGHBOR)

)

13180 next THIS_NEIGHB0R

-"13190 ! All nodes adjacent to THIS_N0DE are set. Now search for

13200 ! shortest-distance unREACHED (but NEARBY) node to process next.

13210 if LAST_NEARBY_INDEX = 0 then

13220 let SEARCH_STATUS = FAILED

13230 else ! determine next node to process

13240 let MI NIMAL_DISTANCE = l.OE+18

13250 ! now find closest unreached node

13260 for THIS_NEARBY_INDEX = 1 to LAST_NEARBY_INDEX

13270 let NEXT_N0DE = NEARBY_N0DE (THIS_NEARBY_INDEX)

13280 if DISTANCE_FR0M_S0URCE (NEXT_N0DE) < MINIMAL_DISTANCE then

13290 let BEST_NEARBY_INDEX = THIS_NEARBY_INDEX

13300 let MINIMALJDI STANCE = DISTANCE_FROM_SOURCE (NEXT_N0DE)

13310 end if

13320 next THIS_NEARBY_INDEX

13330 ! establish new THIS_N0DE

13340 let THIS_N0DE = NEARBY_N0DE ( BEST_NEARBY_INDEX)

13350 ! change THISJJODE from being NEARBY to REACHED

13360 let REACHED_STATUS (THIS_N0DE) = REACHED

13370 ! remove THIS_N0DE from NEARBY list

13380 let NEARBY_N0DE (BEST_NEARBY_INDEX) = &

& NEARBY_N0DE (LAST_NEARBY_INDEX)

13390 let LAST_NEARBY_INDEX = LAST_NEARBY_INDEX - 1 13400 if THIS_N0DE = TARGET_INDEX then let SEARCH_STATUS = SUCCEEDED

13410 end if

13420 loop

13430 ! 13440 ! Shortest path between PERSONS now established. Next task is

13450 ! to translate path to English description of RELATIONSHIP.

13460 if SEARCH_STATUS = FAILED then

13470 print " "; NAME$ ( TARGET_INDE X) ; " is not related to "; &

& NAME$ (S0URCE_INDEX)

13480 else

13490 ! success - parse path to find and display RELATIONSHIP

13500 call RES0LVE_PATH_T0_ENGLISH

13510 call C0MPUTE_C0MM0N_GENES (S0URCE_INDEX, TARGET_INDEX, & & IDENTIFIER$, NEIGHB0R_C0UNT, NEIGHBOR_INDEX, NEIGHB0R_EDGE , & & DESCENDANT IDENTIFIER$, DESCENDANT_GENES)

13520 end if

13530 exit sub

13540 ! 13550 ! end of main line of execution of FIND_RELATIONSHIP

13560 !
Page 42

13570 sub PROCESS_ADJACENT_NODE (BASE_NODE, NEXT_NODE, NEXT_BASE_EDGE

)

13580 ! NEXT_NODE is adjacent to last-REACHED node (= BASE_NODE)

.

13590 ! if NEXT_NODE already REACHED, do nothing.

13600 ! If previously seen, check whether path thru BASE_NODE is

13610 ! shorter than current path to NEXT_N0DE, and if so re-link

13620 ! next to base.

13630 ! If not previously seen, link next to base node.

13640 ! 13650 if NEXT_BASE_EDGE = SPOUSE then

13660 let WEIGHT_THIS_EDGE =1.8

13670 else

13680 let WEIGHT_THIS_EDGE =1.0

13690 end if

13700 ! 13710 if REACHED_STATUS (NEXT_N0DE) <> REACHED then

13720 let DISTANCE_THRU_BASE_NODE &

& = WEIGHT_THIS_EDGE + DISTANCE_FR0M_S0URCE (BASE_NODE)

13740 if REACHED_STATUS (NEXTJNODE) = N0T_SEEN then

13750 let REACHED_STATUS (NEXT_N0DE) = NEARBY

13760 let LAST_NEARBY_INDEX = LAST_NEARBY_INDEX + 1 13770 let NEARBYJJODE (LAST_NEARBY_INDEX) = NEXT_N0DE

13780 ! link next to base by re-setting its predecessor index to

13790 ! point to base, note type of edge, and re-set distance

13800 ! as it is through base node.

13810 let DISTANCE_FR0M_S0URCE (NEXTJJODE) = DISTANCE_THRU_BASE_NODE

13820 let PATH_PREDECESSOR OJEXT_N0DE) = BASE_N0DE

13830 let EDGE_T0_PREDECESS0R (NEXT_N0DE) = NEXT_BASE_EDGE

13840 else ! REACHED_STATUS = NEARBY

13850 if DISTANCE_THRU_BASE_NODE < DISTANCE_FROM_SOURCE (NEXT_N0DE ) then

13860 ! link next to base by re-setting its predecessor index to

13870 ! point to base, note type of edge, and re-set distance

13880 ! as it is through base node.

13890 let DISTANCE_FR0M_S0URCE (NEXT_N0DE) = DISTANCE_THRU_BASE_NODE

13900 let PATH_PREDECESSOR (NEXT_N0DE) = BASE_N0DE

13910 let EDGE_T0_PREDECESS0R (NEXT_N0DE ) = NEXT_BASE_EDGE

13920 end if

13930 end if

13940 end if

13950 end sub

13960 !
Page 43

13970

13980

13990

14000

14010

14020

14030

14040

14050

14060

14070

14080

14090

14100

14110

14120

14130

14140

14150

14160

14170

14180

14190

14200

14210

14220

14230

14240

14250

14260

14270

14280

14290

14300

14310

14320

14330

sub RES0LVE_PATH_T0_ENGLISH

RESOLVE_PATH_TO_ENGLISH condenses the shortest path to a series of RELATIONSHIPS for which there are English

descriptions

Key persons are the ones in the RELATIONSHIP path which remain

after the path is condensed.

print " Shortest path between identified persons:

" let THIS_N0DE = TARGET_INDEX

! print path and initialize KEY_PERSON array from path elements,

! as shortest path is traversed,

let KEY_INDEX = 1 do until THIS_NODE = SOURCE_INDEX

let PERSON_INDEX (KEY_INDEX) = THIS_NODE

let PROXIMITY (KEY_INDEX) = FULL

let RELATION_TO_NEXT (KEY_INDEX) = EDGE_TO_PREDECESSOR (THIS_NODE)

print " "; NAME$ (THIS_NODE); tab (23); "is "; if EDGE_TO_PREDECESSOR (THIS_NODE) = SPOUSE then

let GENERATION_GAP (KEY_INDEX) = 0

print "spouse of"

else

let GENERATION_GAP (KEY_INDEX) = 1 if EDGE_TO_PREDECESSOR (THIS NODE) = PARENT then

print "parent of"

else ! edge is child-type

print "child of"

end if

end if

let KEY_INDEX = KEY_INDEX + 1 let THIS NODE = PATH PREDECESSOR (THIS NODE)

loop

print

let PERSON INDEX

NAME$ (THIS_NODE) _ (KEY_INDEX)

let RELATION_TO_NEXT (KEY_INDEX) _

let RELATION_TO_NEXT (KEY_INDEX + 1) = NULL_RELATION

I

= THIS_NODE

= NULL RELATION
Page 44

14340 ! Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations

14350 ! to SIBLING relations.

14360 let KEY_INDEX = 1 14370 do until RELATI0N_T0_NEXT (KEYJENDEX) = NULL_RELATI0N

14380 if RELATI0N_T0_NEXT (KEY_INDEX) = CHILD then

14390 let LATER_KEY_RELATION = RELATI0N_T0_NEXT (KEY_INDEX + 1)

14400 if LATER_KEY_RELATION = PARENT then

14410 ! found either full or half SIBLINGS

14420 let GENERATION_GAP (KEY_INDEX) = 0

14430 let' RELATI0N_T0_NEXT (KEY_INDEX) = SIBLING

14440 let PROXIMITY (KEY_INDEX) = & & SIBLING_PROXIMITY (PERSONJENDEX (KEY_INDEX) , &

& PERS0N_INDEX (KEY_INDEX +2))

14450 call CONDENSE_KEY_PERSONS (KEY_INDEX, 1)

14460 else

14470 if LATER_KEY_RELATION = SPOUSE and &

& RELATI0N_T0_NEXT (KEY_INDEX + 2) = PARENT then

14480 ! found step-siblings

14490 let GENERATION_GAP (KEY_INDEX) = 0

14500 let RELATI0N_T0_NEXT (KEY_INDEX) = SIBLING

14510 let PROXIMITY (KEY_INDEX) = STEP

14520 call C0NDENSE_KEY_PERS0NS (KEY_INDEX, 2)

14530 end if

14540 end if

14550 end if

14560 let KEY_INDEX = KEY_INDEX + 1 14570 loop

14580 ! 14590 ! Resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to

14600 ! direct descendant or ancestor relations.

14610 let KEY_INDEX = 1 14620 do until RELATI0N_T0_NEXT (KEY_INDEX) = NULL_RELATI0N

14630 if RELATI0N_T0_NEXT (KEY_INDEX) = CHILD or &

& RELATI0N_T0_NEXT (KEY_INDEX) = PARENT then

14640 let LATER_KEY_INDEX = KEY_INDEX + 1 14650 do while RELATION_TO_NEXT (LATER_KEY_INDEX) &

& = RELATION_TO_NEXT (KEY_INDEX)

14660 let LATER_KEY_INDEX = LATER_KEY_INDEX + 1 14670 loop

14680 let GENERATI0N_C0UNT = LATER_KEY_INDEX - KEY_INDEX

14690 if GENERATI0N_C0UNT > 1 then ! compress generations

14700 let GENERATION_GAP (KEY_INDEX) = GENERATI0N_C0UNT

14710 call C0NDENSE_KEY_PERS0NS (KEY_INDEX, GENERATI0N_C0UNT - 14720 end if

14730 end if

14740 let KEY INDEX = KEY INDEX + 1 14750 loop

14760 !
Page 45

14770 ! Resolve CHILD-SIBLING-PARENT to COUSIN,

14780 ! CHILD-SIBLING to NEPHEW,

14790 ! SIBLING-PARENT to UNCLE.

14800 let KEY_INDEX = 1 14810 do until RELATION_TO_NEXT (KEY_INDEX) = NULL_RELATION

14820 let LATER_KEY_RELATION = RELATI0N_T0_NEXT (KEY_INDEX + 1)

14830 if RELATI0N_T0_NEXr (KEY_INDEX) = CHILD &

& and LATER_KEY_RELATION = SIBLING then

14840 ! found COUSIN or NEPHEW

14850 if RELATION_TO_NEXr (KEY_INDEX + 2) = PARENT then

14860 ! found cousin

14870 let GAPl = GENERATION_GAP (KEY_INDEX)

14880 let GAP2 = GENERATION_GAP (KEY_INDEX + 2)

14890 let C0USIN_RANK (KEY_INDEX) = min (GAPl, GAP2

)

14900 let GENERATIONJSAP (KEY_INDEX) = abs (GAPl - GAP2)

14910 let PROXIMITY (KEY_INDEX) = PROXIMITY (KEY_INDEX + 1)

14920 let RELATI0Njr0_NEXT (KEY_INDEX) = COUSIN

14930 call C0NDENSE_KEY_PERS0NS (KEY_INDEX, 2)

14940 else ! found NEPHEW

14950 let PROXIMITY (KEY_INDEX) = PROXIMITY (KEY_INDEX + 1)

14960 let RELATI0N_T0_NEXT (KEY_INDEX) = NEPHEW

14970 call C0NDENSE_KEY_PERS0NS (KEY_INDEX, 1)

14980 end if

14990 else

15000 if RELATI0N_T0_NEXT (KEY_INDEX) = SIBLING &

& and LATER_KEY_RELATION = PARENT then

15010 ! found UNCLE

15020 let GENERATIONJSAP (KEY_INDEX) = &

& GENERATION_GAP (KEY_INDEX + 1)

15030 let RELATION_TO_NEXT (KEY_INDEX) = UNCLE

15040 call CONDENSE_KEY_PERSONS (KEY_INDEX, 1)

15050 end if

15060 end if

15070 let KEY_INDEX = KEY_INDEX + 1 15080 loop

15090 !
Page 46

15100 ! Loop below will pick out valid adjacent strings of elements

15110 ! to be printed. KEY_INDEX points to first element,

15120 ! LATER_KEY_INDEX to last element, and PRIMARY_INDEX to the

15130 ! element which determines the primary English word to be used.

15140 ! Associativity of adjacent elements in condensed table

15150 ! is based on English usage.

15160 print " Condensed path:"

15170 let KEY_INDEX = 1 15180 do until RELATION_TO_NEXT (KEY_INDEX) = NULLJRELATION

15190 let KEY_RELATI0N = RELATION_TO_NEXT (KEY_INDEX)

15200 let LATER_KEY_INDEX, PRIMARY_INDEX = KEY_INDEX

15210 if RELATION_TO_NEXT (KEY_INDEX + 1) <> NULL_RELATI0N then

15220 ! seek multi-element combination

15230 let ANOTHER_ELEMENT_POSSIBLE = TRUE

15240 if KEY_RELATI0N = SPOUSE then

15250 let LATER_KEY__INDEX = LATER_KEY_INDEX + 1 15260 let PRIMARY_INDEX = LATER_KEY_INDEX

15270 if RELATI0N_T0_NEXT (LATER_KEY_INDEX) = SIBLING or &

& RELATI0N_T0_NEXT (LATER_KEY__INDEX) = COUSIN then

15280 ! nothing can follow spouse-sibling or spouse-cousin

15290 let ANOTHER_ELEMENT_POSSIBLE = FALSE

15300 end if

15310 end if

15320 ! PRIMARY_INDEX is now correctly set. Next if-statement

15330 ! determines if a following SPOUSE relation should be

15340 ! appended to this combination or left for the next

15350 ! combination.

15360 if RELATI0N_T0_NEXT (PRIMARY_INDEX + 1) = SPOUSE and &

& ANOTHER_ELEMENT_POSSIBLE = TRUE then

15370 ! Only a SPOUSE can follow a Primary

15380 ! check primary preceding and following SPOUSE.

15390 let PRIMARY_RELATION = RELATION_TO_NEXT (PRIMARY_INDEX)

15400 let NEXT_PRIMARY_RELATION = RELATION_TO_NEXT (PRIMARY_INDEX +

15410 if (NEXT_PRIMARY_RELATION = NEPHEW or &

& NEXT_PRIMARY_RELATION = COUSIN or &

& NEXr_PRIMARY_RELATION = NULL_RELATI0N) &

& or (PRIMARY_RELATION = NEPHEW) &

& or ( (PRIMARY_RELATION = SIBLING or &

& PRIMARY_RELATION = PARENT) &

& and NEXT_PRIMARY_RELATION <> UNCLE ) then

15420 ! append following SPOUSE with this combination

15430 let LATER_KEY_INDEX = LATER_KEY_INDEX + 1 15440 end if

15450 end if

15460 end if ! multi-element combination

15470 call DISPLAY_RELATION (KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX)

15480 let KEY_INDEX = LATER_KEY_INDEX + 1 15490 loop

15500 ! 15510 print " "; NAME$ (PERS0N_INDEX (KEY_INDEX))

15520 end sub

15530 ! end of RESOLVE_PATH_TO_ENGLISH

15540 !
Page

15550 function SIBLING_PROXIMITY (INDEXl, INDEX2)

15560 ! Determines whether two PERSONS are full siblings, i.e.,

15570 ! have the same two parents

.

15580 if RELATIVE_IDENTIFIER$ (INDEXl, FATHER_IDENT) <> NULL_IDENT$ and

& RELATIVE_IDENTIFIER$ (INDEXl, M0THER_IDENT) <> NULL_IDENT$ and

& RELATIVE_IDENT1FIER$ (INDEXl, FATHER_IDENT ) =

& RELATIVE_IDENTIFIER$ (INDEX2, FATHER_IDENT) and

& RELATIVE_IDENTIFIER$ (INDEXl, M0THER_IDENT) =

& RELATIVE_IDENTIFIER$ (INDEX2, M0THER_IDENT

)

15590 let SIBLINGJPROXIMITY = FULL

15600 else

15610 let SIBLING_PROXIMITY = HALF

15620 end if

15630 end function ! SIBLING_PROXIMITY

15640 ! 15650 sub C0NDENSE_KEY_PERS0NS (AT_INDEX, GAP_SIZE)

15660 ! C0NDENSE_KEY_PERS0NS condenses superfluous entries from the

15670 ! key person array entries, starting at AT INDEX

15680 let RECEIVE_INDEX = AT_INDEX

15690 do

15700 let RECEIVE_INDEX = RECEIVE_INDEX + 1 15710 let SEND_INDEX = RECEIVE_INDEX + GAP_SIZE

15720 let RELATI0N_T0_NEXT (RECEIVE_INDEX) = RELATI0N_T0_NEXT (SEND

15730 let PERS0N_INDEX (RECEIVE_INDEX) = PERS0N_INDEX (SEND~

15740 let GENERATION_GAP (RECEIVE_INDEX) = GENERATION_GAP (SEND'

15750 let PROXIMITY (RECEIVE_INDEX) = PROXIMITY (SEND^

15760 let C0USIN_RANK (RECEIVE_INDEX) = C0USIN_RANK (SEND_

15770 loop until RELATION_TO_NEXT (SEND_INDEX) = NULL_RELATI0N

15780 end sub

15790 ! 15800 sub DISPLAY_RELATION (FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX)

15810 ! DISPLAYJRELATION takes 1, 2, or 3 adjacent elements in the

15820 ! condensed table and generates the English description of

15830 ! the relation between the first and last + 1 elements.

15840 ! 15850 let FIRST_RELATION = RELATI0N_T0_NEXT (FIRST_INDEX)

15860 let LAST_RELATI0N = RELATI0N_T0_NEXT (LAST_INDEX)

15870 let PRIMARY_RELATION = RELATION_TO_NEXT (PRIMARY_INDEX)

15880 ! 15890 ! set THIS_PROXIMITY

15900 if (PRIMARY_RELATION = PARENT and FIRST_RELATION = SPOUSE) or

& (PRIMARY_RELATION = CHILD and LAST_RELATION = SPOUSE) then

15910 let THIS_PROXIMITY = STEP

15920 else

15930 if PRIMARY_RELATION = SIBLING or & & PRIMARY_RELATION = UNCLE or &

& PRIMARY_RELATION = NEPHEW or &

& PRIMARY_RELATION = COUSIN then

15940 let THIS_PROXIMITY = PROXIMITY (PRIMARY_INDEX)

15950 else

15960 let THIS_PROXIMITY = FULL

15970 end if

15980 end if

15990 !

&

&

&&&

ther

INDEX)

INDEX)

INDEX)

INDEX)

INDEX)
Page 48

16000

16010

&

&

&

&16020

16030

16040

16050

16060

16070

16080

&

&

&

&16090

16100

16110

&&

&

&

16120

16130

16140

16150

16160

16170

16180

16190

16200

16210

16220

16230

16240

16250

16260

16270

16280

&

&

&16290

16300

16310

16320

16330

16340

16350

16360

16370

! set THIS_GENERATION_GAP

if PRIMARY_RELATION = PARENT or PRIMARY_RELATION = CHILD or PRIMARY_RELATION = UNCLE or PRIMARY_RELATION = NEPHEW or PRIMARY RELATION = COUSIN then

let THIS_GENERATION_GAP = GENERATION_GAP (PRIMARY_INDEX)

else

let THIS_GENERATION_GAP = 0

end if

I

! set INLAW

if (FIRST_RELATION = SPOUSE) and &

(PRIMARY_RELATION = SIBLING or & PRIMARY_RELATION = CHILD or &

PRIMARY_RELATION = NEPHEW or &

PRIMARY_RELATION = COUSIN) then

let INLAW = TRUE

else

if (LAST_RELATI0N = SPOUSE) and &

(PRIMARY_RELATION = SIBLING or &

PRIMARY_RELATION = PARENT or &

PRIMARY_RELATION = UNCLE or &

PRIMARY_RELATION = COUSIN) then

let INLAW = TRUE

else

let INLAW = FALSE

end if

end if

j

! set THIS_COUSIN_RANK

if PRIMARY_RELATION = COUSIN then

let THIS_COUSIN_RANK = C0USIN_RANK (PRIMARY_INDEX)

else

let THIS_COUSIN_RANK = 0

end if

!

! parameters are set - now generate display.

print NAME$ (PERSON INDEX (FIRST INDEX)); tab(23); "is

PRIMARY_RELATION = PARENT or &

PRIMARY_RELATION = CHILD or &

PRIMARY_RELATION = UNCLE or &

PRIMARY_RELATION = NEPHEW then

! print generation-qualifier

if THIS_GENERATION_GAP >= 3 then

print "great";

if THIS_GENERATION_GAP > 3 then

print "*"; str$ (THIS_GENERATION_GAP - 2);

end if

print "-";

end if

if THIS GENERATION GAP >= 2 then print "grand-";
Page 49

16380

16390

16400

16410

16420

16430

16440

16450

16460

16470

16480

16490

16500

16510

16520

16530

if THIS PROXIMITY

end if

elseif PRIMARY RELATION = COUSIN and THIS COUSIN RANK > 1 then

print str$ (THIS COUSIN RANK);

end select

print "step-";

select case mod (THIS_C0USIN RANK, 10)

case 3

print "rd " case else

print "th "

case 2 print "nd "

case 1 print "st "

STEP then

16540 elseif THIS_PROXIMITY = HALF then

16550 print "half-";

16560 end if

16570 ! 16580 let THIS GENDER$ = GENDER$ (PERSON INDEX (FIRST INDEX))

16590 select case PRIMARY RELATION

16600 case 1 ! PARENT

16610 if THIS GENDER$ = MALE$ then print "father"

;

else print "mother"

;

16620 case 2 ! CHILD

16630 if THIS GENDER$ = MALE$ then print "son"

;

else print "daughter"

;

16640 case 3 ! SPOUSE

16650 if THIS GENDER$ = MALE$ then print "husband"

;

else print "wife"

;

16660 case 4 ! SIBLING

16670 if THIS GENDER$ = MALE$ then print "brother"

;

else print "sister"

;

16680 case 5 ! UNCLE

16690 if THIS GENDER$ = MALE$ then print "uncle"

;

else print "aunt"

;

16700 case 6 ! NEPHEW

16710 if THIS GENDER$ = MALE$ then print "nephew"

;

else print "niece"

;

16720 case 7 ! COUSIN

16730 print "cousin";

16740 case else

16750 print "null";

16760 end select

16770 ! 16780 if INLAW = TRUE then print "-in-law";

16790 ! 16800 if PRIMARY_RELATION = COUSIN and THIS_GENERATION_GAP > 0 then

16810 if THIS_GENERATION_GAP > 1 then

16820 print THIS_GENERATION_GAP; "times removed";

16830 else

16840 print " once removed";

16850 end if

16860 end if

16870 ! 16880 print " of"

16890 ! 16900 end sub ! end of internal sub DISPLAY_RELATION

16910 end sub ! end of external sub FIND_RELATIONSHIP

16920 !
Page 50

16930 ! —— program-unit number 3 —

16940 ! 16950 external sub COMPUTE_COMMON_GENES (INDEXl, INDEX2, IDENTIFIER$ (), &

& NEIGHB0R_C0UNT (), NEIGHBOR_INDEX (,), NEIGHB0R_EDGE (,), &

& DESCENDANT_IDENTIFIER$ (), DESCENDANT_GENES ())

16960 ! 16970 ! C0MPUTE_C0MM0N_GENES assumes that each ancestor contributes

16980 ! half of the genetic material to a person. It finds common

16990 ! ancestors between two persons and computes the expected

17000 ! value of the PROPORTION of common material.

17010 ! 17020 declare sub ZER0_PR0P0RTI0N, MARK_PR0P0RTI0N, CHECK_C0MM0N_PR0P0RTI0N

17030 ! 17035 option base 1 17040 ! 17045 data 1, 2, 3, 4, 5, 6, 7, 8

17050 read PARENT, CHILD, SPOUSE, SIBLING, UNCLE, NEPHEW

17055 read COUSIN, NULL_RELATION

17057 ! 17060 ! Begin main line of execution of COMPUTE_COMMON_GENES

17065 ! 17070 ! First zero out all ancestors to allow adding. This is necessary

17075 ! because there might be two paths to an ancestor.

17080 call ZEROJPROPORTION (INDEXl, 0)

17090 ! now mark with shared PROPORTION

17100 call MARK_PROPORTION (IDENTIFIER$ (INDEXl), 1.0, INDEXl, 0)

17110 let COMMON_PROPORTION =0.0

17120 call CHECK_C0MM0N_PR0P0RTI0N (C0MM0N_PR0PORTION, & & IDENTIFIER$ (INDEXl), 1.0, 0.0, INDEX2, 0)

17130 print using " Proportion of common genetic material = #.#####^ ": &

& C0MM0N_PR0P0RTI0N

17140 ! 17150 ! End main line of execution of C0MPUTE_C0MM0N_GENES

17160 ! 17170 sub ZER0_PR0P0RTI0N (ZER0_INDEX, THIS_NEIGHB0R)

17180 ! ZER0_PR0PORTION recursively seeks out all ancestors and

17190 ! zeros them out

17200 let DESCENDANT_GENES (ZER0_INDEX) =0.0

17210 for THIS_NEIGHBOR = 1 to NEIGHBOR_COUNT (ZERO_INDEX)

17220 if NEIGHBOR_EDGE (ZERO_INDEX, THIS_NEIGHBOR) = PARENT then

17230 call ZER0_PR0PORTION &

& (NEIGHBOR_INDEX (ZERO_INDEX, THIS_NEIGHBOR) , 0)

17240 end if

17250 next THIS_NEIGHBOR

17260 end sub ! ZERO_PROPORTION

17270 !
Page 51

17280 sub MARK_PROPORTION (MARKER$, PROPORTION, MARKED_INDEX, THIS_NEIGHBOR

)

17290 ! MARK_PROPORTION recursively seeks out all ancestors and

17300 ! marks them with the sender's PROPORTION of shared

17310 ! genetic material. This PROPORTION is diluted by one-half

17320 ! for each generation

17330 let DESCENDANT_IDENTIFIER$ (MARKED_INDEX) = MARKER$

17340 let DESCENDANT_GENES (MARKED_INDEX) = &

& DESCENDANT_GENES (MARKED_INDEX) + PROPORTION

17350 for THIS_NEIGHBOR = 1 to NEIGHBORjCOUNT (MARKED_INDEX)

17360 if NEIGHBOR_EDGE (MARKED_INDEX, THIS_NEIGHBOR) = PARENT then

17370 call MARK_PRO PORTION (MARKER$, PROPORTION / 2.0, & & NEIGHBOR_INDEX (MARKED_INDEX, THIS_NEIGHBOR) , 0)

17380 end if

17390 next THIS_NEIGHBOR

17400 end sub ! MARK_PROPORTION

17410 ! 17420 sub CHECK_COMMON_PROPORTION (COMMON_PROPORTION, MATCH_IDENTIFIER$, & & PROPORTION, ALREADYjCOUNTED, CHECK_INDEX, THIS_NEIGHBOR)

17430 ! CHECK_COMMON_PROPORTION searches all the ancestors of

17440 ! CHECK_INDEX to see if any have been marked, and if so 17450 ! adds the appropriate amount to COMMON_PROPORTION

17460 if DESCENDANT_IDENTIFIER$ (CHECK_INDEX) = MATCH_IDENTIFIER$ then

17470 ! Increment COMMON_PROPORTION by the contribution of

17480 ! this common ancestor, but discount for the contribution

17490 ! of less remote ancestors already counted

17500 let THISjCONTRIBUTION = DESCENDANT_GENES (CHECK_INDEX) * PROPORTION

17510 let COMMON_PROPORTION = COMMON_PROPORTION & & + THISJCONTRIBUTION - ALREADY_COUNTED

17520 else

17530 let THIS_CONTRIBUTION =0.0

17540 end if

17550 for THIS_NEIGHBOR = 1 to NEIGHBORJCOUNT (CHECK_INDEX)

17560 if NEIGHBOR_EDGE (CHECK_INDEX, THIS_NEIGHBOR) = PARENT then

17570 call CHECK_COMMON_PROPORTION (COMMON_PROPORTION , &

& MATCH_IDENTIFIER$, PROPORTION / 2.0, &

& THISJCONTRIBUTION / 4.0, &

& NEIGHBOR_INDEX (CHECK_INDEX, THIS_NEIGHBOR) , 0)

17610 end if

17620 next THIS_NEIGHBOR

17630 ! 17640 end sub ! end of internal sub CHECKjCOMMON_PROPORTION

17650 end sub ! end of external sub COMPUTE COMMON GENES
Page 52

4.0 C

The identifiers NULL and FILE are capitalized, even though they are supplied by

the standard run-time library, because identifiers in C are case-sensitive,

e.g., "null" is not equivalent to "NULL".

/* Bring in standard routines for run-time support */

//include <stdio.h>

/* Global types and objects */

typedef short int BOOLEAN;

//define TRUE 1 //define FALSE 0

//define EQUALS 0

//define NULL_ID "000"

//define NULLjCHR '\0'

//define MAX_PERS 300

//define NAME_LEN 20

/* every PERSON has a unique 3-digit IDENT */

//define ID_LEN 3

//define BUF_LEN 60

/* Use "+ 1" when treating type as variable-length - extra character

used to hold NULL_CHR termination character. */

typedef char NAMEJT'^P [NAME_LEN + 1];

typedef char BUF_TYPE [BUF_LEN + 1];

typedef char MSG_TYPE [40 +1];

typedef char ID_TYPE [ID_LEN +1];

typedef int INDXJTYP, COUNTER;

/* each person's record in the file identifies at most threothers directly related: father, mother, and spouse */

typedef short int GIVEN_ID;

//define FATHR_ID 0

//define MOTHR_ID 1 //define SPOUS_ID 2

//define MAX_GVEN 3

typedef IDJTYPE REL_ARRY [MAX_GVEN];

//define REQjDK "Request OK"

//define REQ_STOP "stop"

typedef char GNDR_TYP;

//define MALE 'M'

//define FEMALE 'F'
Page 53

typedef unsigned int REL_TYPE

/* Values defined as octal powers of two to facilitate comparisons

of one relation with several possibilities. */

//define PARENT 0001

#define CHILD 0002

#define SPOUSE 0004

#define SIBLING 0010

#define UNCLE 0020

//define NEPHEW 0040

//def ine COUSIN 0100

//define NULL REL 0200

/* directed edges in the graph are of a given type */

typedef RELJTYPE EDG_TYPE;

/* A node in the graph (= PERSON) has either already been reached,

is immediately adjacent to those reached, or farther away. */

typedef short int REACHJTY;

//define REACHED 1 //define NEARBY 2

//define NOT SEEN 3

/* each PERSON has a linked list of adjacent nodes, called neighbors */

typedef struct NBR_N0DE

{ INDXJTYP NBR_DEX;

EDGJTYPE NBR_EDGE

struct NBR_N0DE *NEXT_NBR;

}

NBR_REC, *NBR_PTR;

/* All relationships are captured in the directed graph of which

each record is a node . */

typedef struct

{

/* static information - filled from PEOPLE file: */

NAMEJIYP NAME

ID_TYPE IDE NT;

GNDRJTYP GENDER

/* IDENTs of immediate relatives - father, mother, spouse */

REL_ARRY REL_ID;

/* head of linked list of adjacent nodes */

NBR_PTR NBR_HDR;

/* data used when traversing graph to resolve user request: */

float DIST_SRC

INDXJTYP PATHPRED;

EDGJTYPE EDG_PRED;

REACHJTY REACH_3T;

/* data used to compute common genetic material */

IDJTYPE DSC_ID;

float DSC_GENE

}

PERS REC;
Page 54

/« the PERSON array Is the central repository of Information

about inter-relatlonshlps . */

PERS_REC PERSON [MAX_PERS];

INDX_TYP NUM_PERS;

/* Key persons are the ones In the RELJSHIP path which remain

after the path is condensed. •/

typedef short int SIB_TYPE;

//define STEP 1 #define HALF 2

^define FULL 3

typedef struct

{ REL_TYPE

INDXJTYP

COUNTER

SIB_TYPE

COUNTER

}

KEY REC;

RELJIEXT;

PERS_DEX;

GEN_GAP;

PROXIMTY;

CUZ RANK;

/»»»»»*»»*» Main line of execution RELATE »«*»»»»»»»/

main (

)

{ /* These variables are used when establishing the PERSON array

from the PEOPLE file. »/

FILE

register INDXJTYP

IDJTYPE

GIVEN_ID

char

»fopen(), "PEOPLE;

CURRENT, PREVIOUS;

PREV_ID, CUR_ID;

RELJSHIP;

INP BUF [100];

/* These variables are used to accept and resolve requests for

RELJSHIP information. »/

COUNTER SEMI_LOC

;

BUFJTYPE REQ_BUF;

BUFJTYPE P1_IdENT, P2_IDENT;

COUNTER P1_F0UND, P2_F0UND;

MSGJTYPE ERR MSG;

INDXJTYP PI TNDEX, P2 INDEX;
Page 55

/* *** execution of main sequence begins here *** */

PEOPLE = fopen("PEOPLE. DAT", "r");

/* This loop reads in the PEOPLE file and constructs the PERSON

array from it (one PERSON == one record == one array entry).

As records are read in, links are constructed to represent the

PARENT-CHILD or SPOUSE REL_SHIP. The array then Implements

a directed graph which is used to satisfy subsequent user requests. The file is assumed to be correct - no validation

is performed on it . */

READ_PEO:

for (CURRENT =0; ; CURRENT-H-)

{

/* copy direct information from file to array */

if (PXD_GETC (PERSON [CURRENT] . NAME, PEOPLE, NAME_LEN) == EOF)

break;

FXD_GETC (PERSON [CURRENT] . IDENT, PEOPLE, ID_LEN);

FXD_GETC (&(PERSON [CURRENT] . GENDER), PEOPLE, 1);

for (REL_SHIP = FATHR_ID; REL_SHIP < MAX_GVEN; REL_SHIP-H-)

FXD_GETC (PERSON [CURRENT] . REL_ID [REL_SHIP] , PEOPLE, ID_LEN);

/* flush remainder of record */

fgets (1NP_BUF, 100, PEOPLE);

/* Location of adjacent persons as yet undetermined */

PERSON [CURRENT] . NBR_HDR = NULL;

/* Descendants as yet undetermined */

St ropy (PERSON [CURRENT] . DSC_ID, NULL_ID);

/* Compare this PERSON against all previously entered PERSONS

to search for REL_SHIPs . */

strcpy (CUR_ID, PERSON [CURRENT] . IDENT);

CMP_PREV:

for (PREVIOUS = 0; PREVIOUS < CURRENT; PREVIOUS-H-)

{strcpy (PREV_ID, PERSON [PREVIOUS] . IDENT);

/* Search for father, mother, or spouse relationship in

either direction between this and PREVIOUS PERSON.

Assume at most one REL_SHIP exists. */

TRY_RELS

:

for (REL_SHIP = FATHR_ID; REL_SHIP < MAX_GVEN; REL_SHIP++)

{

if (STREQ (PRE V_ID, PERSON [CURRENT] . REL_ID [REL_SHIP]))

{ LINK_REL (CURRENT, REL_SHIP, PREVIOUS);

break;

}

else

if (STREQ (CUR_ID, PERSON [PREVIOUS] . REL_ID [REL_SHIP]))

{

LINK_REL (PREVIOUS, REL_SHIP, CURRENT);

break;

}

} /* end TRY_RELS */

} /* end CMP_PREV */

} /* end READJPEO */

NUM_PERS = CURRENT;

f close (PEOPLE);
Page 56

/* PERSON array is now loaded and edges between immediate relatives

(PARENT -CHILD or SPOUSE -SPOUSE) are established.

While-loop accepts requests and finds REL_SHIP (if any)

between pairs of PERSONS. */

PROC_REQ:

while (TRUE)

{

PROMPT (REQ_BUF);

if (STREQ (REQ_BUF, REQ_STOP))

break;

SEMI_LOC = CHK_RQST (REQ_BUF, ERR_MSG);

/* Syntax check of request completed. Now either display error

* message or search for the two PERSONS. */

if (STREQ (ERR_MSG, REQ_OK))

{ /* Request syntactically correct - search for requested PERSONS. */

REQ_BUF [SEMI_LOC] = NULL_CHR;

BUF_PERS (REQ_BUF, 0, P1_IDENT);

BUF_PERS (REQJBUF, SEMI_LOC + 1, P2_IDENT);

SEEK_PER (P1_IDENT, P2_IDENT, & P1_INDEX, & P2_INDEX,

& P1_F0UND, & P2_F0UND);

if (P1_F0UND == 1 && P2_F0UND == 1)

/* Exactly one match for each PERSON - proceed to

determine REL_SHIP, if any. */

if (P1_INDEX == P2_INDEX)

printf (" %ls is identical to %8s \n"

,

PERSON [P1_INDEX] . NAME,

(PERSON [P1_INDEX] . GENDER == MALE) ? "himself." : "herself.");

else

FIND_REL (P1_INDEX, P2_INDEX);

else /* either not found or more than one found */

if (P1_F0UND == 0)

printf (" First person not found. \n");

else if (P1_F0UND > 1)

{ printf (" Duplicate names for first person -");

printf (" use numeric identif ier .\n" )

;

}

if (P2_F0UND == 0)

printf (" Second person not found.\n");

else if (P2_F0UND > 1)

{

printf (" Duplicate names for second person -");

printf (" use numeric identif ier .\n")

;

}

} /* end processing of syntactically legal request */

else

printf (" Incorrect request format: %ls \n" , ERR_MSG);

} /* end PROC_REQ loop */ ~

printf (" End of relation-finder. \n");

}

/* End of main line of RELATE */
Page 57

/* procedures under RELATE »/

FXD GETC (RECEIVER, SENDING, GET LEN)

char

FILE

int

•RECEIVER;

•SENDING;

GET LEN;

{ register int CHAR_CNT;

for (CHAR_CNT = 0;

CHAR_CNT++ < GET_LEN && (»RECEIVER++ = getc (SENDING)) ! = EOF ; ) ; if (CHAR_CNT >= GET_LEN)

{

•RECEIVER = NULL_CHR;

return !EOF;

}

else

return EOF;

STREQ (STRING1, STRING2)

/• compare for equality, ignore trailing spaces •/

register char •STRING 1 , •STRING2;

{ register char •LONGER;

for ( ; •STRING 1 == •STRING2; STRING STRING2++)

if ( •STRING 1 == NULL_CHR)

return TRUE;

if ( •STRING 1 == NULL_CHR)

LONGER = STRING2;

else

if (•STRING2 == NULL_CHR)

LONGER = STRING 1; else

return FALSE;

for ( ; •LONGER++ =='';);

return (•—LONGER == NULL_CHR);

}
Page 58

LINK_REL (FROM_DEX, REL_SHIP, TO_INDEX)

/* establishes cross- indexing between immediately related PERSONS. */

register INDXJTYP FROM_DEX, TO_INDEX;

register GIVEN_ID REL_SHIP;

{ /* execution of LINK_REL */

if (REL_SHIP == SPOUS_ID)

{ LINK_ONE (FROMJDEX, SPOUSE, TO_INDEX);

LINK_ONE (TO_INDEX, SPOUSE, FROM_DEX);

}

else /* REL_SHIP is father or mother */

{

LINK_ONE (FROMJDEX, PARENT, TO_INDEX);

LIN-K_ONE (TO_INDEX, CHILD, FROM_DEX);

}

LINK_ONE (FROM_DEX, THIS_EDG, TO_INDEX)

/* Establishes the NBR_REC from one PERSON to another */

INDXJTYP FROMJDEX, TO_INDEX;

EDGJTYPE THIS_EDG;

{ register NBR_PTR NEWJ^BR;

NEW_NBR = (NBR_REC * ) calloc(l, sizeof (NBR_REC ) )

;

NEW_NBR -> NBRJDEX = TO_INDEX;

NEW_NBR -> NBR_EDGE = THIS_EDG;

NEW_NBR -> NEXTJJBR = PERSON [FROM_DEX] . NBRJIDR;

PERSON [FROM_DEX] . NBR_HDR = NEW_NBR;

}

PROMPT (REQ_BUF)

/* Issues prompt for user-request, reads in request,

blank-fills buffer, and skips to next line of input. */

BUFJTYPE REQ_BUF

;

{

print f (" \n");

printf (** \n");

printf (" Enter two person-identifiers (name or number) ,\n");

printf (" separated by semicolon. Enter \"stop\" to stop.\n");

fgets (REQ_BUF, BUFJ.EN, stdin);

for ( ; *REQJBUF-H- != '\n' ; ) ; *~REQ BUF = '\0';

}
CHK_RQST (REQ_BUF, REQ_STAT)

/* Performs syntactic check on request in buffer. */

BUFJTYPE REQ_BUF;

MSGJCYPE REQ_STAT

{ COUNTER SEMI_LOC = 1,

SEMI_CNT = 0;

register COUNTER BUFJDEX;

BOOLEAN P1_EXIST = FALSE,

P2_EXIST = FALSE;

strcpy (REQ_STAT, REQJDK);

for (BUF_DEX = 0; BUF_DEX < BUF_LEN && REQ_BUF [BUF_DEX]; BUF_DEX-H-)

{

if (REQJBUF [BUFJDEX] != ' ')

if (REQ_BUF [BUFJDEX] == ';')

{

SEMI_LOC = BUFJ)EX;

SEMIj:NT = SEMIJCNT + 1;

}

else /* Check for non-blanks before/after semicolon. */

if (SEMIJCNT < 1)

P1_EXIST = TRUE;

else

P2_EXIST = TRUE;

}

/* set REQ_STAT, based on results of scan of REQ_BUF. */

if (SEMIJCNT != 1)

strcpy (REQ_STAT, "must be exactly one semicolon.");

else if ( ! Pl_EXIST)

strcpy (REQ_STAT, "null field preceding semicolon.");

else if ( ! P2_EXIST)

strcpy (REQ_STAT, "null field following semicolon.");

return SEMIj:.OC;

}

ByF_PERS (REQJ5UF, BUFJ)EX, PERS_ID)

/* fills in the PERS_ID from the designated portion

of the REQ_BUF, deleting leading blanks. */

BUFJTYPE REQ_BUF

register COUNTER BUFJDEX;

NAME TYP PERS ID;

for ( ; REQJBUF [BUFJ)EX++]

strcpy (PERS ID, &REQ_BUF [ =='';); —BUF DEX] );
Page 60

SEEK_PER (P1_IDENT, P2_IDENT, P1_INDEX, P2_INDEX,

P1_F0UND, P2_F0UND)

/» SEEK_PER scans through the PERSON array,

looking for the two requested PERSONS. Match may be by NAME

or unique IDENT-number. »/

BUFJTYPE P1_IDENT, P2_IDENT;

INDXJTYP »P1_INDEX, »P2_INDEX;

COUNTER »P1_F0UND, »P2_F0UND;

{ register INDXJTYP CURRENT;

*P1_INDEX =0;

»P2_INDEX = 0;

»P1_F0UND = 0;

»P2_F0UND =0;

SCAN_PER

:

for (CURRENT = 0; CURRENT < NUM PERS; CURRENT++)

{

/• allow identification by name or number. */

if (STREQ (P1_IDENT, PERSON [CURRENT] . IDENT) I I STREQ (P1_IDENT, PERSON [CURRENT] . NAME))

{

(»P1_F0UND)++;

»P1_INDEX = CURRENT;

}

if (STREQ (P2_IDENT, PERSON [CURRENT] . IDENT) I I STREQ (P2_IDENT, PERSON [CURRENT] . NAME))

{ (»P2_F0UND)++;

«P2_INDEX = CURRENT;

}

} /» end SCAN_PER loop »/

} /» end of SEEK PER »/
Page 61

FIND_REL (TARG_DEX, SRCEJDEX)

/* Finds shortest path (if any) between two PERSONS and

determines their REL_SHIP based on immediate relations

traversed in path. PERSON array simulates a directed graph,

and algorithm finds shortest path, based on following

weights: PARENT-CHILD edge - 1.0

SPOUSE-SPOUSE edge = 1.8 */

INDXJTYP

{ register INDXJTYP

INDXJTYP

register NBR_PTR

float

typedef short int

#define SEARCHNG

#define SUCCESS

//define FAILED

SRCHJTYP

/* begin execution of FINDJREL */

/* initialize PERSON-array for processing - mark all nodes as not seen */

for (PERSJ)EX = 0; PERSJDEX < NUM_PERS; PERSJ)EX-H-)

PERSON [PERSJ)EX] . REACH_ST = NOT_SEEN;

THIS_NOD = SRCEJ)EX;

/* mark source node as REACHED */

PERSON [THISJJOD] . REACH_ST = REACHED;

PERSON [THISJJOD] . DIST_SRC = 0.0;

/* no NEARBY nodes exist yet */

LSTJJRBY = -1;

SRCH ST = (THIS NOD = TARGJ)EX) ? SUCCESS : SEARCHNG;

TARGJDEX, SRCEJDEX;

PERSJ)EX;

THISJJOD, BESTJ)EX, LSTJfRBY,

NRBY_ND [MAX_PERS];

THIS_NBR;

MINJ)IST;

SRCHJTYP;

12

3

SRCH ST;
Page 62

/* Loop keeps processing closest-to-source , unREACHED node

until target REACHED, or no more connected nodes. */

SEEKTARG:

while (SRCH_ST == SEARCHNG)

{ /* Process all nodes adjacent to THIS_NOD */

for (THIS_NBR = PERSON [THIS_NOD] . NBR_HDR;

THIS_NBR != NULL;

THIS_NBR = THISJJBR -> NEXT_NBR)

PROC_ADJ (THIS_NOD, THIS_NBR -> NBR_DEX, THIS_NBR -> NBR_EDGE,

NRBY_ND, &LST_NRBY);

/* All nodes adjacent to THIS_NOD are set. Now search for

shortest-distance tinREACHED (but NEARBY) node to process next. */

if (LST_NRBY == -1)

SRCH_ST = FAILED;

else /* determine next node to process */

{

MIN_DIST = l.OE+18;

for (PERS_DEX = 0; PERSJDEX <= LST_NRBY; PERS_DEX-++)

if (PERSON [NRBY ND [PERS DEX]] . DIST SRC < MIN DIST)

{

BEST_DEX = PERS_DEX;

MIN_DIST = PERSON [NRBY_ND [PERS_DEX] ] . DIST SRC;

}

/* establish new THISJJOD */

THIS_NOD = NRBY_ND [BEST_DEX];

/* change THISJJOD from being NEARBY to REACHED */

PERSON [THIS_NOD] . REACH_ST = REACHED;

/* remove THISJJOD from NEARBY list */

NRBY_ND [BEST_DEX] = NRBYJID [LSTJJRBY— ];

if (THISJJOD == TARGJDEX)

SRCH_ST = SUCCESS;

}

} /* end SEEKTARG loop */

/* Shortest path between PERSONS now established. Next task is

to translate path to English description of REL_SHIP. */

if (SRCH_ST == FAILED)

printf (" %ls is not related to %ls\n",

PERSON [TARGJ)EX] . NAME, PERSON [SRCE_DEX] . NAME);

else /* success - parse path to find and display REL_SHIP */

{

RESOLVE (SRCEJ)EX, TARGJ)EX);

CMPT GNS (SRCE DEX, TARG DEX);

}

} /* end FIND REL */
/* procedures under FIND_REL */

PROC_ADJ (BASENODE, NXT_NODE , N_B_EDGE, NRBY_ND, LSTNRBY)

/* NXT_NODE is adjacent to last-REACHED node (== BASENODE).

If NXT_NODE already REACHED, do nothing.

If previously seen, check whether path thru BASENODE is

shorter than current path to NXT_NODE, and if so re-link

next to base

.

If not previously seen, link next to base node. */

register INDXJTYP NXT_NODE;

INDXJTYP BASENODE, NRBY_ND[], *LST_NRBY;

EDGJTYPE N_B_EDGE

;

{ float WGHT_EDG, DIST_BAS;

/* begin execution of PROC_ADJ */

if (PERSON [NXT_NODE] . REACH_ST != REACHED)

{

WGHT_EDG = (N_B_EDGE == SPOUSE) ? 1.8 : 1.0;

DIST_BAS = WGHT_EDG + PERSON [BASENODE] . DIST_SRC;

if (PERSON [NXT_NODE] . REACH_ST == NOT_SEEN)

{ PERSON [NXT_NODE] . REACH_ST = NEARBY;

NRBY_ND [++ *LST_NRBY] = NXT_NODE

;

/* link next to base by re-setting its predecessor index to

point to base, note type of edge, and re-set distance

as it is through base node. */

PERSON [NXT_NODE] . DIST_SRC = DIST_BAS;

PERSON [NXTJJODE] . PATHPRED = BASENODE;

PERSON [NXT_NODE ]

. EDG_PRED = N_B_EDGE

;

}

else /* REACH_ST = NEARBY */

if (DISTJBAS < PERSON [NXTJJODE] . DIST_SRC)

{ /* link next to base by re-setting its predecessor index

point to base, note type of edge, and re-set distance

as it is through base node. */

PERSON [NXT_NODE] . DIST_SRC = DIST_BAS;

PERSON [NXTJJODE] . PATHPRED = BASENODE;

PERSON [NXT_NODE] . EDG_PRED = NJJDGE;

}

}

} /* end PROC ADJ */
Page 64

RESOLVE (SRCE_DEX, TARGJDEX)

/* RESOLVE condenses the shortest path to a series of REL_SHIPs for which there are English

descriptions. */

INDX_TYP SRCE_DEX, TARG_DEX;

{ /* these variables are used to generate KEY_PERSs */

COUNTER GEN_CNT;

/* these variables are used to condense the path */

KEY_REC KEY_PERS [MAX_PERS ]

;

RELJTYPE KEY_REL, LKEY_REL, PRIM_REL, NXT_PRIM;

register INDXJTYP KEY_DEX;

INDXJTYP LKEY_DEX, PRIM_DEX, THIS_NOD;

BOOLEAN SEEKMORE

;

/* begin execution of RESOLVE */

printf (" Shortest path between identified persons: \n");

/* Display path and initialize KEY_PERS array from path element

TRAVERSE:

for (THIS_NOD = TARG_DEX, KEY_DEX = 0; THIS_NOD != SRCEJDEX;

THIS_NOD = PERSON [THIS_NOD] . PATHPRED, KEY_DEX-H-)

{

printf (" %ls is ", PERSON [THIS_NOD] . NAME);

KEY_PERS [KEY_DEX] . PERS_DEX = THIS_NOD;

KEY_PERS [KEY_DEX] . PROXIMTY == FULL;

KEY_PERS [KEY_DEX] . REL_NEXT = PERSON [THIS_NOD] . EDG_PRED

switch (PERSON [THIS_NOD] . EDG_PRED)

{ case PARENT: printf ("parent of\n");

KEY_PERS [KEY_DEX] . GEN_GAP = 1;

break;

case CHILD : printf ("child of\n");

KEY_PERS [KEYJDEX] . GEN_GAP = 1; break; case SPOUSE: printf ("spouse of\n");

KEY_PERS [KEY_DEX] . GEN_GAP = 0;

break;

} /* end switch */

} /* end TRAVERSE loop */

printf (" %ls\n", PERSON [THIS_NOD] . NAME);

KEY_PERS [KEY_DEX] . PERSJDEX = THIS_NOD;

KEY_PERS [KEY_DEX] . REL_NEXT = NULL_REL;

KEY PERS [KEY DEX + 1] . REL NEXT = NULL REL;
Page 65

/* Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations

to SIBLING relations. */

FIND_SIB:

for (KEYJDEX = 0; KEY_PERS [KEY DEX] . REL NEXT != NULL REL; KEY DEX-H-)

{ _ - _ _

if (KEY_PERS [KEY_DEX] . REL NEXT == CHILD)

{

LKEY_REL = KEY_PERS [KEY_DEX + 1] . REL_NEXT;

If (LKEY_REL == PARENT)

{ /* found either full or half SIBLINGS */

BOOLEAN FULL_SIB();

KEY_PERS [KEY_DEX] . PROXIMTY = FULL_SIB (KEY_PERS [KEY_DEX] . PERS_DEX,

KEY_PERS [KEY_DEX + 2] . PERS_DEX)

? FULL : HALF;

KEY_PERS [KEY_DEX] . GEN_GAP = 0;

KEY_PERS [KEY_DEX] . REL_NEXT = SIBLING;

CONDENSE (KEY_DEX, 1, KEY_PERS);

}

else

if (LKEY_REL == SPOUSE

&& KEY_PERS [KEYJDEX + 2] . REL_NEXT == PARENT)

{ /* found step-SIBLINGs */

KEY_PERS [KEY_DEX] . GEN_GAP = 0;

KEY_PERS [KEY_DEX] . PROXIMTY = STEP;

KEY_PERS [KEYJDEX] . REL_NEXT = SIBLING;

CONDENSE (KEY_DEX, 2, KEY_PERS )

;

}

} /* end if RELJJEXT == CHILD */

} /* end FIND_SIB loop */

/* Resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to

direct descendant or ancestor relations. */

FIND_ANC:

for (KEY_DEX = 0; KEY_PERS [KEY_DEX] . REL_NEXT != NULL_REL; KEY_DEX-H-)

{

if (KEY_PERS [KEY_DEX] . RELJJEXT == CHILD | | KEY_PERS [KEY_DEX] . REL_NEXT == PARENT)

{

for (LKEY_DEX = KEYJDEX + 1; KEYJPERS [LKEY_DEX] . RELJJEXT == KEYJ>ERS [KEYJDEX] . RELJJEXT;

LKEY_DEX-H-) ; GENJ:NT = LKEYJDEX - KEYJDEX;

if (GENJJNT > 1) /* compress generations */

{

KEYJ'ERS [KEYJDEX] . GEN_GAP = GENJINT;

CONDENSE (KEY_DEX, GENJ]NT - 1, KEY_PERS )

;

}

} /* end if RELJJEXT == CHILD or PARENT */

} /* end FIND ANC loop */
Page 66

/* Resolve CHILD-SIBLING-PARENT to COUSIN,

CHILD-SIBLING to NEPHEW,

SIBLING-PARENT to UNCLE. */

FIND_CUZ:

for (KEYJDEX = 0; KEY_PERS [KEY_DEX] . REL_NEXT != NULL_REL; KEY_DEX-H-)

{

LKEY_REL = KEY_PERS [KEYJDEX + 1] . REL_NEXT;

if (KEY_PERS [KEY_DEX] . REL_NEXT == CHILD && LKEY_REL == SIBLING)

{ /* COUSIN or NEPHEW */

if (KEY_PERS [KEY_DEX + 2] . REL_NEXr == PARENT)

{ /* found COUSIN */

COUNTER GAPl, GAP2;

GAPl = KEY_PERS [KEY_DEX] . GEN_GAP;

GAP2 = KEYJPERS [KEY_DEX + 2] . GEN_GAP;

KEY_PERS [KEY_DEX] . PROXIMTY = KEY_PERS [KEY_DEX + 1] . PROXIMTY;

KEY_PERS [KEY_DEX] . GEN_GAP

= (GAPl < GAP2) ? (GAP2 - GAPl) : (GAPl - GAP2);

KEY_PERS [KEY_DEX] . CUZ_RANK = (GAPl < GAP2) ? GAPl : GAP2;

KEY_PERS [KEYJDEX] . RELJ^EXT = COUSIN;

CONDENSE (KEY_DEX, 2, KEY_PERS )

;

}

else /* found NEPHEW */

{

KEY_PERS [KEYJDEX] . PROXIMTY = KEYJ>ERS [KEYJDEX + 1] . PROXIMTY;

KEY_PERS [KEYJ)EX] . REL_NEXT = NEPHEW;

CONDENSE (KEYJDEX, 1, KEYJ>ERS);

}

} /* end COUSIN or NEPHEW */

else

if (KEYJ>ERS [KEYJDEX] . RELJJEXT == SIBLING && LKEYJIEL == PARENT)

{ /* found UNCLE */

KEYJ>ERS [KEYJDEX] . GENJSAP = KEYJ'ERS [KEYJDEX + 1] . GENJSAP;

KEY_PERS [KEY_DEX] . RELJJEXT = UNCLE;

CONDENSE (KEYJDEX, 1, KEYJ'ERS);

}

} /* end FIND CUZ loop */
Page 67

/* Loop below will pick out valid adjacent strings of elements

to be displayed. KEY_DEX points to first element,

LKEY_DEX to last element, and PRIM_DEX to the

element which determines the primary English word to be used.

Associativity of adjacent elements in condensed table

is based on English usage. */

printf (" Condensed path:\n");

CONSLIDT

for (KEYJDEX = 0; KEY_PERS [KEY_DEX] . REL_NEXT != NULL_REL;

KEY DEX = LKEY DEX + 1)

{

KEY_REL = KEY_PERS [KEY_DEX] . RELJIEXT;

LKEY_DEX = KEY_DEX;

PRIMJDEX = KEY_DEX;

if (KEY_PERS [KEY_DEX + 1] . REL_NEXT != NULL_REL)

{ /* seek multi-element combination */

SEEKMORE = TRUE;

if (KEY_REL == SPOUSE)

{

PRIMJDEX = -H-LKEY_DEX;

/* Nothing can follow SPOUSE-SIBLING or SPOUSE-COUSIN */

SEEKMORE = ! (KEY PERS [LKEY DEX] . REL NEXT & (SIBLING I COUSIN));

} _ - _

/* PRIMJDEX is now correctly set. Next if-statement

determines if a following SPOUSE relation should be

appended to this combination or left for the next

combination. */

if (SEEKMORE && KEY_PERS [PRIM_DEX + 1] . RELJJEXT == SPOUSE)

{ /* Only a SPOUSE can follow a Primary;

check primary preceding and following SPOUSE. */

PRIM_REL = KEY_PERS [PRIM_DEX] . REL_NEXT;

NXT_PRIM = KEY_PERS [PRIM_DEX + 2] . RELJJEXT;

if ((NXT_PRIM & (NEPHEW | COUSIN I NULL_REL))

I I (PRIM_REL == NEPHEW)

II ((PRIM_REL & (SIBLING | PARENT)) && NXT_PRIM != UNCLE ))

/* append following SPOUSE with this combination. */

LKEY_DEX-H-;

}

} /* end multi-element combination */

SHOW_REL (KEYJDEX, LKEY_DEX, PRIM_DEX, KEY_PERS);

} /* end CONSLIDT loop */

printf (" %ls\n", PERSON [KEYJ>ERS [KEYJ)EX] . PERSJ)EX] . NAME);

} /* end of RESOLVE */
Page 68

BOOLEAN FULL_SIB (INDEXl, INDEX2)

/* Determines whether two PERSONS are full siblings, I.e.,

have the same two parents. */

register INDX TYP INDEXl, INDEX2;

{

}

return

! STREQ (PERSON [INDEXl

! STREQ (PERSON [INDEXl

STREQ (PERSON [INDEXl] . PERSON [INDEX2] . STREQ (PERSON [INDEXl] . PERSON [INDEX2] ,

. REL_ID [FATHR_ID], NULL_ID) &&

. REL_ID [MOTHR_ID] , NULL_ID) &&

REL_ID [FATHR_ID],

REL_ID [FATHR_ID]) &&

REL_ID [MOTHR_ID],

REL ID [MOTHR ID]);

CONDENSE (AT_INDEX, GAP_SIZE, KEY_PERS)

/* CONDENSE condenses superfluous entries from the

KEY PERS array, starting at AT INDEX. */

register INDXJIYP

COUNTER

KEY_REC

{ register INDXJTYP

do

{

AT_INDEX;

GAP_SIZE;

KEY_PERS [];

SEND DEX;

AT_INDEX-H-;

SEND_DEX = AT_INDEX + GAP_SIZE;

KEY_PERS [AT_INDEX] = KEY_PERS [SEND_DEX];

}

while (KEY PERS [SEND DEX] . REL NEXT != NULL REL);
Page 69

/* procedures under RESOLVE */

SHOW_REL (FRST_DEX, 1AST_DEX, PRIM_DEX, KEY_PERS)

/* SHOW_REL takes 1, 2, or 3 adjacent elements in the

condensed table and generates the English description of

the relation between the first and last + 1 elements. */

INDXJTYP

KEY_REC

BOOLEAN

SIBJTYPE

GNDRJTYP

short int

register REL_TYPE

COUNTER

FRST_DEX, LAST_DEX, PRIM_DEX;

KEY_PERS [];

INLAW;

THIS_PRX;

THIS_GND;

SUFFIX;

FRST_REL, LAST_REL, PRIM_REL;

THIS GAP, THIS CUZ

;

FRST_REL = KEY_PERS [FRST_DEX] . REL_NEXT;

LAST_REL = KEY_PERS [LAST_DEX] . REL_NEXT;

PRIM_REL = KEYJPERS [PRIM_DEX] . REL_NEXT;

/* set THIS_PRX */

if ((PRIM_REL == PARENT && FRST_REL = SPOUSE) ||

(PRIM_REL == CHILD && LAST_REL == SPOUSE))

THIS_PRX = STEP;

else

if (PRIM_REL & (SIBLING I UNCLE | NEPHEW I COUSIN))

THIS_PRX = KEY_PERS [PRIM_DEX] . PROXIMTY;

else

THIS_PRX = FULL;

/* set THIS_GAP */

if (PRIM_REL & (PARENT | CHILD | UNCLE I NEPHEW I COUSIN))

THIS_GAP = KEY_PERS [PRIM_DEX] . GEN_GAP;

else

THIS_GAP =0;

/* set INLAW */

INLAW = FALSE;

if (FRST_REL == SPOUSE && (PRIM_REL & (SIBLING | CHILD | NEPHEW I COUSIN)))

INLAW = TRUE;

else

if (LAST_REL == SPOUSE &&

(PRIM_REL & (SIBLING | PARENT | UNCLE | COUSIN)))

INLAW = TRUE;

/* set THIS_CUZ */

if (PRIM_REL == COUSIN)

THIS_CUZ = KEY_PERS [PRIM_DEX] . CUZ_RANK;

else

THIS CUZ = 0;
Page 70

/* parameters are set - now generate display. */

printf (" %ls is ", PERSON [KEY PERS [FRST_DEX] . PERSJDEX] . NAME);

if (PRIM_REL & (PARENT | CHILD T UNCLE | NEPHEW))

{ /* display generation-qualifier */

if (THIS_GAP >= 3)

{

printf ("great");

if (THIS_GAP > 3)

printf ("*%ld", THIS_GAP - 2);

printf ("-");

}

if (THIS_GAP >= 2)

printf ("grand-");

if (PRIM_REL == COUSIN && THIS_CUZ > 1)

{

printf ("%ld", THIS_CUZ);

SUFFIX = THIS_CUZ % 10;

switch (SUFFIX)

}

}

if (THIS_PRX == STEP)

printf ("step-");

else

if (THIS_PRX == HALF)

printf ("half-");

else

case 1: printf

case 2: printf

case 3: printf

default: printf

("st ")

("nd ")

("rd ")

("th ")

break;

break;

break;

break;
THIS_GND = PERSON [KEY_PERS [FRST_DEX] . PERS_DEX] . GENDER

switch (PRIM_REL)

{ case PARENT : if (THIS GND == MALE) printf (

' "father" )

;

else printf ([ "mother" )

;

break

;

case CHILD : if (THIS GND == MALE) printf (

' "son" )

;

else printf (, daughter );

break:;

case SPOUSE : if (THIS GND == MALE) printf (

' "husband" )

;

else printf , wife );

break j case SIBLING: if (THIS GND == MALE) printf (, brother )

;

else printf (' "sister" )

;

break

;

case UNCLE : J £ / Tin X O O XTTV *jl A T T? \ ir (THIS GND == MALE) printf , uncle )

;

else printf [ "aunt " )

;

break; case NEPHEW : if (THIS GND == MALE) printf (

' "nephew" )

;

else printf <^"niece" )

;

break;

case COUSIN : printf ("cousin");

break;

default : printf ("null");

break;

}

if (INLAW)

printf ("-in-law");

if (PRIM_REL == COUSIN && THIS_GAP > 0)

if (THIS_GAP > 1)

printf (" %ld times removed", THIS_GAP);

else

printf (" once removed");

printf (" of\n");

/* end of SHOW REL */
Page 72

/* procedures under FIND_REL */

CMPT_GNS (INDEXl, INDEX2)

/* CMPT_GNS assumes that each ancestor contributes

half of the genetic material to a PERSON. It finds common ancestors between two PERSONS and computes the expected

value of the PROPORTN of common material. */

register INDXJTYP INDEXl, INDEX2;

{ float COM_PROP;

/* First zero out all ancestors to allow adding. This is necessary

because there might be two paths to an ancestor. */

ZERO_PRO (INDEXl);

/* now mark with shared PROPORTN */

MARK_PRO (PERSON [INDEXl] . IDENT, 1.0, INDEXl);

COM_PROP =0.0;

CHK_COM ( & COM_PROP, PERSON [INDEXl] . IDENT, 1.0, 0.0, INDEX2);

printf (" Proportion of common genetic material = %1.5e \n",

COM_PROP);

} /* end of CMPT_GNS */

ZERO_PRO (ZERO_DEX)

/* ZERO_PRO recursively seeks out all ancestors and zeros them out . */

register INDXJTYP ZEROJDEX;

{ register NBR_PTR THIS_NBR;

PERSON [ZERO_DEX] . DSC_GENE = 0.0;

for (THIS_NBR = PERSON [ZERO_DEX] . NBR_HDR;

THIS_NBR != NULL;

THIS_NBR = THIS_NBR -> NEXT NBR)

{ if (THIS_NBR -> NBR_EDGE == PARENT)

ZERO_PRO (THIS NBR -> NBR DEX);

}

} /* end of ZERO PRO */
MARK_PRO (MARKER, PROPORTN, MARK_DEX)

/* MARK_PRO recursively seeks out all ancestors and

marks them with the sender's PROPORTN of shared

genetic material. This PROPORTN is diluted by one-half

for each generation. */

IDJTYPE MARKER;

float PROPORTN;

INDXJTYP MARK_DEX;

{ register NBR_PTR THIS_NBR;

strcpy (PERSON [MARKJDEX] . DSC_ID, MARKER);

PERSON [MARK_DEX] . DSC_GENE += PROPORTN;

for (THIS_NBR = PERSON [MARK_DEX] . NBR_HDR;

THIS_NBR != NULL;

THIS_NBR = THIS_NBR -> NEXT NBR)

{

if (THISJJBR -> NBR_EDGE == PARENT)

MARK_PRO (MARKER, PROPORTN / 2.0, THIS NBR -> NBR DEX);

}

} /* end of MARK_PRO */

CHK_COM (COM_PTR, MATCH_ID, PROPORTN, COUNTED, CHKJDEX)

/* CHK_COM searches all the ancestors of

CHK_DEX to see if any have been marked, and if so adds the appropriate amount to *COM_PTR. */

float *COM_PTR, PROPORTN, COUNTED;

IDJTYPE MATCH_ID;

INDXJTYP CHKJ)EX;

{ register NBR_PTR THIS_NBR;

register float CONTRIB;

if (STREQ (PERSON [CHK_DEX] . DSC_ID, MATCH_ID))

{ /* Increment *COM_PTR by the contribution of

this common ancestor, but discount for the contribution

of less remote ancestors already counted. */

CONTRIB = PERSON [CHK_DEX] . DSC_GENE * PROPORTN;

*COM PTR 4= CONTRIB - COUNTED;

}

else

CONTRIB =0.0;

for (THISJJBR = PERSON [CHKJ)EX] . NBRJIDR;

THIS_NBR != NULL;

THISJJBR = THISJJBR -> NEXTJJBR)

{

if (THISJJBR -> NBRJIDGE == PARENT)

CHKj:OM (COM_PTR, MATCH_ID, PROPORTN / 2.0,

CONTRIB / 4.0, THISJJBR -> NBRJ)EX);

}

} /* end of CHK COM */
Page 74

5.0 COBOL

In keeping with the general convention of the examples, language- supplied

keywords and identifiers are written in lower case in the program. To conform

strictly to the COBOL-74 standard, however, programs must use only upper-case

letters

.

* Compilation unit number 1

identification division,

program- id. RELATE.

environment division.

configuration section,

source-computer. VAX-11.

object-computer. VAX-11.

input-output section,

file-control

.

select PEOPLE assign to "PEOPLE.DAT",

file status is PEOPLE -STATUS

.

data division.

file section,

fd PEOPLE

label records are standard.

01 PEOPLE -RECORD.

05 NAME pic X(20).

05 IDENTIFIER pic 999. *** "M" for MALE and "F" for FEMALE

05 GENDER pic X.

05 IMMEDIATE -RELATIONS.

10 RELATIVE-IDENTIFIER occurs 3 times pic 999.

working-storage section.

77 ARG-PERSONl-INDEX pic 999.

77 ARG-PERS0N2 -INDEX pic 999.

01 PEOPLE -STATUS.

05 STATUS -1 pic X.

88 END -OF -PEOPLE -FILE value "1".

05 STATUS -2 pic X.

* Define global objects

01 TRUTH-VALUES.

05 IS-TRUE pic X value "T"

.

05 IS-FALSE pic X value "F".

01 SPECIAL-IDENT-VALUE.

05 NULL-IDENT pic 999 value 000.
* each person's record in the file identifies at most three

* others directly related: father, mother, and spouse

01 GIVEN-IDENTIFIERS.

01

05 FATHER-IDENT pic 9 value 1. 05 MOTHER- IDENT pic 9 val ue 2.

05 SPOUSE-IDENT pic 9 value 3.

GENDER-TYPE

.

05 MALE pic X value "M' 05 FEMALE pic X value "F'

T>T7T A T* T *^"M T>\7TiT7 RELAl ION—TYPE

.

05 PARENT pic 9 value 1. 05 CHILD pic 9 value 2.

05 SPOUSE pic 9 value 3.

05 SIBLING pic 9 value 4.

05 UNCLE pic 9 value 5.

05 NEPHEW pic 9 value 6.

05 COUSIN pic 9 value 7.

05 NULL -RELATION pic 9 value 8.

* A node in the graph (= PERSON) has either already been reached,

* is immediately adjacent to those reached, or farther away.

01 REACHED-TYPE.

05 REACHED pic 9 value 1. 05 NEARBY pic 9 value 2.

05 NOT-SEEN pic 9 value 3.
Page 76

* the PERSON array is the central repository of information

* about inter-relationships.

* All relationships are captured in the directed graph of which

* each record is a node

.

01 PERSON-TABLE.

05 NUMBER-OF -PERSONS usage index.

05 PERSON occurs 300 times

indexed by CURRENT, PREVIOUS,

FROM-INDEX, TO-INDEX,

PERSON 1-INDEX, PERS0N2-INDEX.

*** static information - filled from PEOPLE file:

10 NAME pic X(20).

10 IDENTIFIER pic 999.

10 GENDER pic X. *** IDENTIFIERS of immediate relatives - father, mother, spouse

10 IMMEDIATE-RELATIONS.

15 RELATIVE -IDENTIFIER occurs 3 times indexed by RELATIONSHIP

pic 999. *** pointers to immediate neighbors in graph

10 NEIGHBOR-COUNT pic 99.

10 NEIGHBOR-RECORD occurs 20 times indexed by NEXT-NEIGHBOR.

15 NEIGHBOR-INDEX usage index.

15 NEIGHBOR-EDGE pic 9. *** data used when traversing graph to resolve user request:

10 DI STANCE -FROM-SOURCE pic 99999V9.

10 PATH-PREDECESSOR usage index.

10 EDGE-TO-PREDECESSOR pic 9.

10 REACHED-STATUS pic 9. *** data used to compute common genetic material

10 DESCENDANT-IDENTIFIER pic 999.

10 DESCENDANT-GENES pic 9V99999999.

* These variables are used t * RELATIONSHIP information.

01 RELATIONSHIP-WORK-ITEMS.

05 REQUEST-BUFFER

88 REQUEST-TO-STOP

05 PERSONl-IDENT

05 PERS0N2-IDENT

05 PERSON1 -FOUND

05 PERS0N2-F0UND

05 ERROR-MESSAGE

05 REQUEST-OK

01 AUXILIARY-VARIABLES.

05 RELATION-LOOP-DONE

88 RELATION-LOOP-IS

05 TEMP-INDEX

05 THIS -EDGE

05 LEADING-SPACES

05 SEMICOLON-COUNT

05 CURRENT-IDENT

05 PREVIOUS-IDENT

05 TEMP-IDENT

accept and resolve requests for

pic X(60).

value "stop",

pic X(20).

pic X(20).

pic 999.

pic 999.

pic X(40).

pic X(40) value "Request OK".

pic X.

•DONE value "T".

usage index,

pic 9.

pic 99.

pic 99.

pic 999.

pic 999.

pic X(20).
Page 7 7

procedure division.

MAIN-LINE.

open input PEOPLE.

read PEOPLE at end perform NULL.

* This loop reads in the PEOPLE file and constructs the PERSON

* array from it (one PERSON = one record = one array entry).

* As records are read in, links are constructed to represent the

* PARENT-CHILD or SPOUSE RELATIONSHIP. The array then implements

* a directed graph which is used to satisfy subsequent user

* requests. The file is assumed to be correct - no validation

* is performed on it.

perform READ-IN-PEOPLE thru READ-IN-PEOPLE-EXIT

varying CURRENT from 1 by 1 until END-OF-PEOPLE-FILE.

set CURRENT down by 1. set NUMBER-OF-PERSONS to CURRENT,

close PEOPLE.

* PERSON array is now loaded and edges between immediate relatives

* (PARENT-CHILD or SPOUSE -SPOUSE) are established.

perform PROMPT -AND-READ.

* While-loop accepts requests and finds RELATIONSHIP (if any)

* between pairs of PERSONS.

perform READ-AND-PROCESS-REQUEST thru READ-AND-PROCESS-REQUEST-EXIT

until REQUEST-TO-STOP,

display " End of relation-finder.",

stop run.

READ-IN-PEOPLE.

*** copy direct information from file to array

move corresponding PEOPLE -RECORD to PERSON (CURRENT),

move IMMEDIATE-RELATIONS of PEOPLE-RECORD

to IMMEDIATE -RELATIONS of PERSON (CURRENT). *** Location of adjacent persons as yet undetermined

move zero to NEIGHBOR-COUNT of PERSON (CURRENT). *** Descendants as yet undetermined

move NULL-IDENT to DESCENDANT-IDENTIFIER of PERSON (CURRENT), move IDENTIFIER of PERSON (CURRENT) to CURRENT-IDENT.

*** Compare this PERSON against all previously entered PERSONS

*** to search for RELATIONSHIPS.

perform COMPARE-TO-PREVIOUS varying PREVIOUS from 1 by 1 until PREVIOUS not < CURRENT,

read PEOPLE at end perform NULL.

READ-IN-PEOPLE-EXIT.

exit.

NULL.

exit

.
Page 78

COM PARE -TO-PREVIOUS

.

move IDENTIFIER of PERSON (PREVIOUS) to PREVIOUS -IDENT. *** Search for father, mother, or spouse relationship in *** either direction between this and PREVIOUS PERSON.

*** Assume at most one RELATIONSHIP exists, move IS-FALSE to RELATION-LOOP-DONE,

perform TRY-ALL -RELATIONSHI PS

varying RELATIONSHIP from FATHER-IDENT by 1 until RELATIONSHIP > SPOUSE-IDENT or RELATION-LOOP-IS-DONE.

TRY-ALL -RELATIONSHIPS

.

if RELATIVE -IDENTIFIER of PERSON (CURRENT, RELATIONSHIP) = PREVIOUS-IDENT

set FROM-INDEX to CURRENT

set TO-INDEX to PREVIOUS

perform LINK-RELATIVES

move IS-TRUE to RELATION-LOOP-DONE

else

if CURRENT-IDENT = RELATIVE -IDENTIFIER of PERSON (PREVIOUS, RELATIONSHIP)

set FROM-INDEX to PREVIOUS

set TO-INDEX to CURRENT

perform LINK-RELATIVES

move IS-TRUE to RELATION-LOOP-DONE.

LINK-RELATIVES.

* establishes cross-indexing between immediately related PERSONS.

if RELATIONSHIP = SPOUSE-IDENT

move SPOUSE to THIS -EDGE

perform LINK-ONE -WAY

set TEMP-INDEX to FROM-INDEX

set FROM-INDEX to TO-INDEX

set TO-INDEX to TEMP-INDEX

perform LINK-ONE -WAY

else

* RELATIONSHIP is father or mother

move PARENT to THIS -EDGE

perform LINK-ONE-WAY

move CHILD to THIS -EDGE

set TEMP-INDEX to FROM-INDEX

set FROM-INDEX to TO-INDEX

set TO-INDEX to TEMP-INDEX

perform LINK-ONE -WAY.

LINK-ONE -WAY. *** Establishes the NEIGHBOR-RECORD from one PERSON to another

add 1 to NEIGHBOR-COUNT of PERSON (FROM-INDEX).

set NEXT-NEIGHBOR to NEIGHBOR-COUNT of PERSON (FROM-INDEX).

set NEIGHBOR-INDEX of PERSON (FROM-INDEX, NEXT -NEIGHBOR)

to TO-INDEX. move THIS-EDGE

to NEIGHBOR-EDGE of PERSON (FROM-INDEX, NEXT-NEIGHBOR)

.
PROMPT-AND -READ.

* Issues prompt for user-request, reads In request,

* blank-fills buffer, and skips to next line of input.

display " ". display " ". display " Enter two person-identifiers (name or number),",

display " separated by semicolon. Enter ""stop"" to stop.", move spaces to REQUEST-BUFFER,

accept REQUEST-BUFFER.

READ -AND -P ROCE S

S -RE QUE S T

.

perform CHECK-REQUEST.

*** Syntax check of request completed. Now either display error

*** message or search for the two PERSONS.

if ERROR-MESSAGE = REQUEST-OK

perform PROCESS-LEGAL-REQUEST

else

display " Incorrect request format: ", ERROR-MESSAGE,

perform PROMPT-AND -READ.

READ-AND-PROCE S

S -RE QUE ST -E XI T

.

exit

.

CHECK-REQUEST.

* Performs syntactic check on request in buffer

* and fills in identifiers of the two requested persons.

move zero to SEMICOLON-COUNT.

inspect RE QUE ST -BUFFER tallying SEMICOLON-COUNT

for all "

; "

.

if SEMICOLON-COUNT not = 1 move "must be exactly one semicolon." to ERROR-MESSAGE

else

move zero to LEADING-SPACES

inspect REQUEST-BUFFER tallying LEADING-SPACES

for leading spaces

add 1 to LEADING-SPACES

unstring REQUEST-BUFFER delimited by ";"

into PERSONl-IDENT, TEMP-IDENT

with pointer LEADING-SPACES

if PERSONl-IDENT = spaces

move "null field preceding semicolon." to ERROR-MESSAGE

else

if TEMP-IDENT = spaces

move "null field following semicolon." to ERROR-MESSAGE

else

move zero to LEADING-SPACES

inspect TEMP-IDENT tallying LEADING-SPACES

for leading spaces

add 1 to LEADING-SPACES

unstring TEMP-IDENT into PERS0N2-IDENT

with pointer LEADING-SPACES

move REQUEST-OK to ERROR-MESSAGE.
Page 80

PROCE SS -LEGAL-REQUE ST

.

*** search for requested PERSONS.

move zero to PERSON 1-FOUND, PERS0N2-F0UND.

perform SCAN-ALL-PERSONS varying CURRENT from 1 by 1 until CURRENT > NUMBER-OF -PERSONS,

if PERSON1-FOUND = 1 and PERSON2 -FOUND = 1 *** Exactly one match for each PERSON - proceed to *** determine RELATIONSHIP, if any.

if PERSONl-INDEX = PERS0N2-INDEX

if GENDER of PERSON (PERSONl-INDEX) = MALE

display " ", NAME of PERSON (PERSONl-INDEX),

is identical to himself."

else

display " ", NAME of PERSON (PERSONl-INDEX),

is identical to herself."

else

set ARG-PERSONl-INDEX to PERSONl-INDEX

set ARG-PERS0N2-INDEX to PERS0N2-INDEX

call "FINDREL" using

ARG-PERSONl-INDEX, ARG-PERS0N2-INDEX, PERSON-TABLE

else *** either not found or more than one found

perform MISSING-OR-DUPLICATE -PERSONS

.

SCAN-ALL-PERSONS

.

if PERSONl-IDENT = NAME of PERSON (CURRENT) or IDENTIFIER of PERSON (CURRENT)

set PERSONl-INDEX to CURRENT

add 1 to PERSONl-FOUND.

if PERS0N2-IDENT = NAME of PERSON (CLTIRENT) or IDENTIFIER of PERSON (CURRENT)

set PERS0N2-INDEX to CURRENT

add 1 to PERS0N2-F0UND.

MISSING-OR-DUPLICATE-PERSONS.

if PERSONl-FOUND = zero display " First person not found."

else

if PERSONl-FOUND > 1 display " Duplicate names for first person - use",

numeric identifier.",

if PERS0N2-F0UND = zero display " Second person not found."

else

if PERS0N2-F0UND > 1 display " Duplicate names for second person - use"

,

numeric identifier.".
Page 81

* Compilation unit number 2

identification division,

program-id. FINDREL.

* Finds shortest path (if any) between two PERSONS and

* determines their RELATIONSHIP based on immediate relations

* traversed in path. PERSON array simulates a directed graph,

* and algorithm finds shortest path, based on following

* weights: PARENT-CHILD edge =1.0

* SPOUSE -SPOUSE edge = 1.8

environment division.

configuration section,

source-computer. VAX-11.

object-computer. VAX-11.

data division,

working-storage section.

* Define global objects

01 TRUTH-VALUES.

05 IS-TRUE pic X value "T"

.

05 IS-FALSE pic X value "F".

* each PERSON'S record in the file identifies at most three

* others directly related: father, mother, and spouse

01 GIVEN-IDENTIFIERS.

01

05 FATHER-IDENT pic 9 value 1. 05 MOTHER-IDENT pic 9 val ue 2.

05 SPOUSE -I DENT pic 9 value 3.

GENDER-TYPE.

05 MALE pic X value "M' 05 FEMALE pic X value "F'

RELATION-TYPE.

05 PARENT pic 9 value 1. 05 CHILD pic 9 value 2.

05 SPOUSE pic 9 value 3.

05 SIBLING pic 9 value 4.

05 UNCLE pic 9 value 5.

05 NEPHEW pic 9 value 6.

05 COUSIN pic 9 value 7.

05 NULL -RELATION pic 9 value 8.
Page 82

* A node in the graph (= PERSON) has either already been reached,

* is immediately adjacent to those reached, or farther away.

01 REACHED-TYPE

.

05 REACHED pic 9 value 1. 05 NEARBY pic 9 value 2.

05 NOT -SEEN pic 9 value 3.

01 SEARCH-TYPE.

05 SEARCHING pic 9 value 1. 05 SUCCEEDED pic 9 value 2.

05 FAILED pic 9 value 3.

SIBLING-TYPE.

05 STEP pic 9 value 1. 05 HALF pic 9 value 2.

05 FULL pic 9 value 3.

01 KEY-PERSON-TABLE.

05 KEY-PERSON occurs 300 times

indexed by KEY-INDEX, LATER-KEY-INDEX, PRIMARY-INDEX,

FIRST-INDEX, LAST-INDEX,

RECEIVE -INDEX, SEND-INDEX.

10 RELATION-TO -NEXT pic 9.

10 PERSON-INDEX usage index.

10 GENERATION-GAP pic 999.

10 PROXIMITY pic 9.

10 COUSIN-RANK pic 999.

01 AUXILIARY-VARIABLES.

*** these variables are used to find the shortest path

05 WEIGHT-THIS-EDGE pic 99V9.

05 DISTANCE -THRU-BASE -NODE pic 99999V9.

05 SEARCH-STATUS pic 9.

05 NEARBY-NODE usage index, occurs 300 times,

indexed by THIS-NEARBY-INDEX, BEST-NEARBY-INDEX, LAST -NEARBY-INDEX.

05 THIS-EDGE pic 9.

05 NEXT-BASE -EDGE pic 9.

05 MINIMAL-DISTANCE pic 9999999V9.

05 DISPLAY-BUFFER pic X(70).

05 DISPLAY-POINTER pic 99.

05 NULL-IDENT pic 999 value 000.

*** these variables are used to condense the path

05 KEY-RELATION pic 9.

05 LATER-KEY-RELATION pic 9.

05 PRIMARY-RELATION pic 9.

05 FIRST-RELATION pic 9.

05 LAST-RELATION pic 9.

05 NEXT -PRIMARY-RELATION pic 9.

05 GAP-SIZE pic 999.

05 ANOTHER-ELEMENT-POSSIBLE pic X.

88 ANOTHER-ELEMENT-IS-POSSIBLE value "T".
Page 83

*** these variables are used to generate KEY-PERSONs and for DISPLAY

05

05

05

05

05

05

05

05

05

05

05

05

05

GENERATION-COUNT

TEMP -NUMBER

THIS -COUSIN-RANK

THIS -PROXIMITY

THIS-GENDER

THIS-GENERATION-GAP

SUFFIX-INDICATOR

TWO-DIGIT-FIELD

INLAW

88 RELATION-IS -INLAW

MALE-NAME -VALUE S

.

pic 999.

pic 999.

pic 999.

pic 9.

pic X.

pic 999.

pic 9

.

pic Z9.

pic X.

value "T".

10 filler pic X(8) value "father

10 filler pic X(8) value " son

10 filler pic X(8) value "husband

10 filler pic X(8) value "brother

10 filler pic X(8) value "uncle

10 filler pic X(8) value "nephew

10 filler pic X(8) value "cousin

10 filler pic X(8) value "null

MALE -NAME -TABLE redefines MALE -NAME -VALUES.

10 PRIMARY-MALE -NAME pic X(8) occurs 8 times

indexed by MALE-INDEX.

FEMALE-NAME -VALUE S

.

10 filler pic X(8) value "mother

10 filler pic X(8) value "daughter

10 filler pic X(8) value "wife

10 filler pic X(8) value "sister

10 filler pic X(8) value "aunt

10 filler pic X(8) value "niece

10 filler pic X(8) value "cousin

10 filler pic X(8) value "null

FEMALE-NAME-TABLE redefines FEMALE -NAME-VALUES.

10 PRIMARY-FEMALE -NAME pic X(8) occurs 8 times

indexed by FEMALE-INDEX.
Page 84

linkage section.

77 PARM-TARGET-INDEX pic 999.

77 PARM-SOURCE-INDEX pic 999.

01 PERSON-TABLE.

05 NUMBER-OF -PERSONS usage index.

05 PERSON occurs 300 times

indexed by INDEXl, INDEX2, TARGET-INDEX, SOURCE -INDEX,

BASE -NODE, THIS -NODE, NEXT -NODE.

*** static information - filled from PEOPLE file:

10 NAME pic X(20).

10 IDENTIFIER pic 999.

10 GENDER pic X. *** IDENTIFIERS of immediate relatives - father, mother, spouse

10 IMMEDIATE -RELATIONS.

15 RELATIVE -IDENTIFIER occurs 3 times indexed by RELATIONSHIP

pic 999. *** pointers to immediate neighbors in graph

10 NEIGHBOR-COUNT pic 99.

10 NEIGHBOR-RECORD occurs 20 times indexed by THIS -NEIGHBOR.

15 NEIGHBOR-INDEX usage index.

15 NEIGHBOR-EDGE pic 9. *** data used when traversing graph to resolve user request:

10 DISTANCE -FROM-SOURCE pic 99999V9.

10 PATH-PREDECESSOR usage index.

10 EDGE-TO-PREDECESSOR pic 9.

10 REACHED-STATUS pic 9. *** data used to compute common genetic material

10 DESCENDANT-IDENTIFIER pic 999.

10 DESCENDANT-GENES pic 9V99999999.

procedure division using

PARM-TARGET-INDEX, PARM-SOURCE-INDEX, PERSON-TABLE.

MAIN-LINE.

set TARGET -INDEX to PARM-TARGET-INDEX.

set SOURCE-INDEX to PARM-SOURCE-INDEX.

*** initialize PERSON-array for processing - *** mark all nodes as not seen perform MARK-AS-NOT-SEEN varying THIS-NODE from 1 by 1 until THIS-NODE > NUMBER-OF-PERSONS.

set THIS-NODE to SOURCE -INDEX.

*** mark source node as REACHED

move REACHED to REACHED-STATUS of PERSON (THIS-NODE). move zero to DISTANCE -FROM-SOURCE of PERSON (THIS-NODE).

*** no nearby nodes exist yet

set LAST-NEARBY-INDEX to 1.

set LAST-NEARBY-INDEX down by 1. if THIS-NODE = TARGET-INDEX

move SUCCEEDED to SEARCH-STATUS

else

move SEARCHING to SEARCH-STATUS.
*** Loop keeps processing closest-to-source , unREACHED node

*** until target REACHED, or no more connected nodes.

perform SEARCH-FOR-TARGET until SEARCH-STATUS not = SEARCHING.

Shortest path between PERSONS now established. Next task is

to translate path to English description of RELATIONSHIP,

if SEARCH-STATUS = FAILED

display " " , NAME of PERSON (TARGET-INDEX) , " is not related to ",

NAME of PERSON (SOURCE -INDEX)

elsesuccess - parse path to find and display RELATIONSHIP

perform RESOLVE-PATH-TO-ENGLISH

call "COMGENES" using

PARM-SOURCE -INDEX, PARM-TARGET-INDEX, PERSON-TABLE.

OF-FINDREL.

exit program.

MARK-AS-NOT-SEEN.

move NOT-SEEN to REACHED-STATUS of PERSON (THIS-NODE).

SEARCH-FOR-TARGET.

*** Process all nodes adjacent to THIS-NODE

perform PROCESS-ADJACENT-NODE varying THIS-NEIGHBOR from 1 by 1 until THIS-NEIGHBOR > NEIGHBOR-COUNT of PERSON (THIS-NODE).

*** All nodes adjacent to THIS-NODE are set. Now search for *** shortest-distance unREACHED (but NEARBY) node to process next,

if LAST-NEARBY-INDEX = zero move FAILED to SEARCH-STATUS

else *** determine next node to process

move 9999999 to MINIMAL-DISTANCE

perform FIND-CLOSEST-UNREACHED-NODE varying THIS-NEARBY-INDEX

from 1 by 1 until THIS-NEARBY-INDEX > LAST-NEARBY-INDEX

*** establish new THIS-NODE

set THIS-NODE to NEARBY-NODE (BE ST -NEARBY-INDEX)

*** change THIS-NODE from being NEARBY to REACHED

move REACHED to REACHED-STATUS of PERSON (THIS-NODE)

*** remove THIS-NODE from NEARBY list

set NEARBY-NODE (BEST-NEARBY-INDEX) to NEARBY-NODE (LAST-NEARBY-INDEX)

set LAST -NEARBY-INDEX down by 1 if THIS-NODE = TARGET-INDEX

move SUCCEEDED to SEARCH-STATUS.
Page 86

PROCESS-ADJACENT-NODE

.

set BASE -NODE to THIS-NODE.

set NEXT-NODE to NEIGHBOR-INDEX of PERSON (BASE -NODE, THIS -NEIGHBOR)

.

move NEIGHBOR-EDGE of PERSON (BASE -NODE, THIS-NEIGHBOR)

to NEXT-BASE -EDGE. *** NEXT-NODE is adjacent to last-REACHED node (= BASE-NODE).

*** if NEXT-NODE already REACHED, do nothing.

*** If previously seen, check whether path thru BASE -NODE is *** shorter than current path to NEXT-NODE, and if so re-link

*** next to base. *** If not previously seen, link next to base node,

if NEXT-BASE-EDGE = SPOUSE

move 1.8 to WEIGHT-THIS-EDGE

else

move 1.0 to WEIGHT-THIS-EDGE.

if REACHED-STATUS of PERSON (NEXT-NODE) not = REACHED

add WEIGHT-THIS-EDGE, DISTANCE-FROM-SOURCE of PERSON (BASE -NODE)

giving DISTANCE -THRU-BASE -NODE

if REACHED-STATUS of PERSON (NEXT-NODE ) = NOT-SEEN

move NEARBY to REACHED-STATUS of PERSON (NEXT-NODE)

set LAST-NEARBY-INDEX up by 1 set NEARBY-NODE (LAST-NEARBY-INDEX) to NEXT-NODE

perform LINK-NEXT-NODE -TO-BASE-NODE

else *** REACHED-STATUS = NEARBY

if DISTANCE-THRU-BASE-NODE

< DISTANCE-FROM-SOURCE of PERSON (NEXT-NODE)

per f orm L INK-NE XT -NODE -TO -BASE -NODE

.

LINK-NEXT-NODE -TO-BASE-NODE

.

*** link next to base by re-setting its predecessor index to *** point to base, note type of edge, and re-set distance

*** as it is through base node, move DISTANCE-THRU-BASE-NODE

to DISTANCE-FROM-SOURCE of PERSON (NEXT-NODE),

set PATH-PREDECESSOR of PERSON (NEXT-NODE) to BASE -NODE,

move NEXT -BASE -EDGE to EDGE-TO-PREDECESSOR of PERSON (NEXT-NODE )

.

FIND-CLOSEST-UNREACHED-NODE.

set NEXT-NODE to NEARBY-NODE (THIS-NEARBY-INDEX)

.

if DISTANCE-FROM-SOURCE of PERSON (NEXT -NODE) < MINIMAL-DISTANCE

set BEST-NEARBY-INDEX to THIS-NEARBY-INDEX

move DISTANCE-FROM-SOURCE of PERSON (NEXT-NODE) to MINIMAL-DISTANCE.
Page 87

RESOLVE-PATH-TO-ENGLISH.

*** RESOLVE-PATH-TO-ENGLISH condenses the shortest path to a *** series of RELATIONSHIPS for which there are English

*** descriptions.

*** Key persons are the ones in the RELATIONSHIP path which remain

*** after the path is condensed.

display " Shortest path between identified persons: ". set THIS-NODE to TARGET-INDEX. *** Display path and initialize KEY-PERSON array from path elements,

perform TRAVERSE-SHORTEST-PATH varying KEY-INDEX from 1 by 1 until THIS-NODE = SOURCE-INDEX,

display " ", NAME of PERSON (THIS-NODE).

set PERSON-INDEX of KEY-PERSON (KEY-INDEX) to THIS-NODE. move NULL -RELATION to RELATION-TO-NEXT of KEY-PERSON ( KEY -INDEX )

.

move NULL-RELATION to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1).

*** Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations

*** to SIBLING relations.

perform FIND-SIBLINGS varying KEY-INDEX from 1 by 1 until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL-RELATION.

*** Resolve CHILD-CHILD-... and PARENT-PARENT-... relations to *** direct descendant or ancestor relations.

perform FIND-ANCESTORS-OR-DESCENDANTS varying KEY-INDEX from 1 by 1 until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL -RELATION.

*** Resolve CHILD-SIBLING-PARENT to COUSIN, *** CHILD-SIBLING to NEPHEW,

*** SIBLING-PARENT to UNCLE.

perform FIND-COUSINS-NEPHEWS-UNCLES varying KEY-INDEX from 1 by 1 until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL-RELATION.

*** Loop below will pick out valid adjacent strings of elements

*** to be displayed. KEY-INDEX points to first element,

*** LATER-KEY-INDEX to last element, and PRIMARY-INDEX to the *** element which determines the primary English word to be used.

*** Associativity of adjacent elements in condensed table

*** is based on English usage.

set KEY-INDEX to 1.

display " Condensed path:".

perform CONSOLIDATE -ADJACENT-PERSONS

until RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = NULL-RELATION

set THIS-NODE to PERSON-INDEX of KEY-PERSON (KEY-INDEX).

display " ", NAME of PERSON (THIS-NODE).

*** end of RESOLVE-PATH-TO-ENGLISH
Page 88

TRAVERSE -S HORTEST-PATH

.

set PERSON-INDEX of KEY-PERSON (KEY-INDEX) to THIS-NODE.

move FULL to PROXIMITY of KEY-PERSON (KEY-INDEX)

.

move EDGE-TO-PREDECESSOR of PERSON (THIS-NODE)

to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX)

.

if EDGE-TO-PREDECESSOR of PERSON (THIS-NODE) = SPOUSE

move zero to GENERATION-GAP of KEY-PERSON (KEY-INDEX)

display " NAME of PERSON (THIS-NODE), " is spouse of"

elsemove 1 to GENERATION-GAP of KEY-PERSON (KEY-INDEX)

if EDGE-TO-PREDECESSOR of PERSON (THIS-NODE) = PARENT

display " " , NAME of PERSON (THIS-NODE), " is parent of"

else

** edge is child-type

display " ", NAME of PERSON (THIS-NODE), " is child of",

set THIS-NODE to PATH-PREDECESSOR of PERSON (THIS-NODE).

FIND-SIBLINGS.

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = CHILD

move RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1)

to LATER-KEY-RELATION

if LATER-KEY-RELATION = PARENT

** then found either full or half SIBLINGS

perform SET-UP-FULL-HALF -SIBLING

else

if LATER-KEY-RELATION = SPOUSE and

RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 2) = PARENT

** then found step-siblings

move zero to GENERATION-GAP of KEY-PERSON (KEY-INDEX)

move STEP to PROXIMITY of KEY-PERSON (KEY-INDEX)

move SIBLING to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX)

move 2 to GAP-SIZE

perform CONDENSE-KEY-PERSONS.

SET-UP-FULL-HALF-SIBLING. ** Determines whether two PERSONS are full siblings, i.e.,

'** have the same two parents

.

set INDEXl to PERSON-INDEX of KEY-PERSON (KEY-INDEX),

set INDEX2 to PERSON-INDEX of KEY-PERSON (KEY-INDEX + 2).

if (NULL-IDENT not = RELATIVE -IDENTIFIER of PERSON (INDEXl, FATHER-IDENT)

and RELATIVE-IDENTIFIER of PERSON (INDEXl, MOTHER-IDENT)

)

and (RELATIVE-IDENTIFIER of PERSON (INDEXl, FATHER-IDENT) = RELATIVE -IDENTIFIER of PERSON (INDEX2, FATHER-IDENT))

and (RELATIVE -IDENTIFIER of PERSON (INDEXl, MOTHER-IDENT) = RELATIVE-IDENTIFIER of PERSON (INDEX2, MOTHER-IDENT))

move FULL to PROXIMITY of KEY-PERSON (KEY-INDEX)

elsemove HALF to PROXIMITY of KEY-PERSON (KEY-INDEX), move zero to GENERATION-GAP of KEY-PERSON (KEY-INDEX), move SIBLING to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX),

move 1 to GAP-SIZE,

perform CONDENSE-KEY-PERSONS.
Page 89

FIND-ANCESTORS-OR-DESCENDANTS. if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = CHILD or PARENT

perform NULL varying LATER-KEY-INDEX from KEY-INDEX by 1 until RELATION-TO-NEXT of KEY-PERSON (LATER-KEY-INDEX) not = RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX)

set GENERATION-COUNT to LATER-KEY-INDEX

set TEMP-NUMBER to KEY-INDEX

subtract TEMP-NUMBER from GENERATION-COUNT

if GENERATION-COUNT > 1 *** compress generations

move GENERATION-COUNT to GENERATION-GAP of KEY-PERSON (KEY-INDEX)

subtract 1 from GENERATION-COUNT giving GAP-SIZE

perform CONDENSE -KEY-PERSONS.

FIND-COUSINS-NEPHEWS-UNCLES.

move RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1)

to LATER-KEY-RELATION

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = CHILD and

LATER-KEY-RELATION = SIBLING

*** then COUSIN or NEPHEW

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 2) = PARENT

perform FOUND-COUSIN

else *** found NEPHEW

move PROXIMITY of KEY-PERSON (KEY-INDEX + 1) to

PROXIMITY of KEY-PERSON (KEY-INDEX) move NEPHEW to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) move 1 to GAP-SIZE

perform CONDENSE-KEY-PERSONS

else

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) = SIBLING and

LATER-KEY-RELATION = PARENT

*** then found UNCLE

move GENERATION-GAP of KEY-PERSON (KEY-INDEX + 1) to

GENERATION-GAP of KEY-PERSON (KEY-INDEX) move UNCLE to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) move 1 to GAP-SIZE

perform CONDENSE-KEY-PERSONS.

FOUND-COUSIN.

if GENERATION-GAP of KEY-PERSON (KEY-INDEX)

< GENERATION-GAP of KEY-PERSON (KEY-INDEX + 2)

move GENERATION-GAP of KEY-PERSON (KEY-INDEX)

to COUSIN-RANK of KEY-PERSON (KEY-INDEX)

else

move GENERATION-GAP of KEY-PERSON (KEY-INDEX + 2)

to COUSIN-RANK of KEY-PERSON (KEY-INDEX)

.

*** subtract moves in absolute value since GENERATION-GAP is unsigned

subtract GENERATION-GAP of KEY-PERSON (KEY-INDEX + 2)

from GENERATION-GAP of KEY-PERSON (KEY-INDEX), move PROXIMITY of KEY-PERSON (KEY-INDEX + 1)

to PROXIMITY of KEY-PERSON (KEY-INDEX), move COUSIN to RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX)

.

move 2 to GAP-SIZE,

perform CONDENSE-KEY-PERSONS.

NULL.

exit

.
Page 90

CONDENSE -KEY-PERSONS.

*** CONDENSE -KEY-PERSONS condenses superfluous entries from the *** KEY-PERSON array, starting at KEY-INDEX.

set RECEIVE-INDEX to KEY-INDEX.

set RECEIVE-INDEX up by 1.

set SEND-INDEX to RECEIVE-INDEX.

set SEND-INDEX up by GAP-SIZE.

perform SLIDE -IT-DOWN varying RECEIVE-INDEX from RECEIVE-INDEX by 1 until RELATION-TO-NEXT of KEY-PERSON (RECEIVE-INDEX - 1) = NULL-RELATION.

SLIDE-IT-DOWN.

move KEY-PERSON (SEND-INDEX) to KEY-PERSON (RECEIVE-INDEX).

set SEND-INDEX up by 1.

CONSOLIDATE-ADJACENT-PERSONS.

move RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX) to KEY-RELATION,

set LATER-KEY-INDEX, PRIMARY-INDEX to KEY-INDEX.

if RELATION-TO-NEXT of KEY-PERSON (KEY-INDEX + 1) not = NULL-RELATION

perform SEEK-MULTI -ELEMENT-COMBINATION,

set FIRST-INDEX to KEY-INDEX,

set LAST-INDEX to LATER-KEY-INDEX,

perform DISPLAY-RELATION,

set KEY-INDEX to LATER-KEY-INDEX,

set KEY-INDEX up by 1.

SEEK-MULTI -ELEMENT-COMB I NATION.

move IS-TRUE to ANOTHER-ELEMENT-POSSIBLE,

if KEY-RELATION = SPOUSE

set LATER-KEY-INDEX up by 1 set PRIMARY-INDEX up by 1 if RELATION-TO-NEXT of KEY-PERSON (LATER-KEY-INDEX)

= SIBLING or COUSIN

then nothing can follow spouse-sibling or spouse-cousin

move IS-FALSE to ANOTHER-ELEMENT-POSSIBLE.

PRIMARY-INDEX is now correctly set. Next if-statement

determines if a following SPOUSE relation should be

appended to this combination or left for the next

combination

.

if RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX + 1) = SPOUSE

and ANOTHER-ELEMENT-IS-POSSIBLE

Only a SPOUSE can follow a Primary

check primary preceding and following SPOUSE, move RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX)

to PRIMARY-RELATION

move RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX + 2)

to NEXT-PRIMARY-RELATION

if (NEXT-PRIMARY-RELATION = NEPHEW or COUSIN or NULL-RELATION)

or (PRIMARY -RELATION = NEPHEW)

or ( (PRIMARY-RELATION = SIBLING or PARENT)

and NEXT-PRIMARY-RELATION not = UNCLE ) then append following SPOUSE with this combination,

set LATER-KEY-INDEX up by 1.

***

icifk ***

***

***

***

***

***
Page 91

DISPLAY-RELATION.

*** DISPLAY-RELATION takes 1, 2, or 3 adjacent elements in the *** condensed table and generates the English description of *** the relation between the first and last + 1 elements.

move RELATION-TO-NEXT of KEY-PERSON (FIRST-INDEX)

to FIRST-RELATION,

move RELATION-TO-NEXT of KEY-PERSON (LAST-INDEX)

to LAST-RELATION,

move RELATION-TO-NEXT of KEY-PERSON (PRIMARY-INDEX)

to PRIMARY -RELATION.

*** set THIS -PROXIMITY

if (PRIMARY-RELATION = PARENT and FIRST-RELATION = SPOUSE) or (PRIMARY -RELATION = CHILD and LAST-RELATION = SPOUSE)

move STEP to THIS -PROXIMITY

else

if PRIMARY-RELATION = SIBLING or UNCLE or NEPHEW or COUSIN move PROXIMITY of KEY-PERSON (PRIMARY -INDEX) to THIS -PROXIMITY

else

move FULL to THIS -PROXIMITY.

*** set THIS -GENERATION-GAP

if PRIMARY-RELATION = PARENT or CHILD or UNCLE or NEPHEW or COUSIN

move GENERATION-GAP of KEY-PERSON (PRIMARY-INDEX)

to THIS -GENERATION-GAP

else

move zero to THIS-GENERATION-GAP.

*** set INLAW

if (FIRST-RELATION = SPOUSE) and

(PRIMARY-RELATION = SIBLING or CHILD or NEPHEW or COUSIN)

move IS -TRUE to INLAW

else

if (LAST-RELATION = SPOUSE) and

(PRIMARY-RELATION = SIBLING or PARENT or UNCLE or COUSIN)

move IS -TRUE to INLAW

else

move IS -FALSE to INLAW. *** set THIS-COUSIN-RANK

if PRIMARY-RELATION = COUSIN

move COUSIN-RANK of KEY-PERSON (PRIMARY-INDEX) to THIS-COUSIN-RANK

else

move zero to THIS-COUSIN-RANK.
Page 92

*** parameters are set - now generate display.

set THIS-NODE to PERSON-INDEX of KEY-PERSON (FIRST-INDEX),

move spaces to DISPLAY-BUFFER,

move 1 to DISPLAY-POINTER.

string " ", NAME of PERSON (THIS-NODE), " Is

" delimited by size

Into DISPLAY-BUFFER with pointer DISPLAY-POINTER.

If PRIMARY-RELATION = PARENT or CHILD or UNCLE or NEPHEW

perform GENERATE-GENERATION-QUALIFIER

else

If (PRIMARY-RELATION = COUSIN) and (THIS-COUSIN-RANK > 1) move THIS-COUSIN-RANK to IWO-DIGIT-FIELD

string TWO-DIGIT-FIELD delimited by size into DISPLAY-BUFFER

with pointer DISPLAY-POINTER

divide THIS-COUSIN-RANK by 10 giving TEMP-NUMBER

remainder SUFFIX-INDICATOR

if SUFFIX-INDICATOR = 1 string "st " delimited by size

Into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else if SUFFIX-INDICATOR = 2

string "nd " delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else if SUFFIX-INDICATOR = 3

string "rd " delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else

string "th " delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER.

if THIS-PROXIMITY = STEP

string "step-" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else

if THIS-PROXIMITY = HALF

string "half-" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER.

set THIS-NODE to PERSON-INDEX of KEY-PERSON (FIRST-INDEX),

move GENDER of PERSON (THIS-NODE) to THIS-GENDER.

set MALE-INDEX, FEMALE-INDEX to PRIMARY-RELATION,

if THIS-GENDER = MALE

string PRIMARY-MALE-NAME (MALE-INDEX) delimited by space

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else

string PRIMARY-FEMALE -NAME (FEMALE -INDEX) delimited by space

into DISPLAY-BUFFER with pointer DISPLAY-POINTER.

if RELATION-IS-INLAW

string "-in-law" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER.
Page 93

if (PRIMARY -RELATION = COUSIN) and (THIS-GENERATION-GAP > 0)

if THIS-GENERATION-GAP > 1 move THIS-GENERATION-GAP to TWO-DIGIT-FIELD

string " ", TWO-DIGIT-FIELD, " times removed"

delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else

string " once removed" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER.

string " of" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER,

display DISPLAY-BUFFER.

GENERATE-GENERATION-QUALIFIER.

if THIS-GENERATION-GAP not < 3

string "great" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

if THIS-GENERATION-GAP > 3

subtract 2 from THIS-GENERATION-GAP giving TWO-DIGIT-FIELD

string "*", TWO-DIGIT-FIELD, "-" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER

else

string "-" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER,

if THIS-GENERATION-GAP not < 2 string "grand-" delimited by size

into DISPLAY-BUFFER with pointer DISPLAY-POINTER.

«
Page 94

* Compilation unit number 3 —-

identification division,

program-id. COMGENES.

* COMGENES assumes that each ancestor contributes

* half of the genetic material to a PERSON. It finds common

* ancestors between two PERSONS and computes the expected

* value of the PROPORTION of common material.

environment division.

configuration section,

source-computer. VAX-11.

object-computer. VAX-11.

data division.

working- St orage section.

01 RELATION-TYPE.

05 PARENT pic 9 value 1. 05 CHILD pic 9 value 2.

05 SPOUSE pic 9 value 3.

05 SIBLING pic 9 value 4.

05 UNCLE pic 9 value 5.

05 NEPHEW pic 9 value 6.

05 COUSIN pic 9 value 7.

05 NULL -RELATION pic 9 value 8.

AUXILIARY-VARIABLES.

05 COMMON-PROPORTION

05 MATCH- IDENTIFIER

05 TEN-DIGIT-FIELD

pic 9V9999999999.

pic 999.

pic 9.999999999.

01 STACKED-VARIABLES.

*** used to simulate recursion

05 STACK-ENTRY occurs 50

10 PROPORTION

10 THIS-CONTRIBUTION

10 ALREADY-COUNTED

10 PERSON-INDEX

10 NEXT-NEIGHBOR

times indexed by STACK-INDEX,

pic 9V9999999999.

pic 9V9999999999.

pic 9V9999999999.

usage index,

pic 999.

»
Page 9 5

linkage section.

77 PARM-INDEXl pic 999.

77 PARM-INDEX2 pic 999.

01 PERSON-TABLE.

05 NUMBER-OF -PERSONS usage index.

05 PERSON occurs 300 times indexed by

INDEXl, INDEX2, THIS -NODE.

*** static information - filled from PEOPLE file:

10 NAME pic X(20).

10 IDENTIFIER pic 999.

10 GENDER pic X. *** IDENTIFIERS of immediate relatives - father, mother, spouse

10 IMMEDIATE-RELATIONS.

15 RELATIVE-IDENTIFIER occurs 3 times indexed by RELATIONSHIP

pic 999. *** pointers to immediate neighbors in graph

10 NEIGHBOR-COUNT pic 99.

10 NEIGHBOR-RECORD occurs 20 times indexed by THIS-NEIGHBOR.

15 NEIGHBOR-INDEX usage index.

15 NEIGHBOR-EDGE pic 9. *** data used when traversing graph to resolve user request:

10 DI STANCE -FROM-SOURCE pic 99999V9.

10 PATH-PREDECESSOR usage index.

10 EDGE-TO-PREDECESSOR pic 9.

10 REACHED-STATUS pic 9. *** data used to compute common genetic material

10 DESCENDANT-IDENTIFIER pic 999.

10 DESCENDANT-GENES pic 9V99999999.
Page 96

procedure division using

PARM-INDEXl, PARM-INDEX2, PERSON-TABLE.

MAIN-LINE.

set INDEXl to PARM-INDEXl.

set INDEX2 to PARM-INDEX2.

*** First zero out all ancestors to allow adding. This is necessary

*** because there might be two paths to an ancestor.

set STACK-INDEX to 1.

set PERSON-INDEX (STACK-INDEX) to INDEXl. move zero to NEXT-NEIGHBOR (STACK-INDEX),

perform ZERO-PROPORTION until STACK-INDEX < 1.

*** now mark with shared PROPORTION

move IDENTIFIER of PERSON (INDEXl) to MATCH-IDENTIFIER,

set STACK-INDEX to 1. set PERSON-INDEX (STACK-INDEX) to INDEXl. move zero to NEXT-NEIGHBOR (STACK-INDEX). move 1.0 to PROPORTION (STACK-INDEX).

perform MARK-PROPORTION until STACK-INDEX < 1. *** traverse ancestor tree for INDEX2, summing overlap

*** with marked tree of INDEXl move zero to COMMON-PROPORTION

set STACK-INDEX to 1.

set PERSON-INDEX (STACK-INDEX) to INDEX2. move IDENTIFIER of PERSON (INDEXl) to MATCH-IDENTIFIER.

move zero to NEXT -NEIGHBOR (STACK-INDEX). move 1.0 to PROPORTION (STACK-INDEX). move zero to ALREADY-COUNTED (STACK-INDEX).

perform CHECK-COMMON-PROPORTION until STACK-INDEX < 1.

move COMMON-PROPORTION to TEN-DIGIT-FIELD.

display " Proportion of common genetic material = ", TEN-DIGIT-FIELD.

END-OF-COMGENES.

exit program.

ZERO-PROPORTION.

*** ZERO -PROPORTION recursively seeks out all ancestors and

*** zeros them out

.

set THIS-NODE to PERSON-INDEX (STACK-INDEX),

if NEXT-NEIGHBOR (STACK-INDEX) = zero move zero to DESCENDANT-GENES of PERSON (THIS-NODE) move 1 to NEXT-NEIGHBOR (STACK-INDEX),

perform NULL

varying THIS-NEIGHBOR from NEXT-NEIGHBOR (STACK-INDEX) by 1 until THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE)

or NEIGHBOR-EDGE (THIS-NODE, THIS-NEIGHBOR) = PARENT,

if THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE)

*** then no more ancestors

set STACK-INDEX down by 1 else *** set up for next ancestor

set NEXT-NEIGHBOR (STACK-INDEX) to THIS-NEIGHBOR

add 1 to NEXT-NEIGHBOR (STACK-INDEX)

set STACK-INDEX up by 1 set PERSON-INDEX (STACK-INDEX)

to NEIGHBOR-INDEX (THIS-NODE, THIS-NEIGHBOR)

move zero to NEXT-NEIGHBOR (STACK-INDEX).
MARK-PROPORTION.

*** MARK-PROPORTION recursively seeks out all ancestors and

*** marks them with the sender's PROPORTION of shared

*** genetic material. This PROPORTION is diluted by one-half

*** for each generation.

set THIS-NODE to PERSON-INDEX (STACK-INDEX),

if NEXT-NEIGHBOR (STACK-INDEX) = zero move MATCH-IDENTIFIER

to DESCENDANT-IDENTIFIER of PERSON (THIS-NODE)

add PROPORTION (STACK-INDEX)

to DESCENDANT-GENES of PERSON (THIS-NODE) move 1 to NEXT-NEIGHBOR (STACK-INDEX),

perform NULL

varying THIS-NEIGHBOR from NEXT -NEIGHBOR (STACK-INDEX) by

until THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE)

or NEIGHBOR-EDGE (THIS-NODE, THIS-NEIGHBOR) = PARENT,

if THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) *** then no more ancestors

set STACK-INDEX down by 1 else *** set up for next ancestor

set NEXT -NEIGHBOR (STACK-INDEX) to THIS-NEIGHBOR

add 1 to NEXT-NEIGHBOR (STACK-INDEX)

set STACK-INDEX up by 1 set PERSON-INDEX (STACK-INDEX)

to NEIGHBOR-INDEX (THIS-NODE, THIS-NEIGHBOR)

move zero to NEXT-NEIGHBOR (STACK-INDEX)

divide PROPORTION (STACK-INDEX - 1) by 2 giving

PROPORTION (STACK-INDEX)

.
Page 98

CHECK-COMMON-PROPORTION

.

*** CHECK-COMMON-PROPORTION searches all the ancestors of *** CHECK-INDEX to see if any have been marked, and if so *** adds the appropriate amount to COMMON-PROPORTION.

set THIS-NODE to PERSON-INDEX (STACK-INDEX),

if NEXT -NEIGHBOR (STACK-INDEX) = zero move 1 to NEXT-NEIGHBOR (STACK-INDEX)

if DESCENDANT-IDENTIFIER of PERSON (THIS-NODE) = MATCH-IDENTIFIER

*** Increment COMMON-PROPORTION by the contribution of *** this common ancestor, but discount for the contribution

*** of less remote ancestors already counted.

multiply DESCENDANT-GENES of PERSON (THIS-NODE)

by PROPORTION (STACK-INDEX)

giving THIS-CONTRIBUTION (STACK-INDEX)

compute COMMON-PROPORTION = COMMON-PROPORTION

+ THIS-CONTRIBUTION (STACK-INDEX)

- ALREADY-COUNTED (STACK-INDEX)

else

move zero to THIS-CONTRIBUTION (STACK-INDEX),

perform NULL

varying THIS-NEIGHBOR from NEXT -NEIGHBOR (STACK-INDEX) by 1 until THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE)

or NEIGHBOR-EDGE (THIS-NODE, THIS-NEIGHBOR) = PARENT,

if THIS-NEIGHBOR > NEIGHBOR-COUNT (THIS-NODE) *** then no more ancestors

set STACK-INDEX down by 1 else *** set up for next ancestor

set NEXT-NEIGHBOR (STACK-INDEX) to THIS-NEIGHBOR

add 1 to NEXT-NEIGHBOR (STACK-INDEX)

set STACK-INDEX up by 1 set PERSON-INDEX (STACK-INDEX)

to NEIGHBOR-INDEX (THIS-NODE, THIS-NEIGHBOR)

move zero to NEXT-NEIGHBOR (STACK-INDEX)

divide PROPORTION (STACK-INDEX - 1) by 2 giving

PROPORTION (STACK-INDEX)

divide THIS-CONTRIBUTION (STACK-INDEX - 1) by 4 giving

ALREADY-COUNTED (STACK-INDEX).

NULL.

exit

.
Page 99

6.0 FORTRAN

In keeping with the general convention of the examples, language-supplied

keywords and identifiers are written in lower case in the program. To conform

strictly to the FORTRAN standard, however, programs must use only upper-case

letters

program RELATE

c Establish global constants

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

c Each PERSON'S record in the file identifies at most three

c others directly related: father, mother, and spouse

integer FATHID, MOTHID, SPOUID

parameter (FATHID = 1, MOTHID = 2, SPOUID = 3)

character REQOK*10, REQSTP*A

parameter (REQOK = 'Request OK', REQSTP = 'stop')

character MALE*1, FEMALE*!

parameter (MALE = 'M', FEMALE = 'F')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

c These common blocks hold the PERSON array, which is global to

c the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSC ID
Page 100

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character* 1 GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character*(IDLEN) DSCID (MAXPRS)

real DSC GEN (MAXPRS)

c NUMPER keeps track of the actual number of persons

integer NUMPER

c *** end of declarations for common data ***

c These variables are used when establishing the PERSON array

c from the PEOPLE file.

integer CURRNT, PRVDEX

character*(IDLEN) PREVID, CURRID

integer RELSHP

c These variables are used to accept and resolve requests for

c RELSHP information.

BUFDEX, SEMLOC

REQBUF

PlIDNT, P2IDNT

PIFND, P2FND

ERRMSG

PIDEX, P2DEX

PRNOUN

integer

character*(BUFLEN)

character* (NAMLEN)

integer

character* (MSGLEN)

integer

character*?
Page 101

c *** execution of main sequence begins here ***

open (unit=10, f ile='PEOPLE. DAT' , status='old' , fortn='fonnatted'

)

c This loop reads in the PEOPLE file and constructs the PERSON

c array from it (one PERSON = one record = one array entry),

c As records are read in, links are constructed to represent the

c PARENT-CHILD or SPOUSE relationship. The array then implements

c a directed graph which is used to satisfy subsequent user

c requests. The file is assumed to be correct - no validation

c is performed on it.

do 110 CURRNT=1, MAXPRS

c copy direct information from file to array

read (unit=10, fmt='(a20, a3, al, 3a3)', end=lll)

1 NAME(CURRNT) , IDENT(CURRNT) , GENDER( C URRNT )

,

2 ((RELID(CURRNT,ITEMP), ITEMP=FATHID, SPOUID))

c Location of adjacent persons as yet undetermined

NBRCNT (CURRNT) = 0

c Descendants as yet undetermined

DSCID (CURRNT) = NULLID

c Compare this PERSON against all previously entered PERSONS

c to search for relationships.

CURRID = IDENT (CURRNT)

do 120 PRVDEX = 1, CURRNT -1

PREVI D = IDENT (PRVDEX)

c Search for father, mother, or spouse relationship in

c either direction between this and previous PERSON,

c Assume at most one relationship exists,

do 130 RELSHP = FATHID, SPOUID

if (PREVID .eq. RELID (CURRNT, RELSHP)) then

call LNKREL (CURRNT, RELSHP, PRVDEX)

goto 131

else if (CURRID .eq. RELID (PRVDEX, RELSHP)) then

call LNKREL (PRVDEX, RELSHP, CURRNT)

goto 131

end if

130 continue

131 continue

120 continue

110 continue

111 continue

NUMPER = CURRNT - 1 close (unit=10, status='keep')

PERSON array is now loaded and edges between immediate relatives

(PARENT -CHILD or SPOUSE-SPOUSE) are established.
Page 102

c Loop accepts requests and finds relationship (if any)

c between pairs of PERSONS.

200 continue

call PROMPT (REQBUF)

if (REQBUF .eq. REQSTP) goto 201

call CHKRQS (REQBUF, ERRMSG, PlIDNT, P2IDNT)

c Syntax check of request completed. Now either display error

c message or search for the two PERSONS.

if (ERRMSG .eq. REQOK) then

c Request syntactically correct - search for requested PERSONS

call SEEKPR (PlIDNT, P2IDNT, PIDEX, P2DEX,

1 PIFND, P2FND)

if (PIFND .eq. 1 .and. P2FND .eq. 1) then

c Exactly one match for each PERSON - proceed to c determine relationship, if any.

if (PIDEX .eq. P2DEX) then

if (GENDER (PIDEX) .eq. MALE) then

PRNOUN = 'himself

else

PRNOUN = 'herself

end if

write (unit=*, fmt=9002) NAME (PIDEX), PRNOUN

9002 format (a22, ' is identical to ', a7, '.')

else

call FINDRL (PIDEX, P2DEX)

end if

else

c either not found or more than one found

if (PIFND .eq. 0) then

write (unit=*, fmt='(" First person not found.")')

else if (PIFND .gt. 1) then

write (unit=*,

1 fmt='(" Duplicate names for first person",

2 - use numeric identifier.")')

end if

if (P2FND .eq. 0) then

write (unit=*, fmt='(" Second person not found.")')

else if (P2FND .gt. 1) then

write (unit=*,

1 fmt='(" Duplicate names for second person",

2 " - use numeric identifier.")')

end if

end if c end processing of syntactically legal request

else

write (unit=*, fmt=9004) ERRMSG

9004 format (' Incorrect request format: ', a40)

end if

goto 200

201 continue

write (unit=*, fmt='(" End of relation-finder.")')

c End of main line of RELATE

end
Page 103

c procedures under RELATE

subroutine LNKREL (FRMDEX, RELSHP, TODEX)

c establishes cross-Indexing between Immediately related PERSONS,

integer FRMDEX, TODEX, RELSHP

c Each person's record in the file Identifies at most three

c others directly related: father, mother, and spouse

integer FATHID, MOTHID, SPOUID

parameter (FATHID = 1, MOTHID = 2, SPOUID = 3)

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = A,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

if (RELSHP .eq. SPOUID) then

call LNKONE (FRMDEX, SPOUSE, TODEX)

call LNKONE (TODEX, SPOUSE, FRMDEX)

else

c RELSHP is father or mother

call LNKONE (FRMDEX, PARENT, TODEX)

call LNKONE (TODEX, CHILD, FRMDEX)

end if

end
Page 104

subroutine LNKONE (FRMDEX, THSEDG, TODEX)

c Establishes the NBR pointers from one PERSON to another

integer FRMDEX, TODEX, THSEDG

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

c These common blocks hold the PERSON array, which is global to

c the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSC GEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships.

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*l GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character*(IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

c NUMPER keeps track of the actual number of persons

integer NUMPER

c *** end of declarations for common data ***

ITEMP = NBRCNT (FRMDEX) + 1 NBRCNT (FRMDEX) = ITEMP

NBRDEX (FRMDEX, ITEMP) = TODEX

NBREDG (FRMDEX, ITEMP) = THSEDG

end
subroutine PROMPT (REQBUF)

c Issues prompt for user-request, reads in request,

c blank-fills buffer, and skips to next line of input.

character*(*) REQBUF

write (unit=*, fmt=9001)

9001 format (/,' ' 1 Enter two person- identifiers (name or number),'

2 /,' separated by semicolon. Enter "stop" to stop.')

c *** NOTE THAT THIS IS NOT A STANDARD WAY TO READ A LINE FROM

c *** THE TERMINAL (see section 12.9.5.2.1). THE STANDARD

c *** PROVIDES NO SUCH CAPABILITY.

read (unit=*, fmt='(a60)') REQBUF

end

subroutine CHKRQS (REQBUF, REQST, PlIDNT, P2IDNT)

c Performs syntactic check on request in buffer.

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULL ID* (IDLEN)

parameter (NULLID = '000')

character REQOK*10, REQSTP*4

parameter (REQOK = 'Request OK', REQSTP = 'stop')

character REQBUF* ( BUFLEN ) , REQST*(MSGLEN)

character* (NAMLEN) PlIDNT, P2IDNT, LTRIM

integer SEMLOC

SEMLOC = INDEX (REQBUF,';')

P2IDNT = REQBUF ( SEMLOC+1 : BUFLEN)

set REQST, based on results of scan of REQBUF, and

fill in PlIDNT and P2IDNT.
Page 106

if (SEMLOC .eq. 0 .or. INDEX (P2IDNT, ';') .ne. 0) then

REQST = 'must be exactly one semicolon.'

else

if (SEMLOC .eq. 1) then

PlIDNT = '

' else

PlIDNT = REQBUF (1 : SEMLOC-1)

end if

if (PlIDNT .eq. ' ') then

REQST = 'null field preceding semicolon.'

else if (P2IDNT .eq. ' ') then

REQST = 'null field following semicolon.'

else

REQST = REQOK

PlIDNT = LTRIM (PlIDNT)

P2IDNT = LTRIM (P2IDNT)

end if

end if

end

character* (*) function LTRIM (STRING)

c LTRIM deletes leading spaces and returns the resulting value.

character* (*) STRING

do 100 ITEMP = 1, len( STRING)

if (STRING (ITEMP : ITEMP) .ne. ' ') goto 101

100 continue

101 continue

LTRIM = STRING (ITEMP : len( STRING))

end

subroutine SEEKPR (PlIDNT, P2IDNT, PIDEX, P2DEX,

1 PIFND, P2FND)

c SEEKPR scans through the PERSON array, looking for the two c requested PERSONS. Match may be by NAME or unique IDENT-number

.

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULL ID = '000')

character* (NAMLEN) PlIDNT, P2IDNT

integer PIDEX, P2DEX, PIFND, P2FND

integer CURRNT
Page 107

c These common blocks hold the PERSON array, which is global to

c the entire program.

common /PEBINUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*l GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character*(IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS

)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS

)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

c NUMPER keeps track of the actual number of persons

integer NUMPER

c *** end of declarations for common data ***

PIDEX = 0

P2DEX = 0

PIFND = 0

P2FND = 0

do 100 CURRNT = 1, NUMPER

c allow identification by name or number,

if (PlIDNT .eq. IDENT (CURRNT) .or.

1 PlIDNT .eq. NAME (CURRNT)) then

PIFND = PIFND + 1 PIDEX = CURRNT

end if

if (P2IDNT .eq. IDENT (CURRNT) .or.

1 P2IDNT .eq. NAME (CURRNT)) then

P2FND = P2FND + 1 P2DEX = CURRNT

end if

100 continue

end
Page 108

subroutine FINDRL (TRGDEX, SRCDEX)

c Finds shortest path (if any) between two PERSONS and

c determines their relationship based on immediate relations

c traversed in path. PERSON array simulates a directed graph,

c and algorithm finds shortest path, based on following

c weights: PARENT-CHILD edge = 1.0

c SPOUSE-SPOUSE edge = 1.8

integer TRGDEX, SRCDEX

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

c A node in the graph (= PERSON) has either already been reached,

c is immediately adjacent to those reached, or farther away.

integer REACHD, NEARBY, NOSEEN

parameter (REACHD = 1, NEARBY = 2, NOSEEN = 3)

c These common blocks hold the PERSON array, which is global to

c the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships.

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*l GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character*(IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

c NUMPER keeps track of the actual number of persons

integer NUMPER

c *** end of declarations for common data ***
Page 109

integer PERDEX, THSNOD, ADJNOD,

1 BSTDEX, LASTNR, NEARND (MAXPRS)

integer THSEDG, THSNBR

integer RELSHP

real HINDIS

integer SRCHNG, SUCCES, FAILED

parameter (SRCHNG = 1, SUCCES = 2, FAILED = 3)

integer SRCHST

c begin execution of FINDRL

c initialize PERSON-array for processing -

c mark all nodes as not seen

do 100 PERDEX = 1, NUMPER

RCHST (PERDEX) = NOSEEN

100 continue

THSNOD = SRCDEX

c mark source node as reached

RCHST (THSNOD) = REACHD

DSTSRC (THSNOD) =0.0

c no NEARBY nodes exist yet

LASTNR = 0

if (THSNOD .eq. TRGDEX) then

SRCHST = SUCCES

else

SRCHST = SRCHNG

end if
Page 110

c Loop keeps processing closest-to-source , unreached node

c until target reached, or no more connected nodes.

200 continue

if (SRCHST .ne. SRCHNG) goto 201

c Process all nodes adjacent to THSNOD

do 210 THSNBR = 1, NBRCNT (THSNOD)

call PROCAD (THSNOD, NBRDEX (THSNOD, THSNBR),

1 NBREDG (THSNOD, THSNBR), NEARND, LASTNR)

210 continue

c All nodes adjacent to THSNOD are set. Now search for

c shortest-distance unreached (but NEARBY) node to process next.

if (LASTNR .eq. 0) then

SRCHST = FAILED

else

c determine next node to process

HINDIS = l.OE+18

do 220 PERDEX = 1, LASTNR

if (DSTSRC (NEARND (PERDEX)) .It. HINDIS) then

BSTDEX = PERDEX

HINDIS = DSTSRC (NEARND (PERDEX))

end if

220 continue

c establish new THSNOD

THSNOD = NEARND (BSTDEX)

c change THSNOD from being NEARBY to reached

RCHST (THSNOD) = REACHD

c remove THSNOD from NEARBY list

NEARND (BSTDEX) = NEARND (LASTNR)

LASTNR = LASTNR - 1 if (THSNOD .eq. TRGDEX) SRCHST = SUCCES

end if

goto 200

201 continue

c Shortest path between PERSONS now established. Next task is

c to translate path to English description of relationship.

if (SRCHST .eq. FAILED) then

write (unit=*, fmt=9001) NAHE (TRGDEX), NAME (SRCDEX)

9001 format (a22, ' is not related to a20)

else

c success - parse path to find and display relationship

call RESOLV (SRCDEX, TRGDEX)

c compute proportion of common genetic material

call CHPTGN (SRCDEX, TRGDEX)

end if

end
Page 111

c procedures under FINDRL

subroutine PROCAD (BASNOD, NXTNOD, NBEDGE, NEARND, LASTNR)

c NXTNOD is adjacent to last-reached node (= BASNOD).

c If NXTNOD already reached, do nothing,

c If previously seen, check whether path thru BASNOD is

c shorter than current path to NXTNOD, and if so re-link

c next to base

.

c If not previously seen, link next to base node.

integer NXTNOD, BASNOD, NEARND(*), LASTNR

integer NBEDGE

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

c A node in the graph (— PERSON) has either already been reached,

c is immediately adjacent to those reached, or farther away.

integer REACHD, NEARBY, NOSEEN

parameter (REACHD = 1, NEARBY = 2, NOSEEN = 3)

c These common blocks hold the PERSON array, which is global to

c the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSC GEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships,

static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character*(IDLEN) IDENT (MAXPRS)

character*l GENDER (MAXPRS)

IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

data used when traversing graph to resolve user request

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

data used to compute common genetic material

character*(IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)
Page 112

c NUMPER keeps track of the actual number of persons

Integer NUMPER

c *** end of declarations for common data ***

real WGHTEG, DSTBAS

c begin execution of PROCAD

if (RCHST (NXTNOD) .ne. REACHD) then

if (NBEDGE .eq. SPOUSE) then

WGHTEG = 1.8

else

WGHTEG =1.0

end if

DSTBAS = WGHTEG + DSTSRC (BASNOD)

7 if (RCHST (NXTNOD) .eq. NOSEEN) then

c change status of THSNOD from not-seen to NEARBY

RCHST (NXTNOD) = NEARBY

LASTNR = LASTNR + 1 NEARND (LASTNR) = NXTNOD

c link next to base by re-setting its predecessor index to c point to base, note type of edge, and re-set distance

c as it is through base node.

DSTSRC (NXTNOD) = DSTBAS

PATHPR (NXTNOD) = BASNOD

EDGPRD (NXTNOD) = NBEDGE

else

c RCHST is NEARBY

if (DSTBAS .It. DSTSRC (NXTNOD)) then

c link next to base by re-setting its predecessor index

c point to base, note type of edge, and re-set distance

c as it is through base node.

DSTSRC (NXTNOD) = DSTBAS

PATHPR (NXTNOD) = BASNOD

EDGPRD (NXTNOD) = NBEDGE

end if

end if

end if

end
subroutine RESOLV (SRCDEX, TRGDEX)

RESOLV condenses the shortest path to a series of

relationships for which there are English descriptions.

integer SRCDEX, TRGDEX

Establish global constants

integer MAXPRS, NA.MLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN =

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*(IDLEN)

parameter (NULLID = '000')

character MALE*1, FEMALE*1

parameter (MALE = 'M', FEMALE = 'F')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = A,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

sibling proximity can have three values

integer STEP, HALF, FULL

parameter (STEP = 1, HALF = 2, FULL = 3)

These common blocks hold the PERSON array, which is global t the entire program.

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID
Page 114

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character*(IDLEN) IDENT (MAXPRS)

character*l GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character*(IDLEN) DSCID (MAXPRS)

real DSC GEN (MAXPRS)

c NUMPER keeps track of the actual number of persons

integer NUMPER

c *** end of declarations for common data ***

c these variables are used to generate key-person data

integer GENCNT, THSCUZ

integer THSPRX

c these variables are used to condense the path

common /KEYPER/ RELNXT, PERDEX, GENGAP, PRXMTY, CUZRNK

c Key persons are the ones in the relationship path which

c after the path is condensed.

integer RELNXT (MAXPRS)

integer PERDEX (MAXPRS)

integer GENGAP (MAXPRS)

integer PRXMTY (MAXPRS)

integer CUZRNK (MAXPRS)

integer KEYREL, LATREL, PRIREL, NXTPRI

integer KEYDEX, LATDEX, PRIDE X, THSNOD

integer GAPl, GAP2

logical SEEKMR, FULSIB
Page 115

c begin execution of RESOLV

write (unit=*,

1 fmt='(" Shortest path between identified persons: ")')

c Display path and initialize key person arrays from path elements.

THSNOD = TRGDEX

do 100 KEYDEX = 1, MAXPRS

if (THSNOD .eq. SRCDEX) goto 101

PERDEX (KEYDEX) = THSNOD

PRXMTY (KEYDEX) = FULL

RELNXT (KEYDEX) = EDGPRD (THSNOD)

if (EDGPRD (THSNOD) .eq. SPOUSE) then

write (unit=*, fmt='(a22, " is spouse of")') NAME (THSNOD)

GENGAP (KEYDEX) = 0

else

GENGAP (KEYDEX) = 1 if (EDGPRD (THSNOD) .eq. PARENT) then

write (unit=*, fmt='(a22, " is parent of")')

1 NAME (THSNOD)

else

write (unit=*, fmt='(a22, " is child of")')

1 NAME (THSNOD)

end if

end if

THSNOD = PATHPR (THSNOD)

100 continue

101 continue

write (unit=*, fmt='(a22)') NAME (THSNOD)

PERDEX (KEYDEX) = THSNOD

RELNXT (KEYDEX) = NULLRL

RELNXT (KEYDEX + 1) = NULLRL
Page 116

c resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations

c to SIBLNG relations.

do 200 KEYDEX = 1, MAXPRS

If (RELNXT (KEYDEX) .eq. NULLRL) goto 201

if (RELNXT (KEYDEX) .eq. CHILD) then

LATREL = RELNXT (KEYDEX + 1)

if (LATREL .eq. PARENT) then

c found either full or half SIBLNGs

if (FULSIB (PERDEX (KEYDEX), PERDEX (KEYDEX + 2))) then

PRXMTY (KEYDEX) = FULL

else

PRXMTY (KEYDEX) = HALF

end if

GENGAP (KEYDEX) = 0

RELNXT (KEYDEX) = SIBLNG

call CONDNS (KEYDEX, 1)

else if (LATREL .eq. SPOUSE .and.

1 RELNXT (KEYDEX + 2) .eq. PARENT) then

c found step-SIBLNGs

GENGAP (KEYDEX) = 0

PRXMTY (KEYDEX) = STEP

RELNXT (KEYDEX) = SIBLNG

call CONDNS (KEYDEX, 2)

end if

end if

200 continue

201 continue

c resolve CHILD-CHILD-. . . and PARENT-PARENT-. . . relations to

c direct descendant or ancestor relations,

do 300 KEYDEX = 1, MAXPRS

if (RELNXT (KEYDEX) .eq. NULLRL) goto 301

if (RELNXT (KEYDEX) .eq. CHILD .or.

1 RELNXT (KEYDEX) .eq. PARENT) then

do 310 LATDEX = KEYDEX + 1, MAXPRS

if (RELNXT (LATDEX) .ne. RELNXT (KEYDEX)) goto 311

310 continue

311 continue

GENCNT = LATDEX - KEYDEX

if (GENCNT .gt. 1) then

c compress generations

GENGAP (KEYDEX) = GENCNT

call CONDNS (KEYDEX, GENCNT - 1)

end if

end if

300 continue

301 cont inue
Page 117

c resolve CHILD-SIBLNG-PARENT to COUSIN,

c CHILD-SIBLNG to NEPHEW,

C SIBLNG-PARENT to UNCLE,

do 400 KEYDEX = 1, MAXPRS

if (RELNXT (KEYDEX) .eq. NULLRL) goto AOl

LATREL = RELNXT (KEYDEX + 1)

if (RELNXT (KEYDEX) .eq. CHILD .and. LATREL .eq. SIBLNG) then

c found COUSIN or NEPHEW

PRXMTY (KEYDEX) = PRXMTY (KEYDEX + 1)

if (RELNXT (KEYDEX + 2) .eq. PARENT) then

c found COUSIN

GAPl = GENGAP (KEYDEX)

GAP2 = GENGAP (KEYDEX + 2)

GENGAP (KEYDEX) = abs (GAPl - GAP2)

CUZRNK (KEYDEX) = mln (GAPl, GAP2)

RELNXT (KEYDEX) = COUSIN

call CONDNS (KEYDEX, 2)

else

c found NEPHEW

RELNXT (KEYDEX) = NEPHEW

call CONDNS (KEYDEX, 1)

end if

else

if (RELNXT (KEYDEX) .eq. SIBLNG .and.

1 LATREL .eq. PARENT) then

c found UNCLE

GENGAP (KEYDEX) = GENGAP (KEYDEX + 1)

RELNXT (KEYDEX) = UNCLE

call CONDNS (KEYDEX, 1)

end if

end if

AGO continue

401 continue
Page 118

c Loop below will pick out valid adjacent strings of elements

c to be displayed. KEYDEX points to first element,

c LATDEX to last element, and PRIDEX to the

c element which determines the primary English word to be used,

c Associativity of adjacent elements in condensed table

c is based on English usage.

KEYDEX = 1 write (unit=*, fmt='(" Condensed path:")')

500 continue

if (RELNXT (KEYDEX) .eq. NULLRL) goto 501

KEYREL = RELNXT (KEYDEX)

LATDEX = KEYDEX

PRIDEX = KEYDEX

if (RELNXT (KEYDEX + 1) .ne. NULLRL) then

c . seek multi-element combination

SEEKMR = .true,

if (KEYREL .eq. SPOUSE) then

LATDEX = LATDEX + 1 PRIDEX = LATDEX

c Nothing can follow SPOUSE-SIBLNG or SPOUSE-COUSIN

SEEKMR = .not. (RELNXT (LATDEX) .eq. SIBLNG .or.

1 RELNXT (LATDEX) .eq. COUSIN)

end if

c PRIDEX is now correctly set. Next if-statement

c determines if a following SPOUSE relation should be

c appended to this combination or left for the next

c combination.

if (SEEKMR .and. RELNXT (PRIDEX + 1) .eq. SPOUSE) then

c Only a SPOUSE can follow a Primary.

C Check primary preceding and following SPOUSE.

PRIREL = RELNXT (PRIDEX)

NXTPRI = RELNXT (PRIDEX + 2)

if ((NXTPRI .eq. NEPHEW .or.

1 NXTPRI .eq. COUSIN .or.

2 NXTPRI .eq. NULLRL)

3 .or. (PRIREL .eq. NEPHEW)

4 .or. ((PRIREL .eq. SIBLNG .or. PRIREL .eq. PARENT)

5 .and. NXTPRI .ne. UNCLE )) then

c append following SPOUSE with this combination.

LATDEX = LATDEX + 1 end if

end if

end if

c end multi-element combination

call SHOWRE (KEYDEX, LATDEX, PRIDEX)

KEYDEX = LATDEX + 1 goto 500

501 continue

write (unit=*, fmt='(a22)') NAME (PERDEX (KEYDEX))

end

c end of RESOLV
logical function FULSIB (INDEXl, INDEX2)

Determines whether two PERSONS are full siblings, i.e.,

have the same two parents

.

integer INDEXl, INDEX2

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN

1 MSGLEN = 40, MAXNBR = 20, MAXGVN

character NULL1D*( IDLEN)

parameter (NULLID = '000')

integer FATHID, MOTHID, SPOUID

parameter (FATHID = 1, MOTHID = 2, SPOUID = 3)

3, BUFLEN = 60,

3)

These common blocks hold the PERSON array, which is global to

the entire program.

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID

The following data items constitute the PERSON array, which

is the central repository of information about inter-relationships

static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*! GENDER (MAXPRS)

IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer - EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

NUMPER keeps track of the actual number of persons

integer ^ NUMPER

*** end of declarations for common data ***

FULSIB =

1 RELID (INDEXl, FATHID) .ne. NULLID .and.

2 RELID (INDEXl, MOTHID) .ne. NULLID .and.

3 RELID (INDEXl, FATHID) .eq. RELID (INDEX2, FATHID) .and.

4 RELID (INDEXl, MOTHID) .eq. RELID (INDEX2, MOTHID)

end
Page 120

subroutine CONDNS (ATDEX, GAPSIZ)

c CONDNS condenses superfluous entries from the

c key person arrays, starting at ATDEX.

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

common /KEYPER/ RELNXT, PERDEX, GENGAP, PRXMTY, CUZRNK

c Key persons are the ones in the relationship path which remain

c after the path is condensed.

integer RELNXT (MAXPRS)

integer PERDEX (MAXPRS)

integer GENGAP (MAXPRS)

integer PRXMTY (MAXPRS)

integer CUZRNK (MAXPRS)

integer ATDEX, GAPSIZ, SENDEX, RCVDEX

RCVDEX = ATDEX

100 continue

RCVDEX = RCVDEX + 1 SENDEX = RCVDEX + GAPSIZ

RELNXT (RCVDEX) = RELNXT (SENDEX)

PERDEX (RCVDEX) = PERDEX (SENDEX)

GENGAP (RCVDEX) = GENGAP (SENDEX)

PRXMTY (RCVDEX) = PRXMTY (SENDEX)

CUZRNK (RCVDEX) = CUZRNK (SENDEX)

if (RELNXT (SENDEX) .ne. NULLRL) goto 100

end
c procedures under RESOLV

subroutine SHOWRE (FSTDEX, LSTDEX, PRIDEX)

c SHOWRE takes 1, 2, or 3 adjacent elements In the

c condensed table and generates the English description of

c the relation between the first and last + 1 elements.

c Establish global constants

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

character MALE*1, FEMALE*!

parameter (MALE = 'M' , FEMALE = 'F')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

c sibling proximity can have three values

integer STEP, HALF, FULL

parameter (STEP = 1, HALF = 2, FULL = 3)

c These common blocks hold the PERSON array, which is global to

c the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSC GEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID
Page 122

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*! GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSC GEN (MAXPRS)

c NUMPER keeps track of the actual number of persons

integer NUMPER

common /KEYPER/ RELNXT, PERDEX, GENGAP, PRXMTY, CUZRNK

c Key persons are the ones in the relationship path which remain

c after the path is condensed.

integer

integer

integer

integer

integer

RELNXT (MAXPRS)

PERDEX (MAXPRS)

GENGAP (MAXPRS)

PRXMTY (MAXPRS)

CUZRNK (MAXPRS)

c *** end of declarations for common data ***

logical

integer

character

integer

character

integer

integer

character*75

integer

INLAW

THSPRX, THSGAP, THSCUZ

TW0DIG*2

SUFPTR

SUFCHR*12

FSTDEX, LSTDEX, PRIDEX

FSTREL, LSTREL, PRIREL

OUTBUF

OUTPTR
begin execution of SHOWRE

FSTREL = RELNXT (FSTDEX)

LSTREL = RELNXT (LSTDEX)

PRIREL = RELNXT (PRIDEX)

set THSPRX

if ((PRIREL .eq. PARENT .and. FSTREL .eq. SPOUSE) .or.

1 (PRIREL .eq. CHILD .and. LSTREL .eq. SPOUSE)) then

THSPRX = STEP

else

if (PRIREL .eq. SIBLNG .or. PRIREL .eq. UNCLE .or.

1 PRIREL .eq. NEPHEW .or. PRIREL .eq. COUSIN) then

THSPRX = PRXMTY (PRIDEX)

else

THSPRX = FULL

end if

end if

set THSGAP

if (PRIREL .eq. PARENT .or. PRIREL .eq. CHILD .or.

1 PRIREL .eq. UNCLE .or. PRIREL .eq. NEPHEW .or.

2 PRIREL .eq. COUSIN) then

THSGAP = GENGAP (PRIDEX)

else

THSGAP = 0

end if

set INLAW

if (FSTREL .eq. SPOUSE .and.

1 (PRIREL .eq. SIBLNG .or. PRIREL .eq. CHILD .or.

2 PRIREL .eq. NEPHEW .or. PRIREL .eq. COUSIN)) then

INLAW = .true.

else

if (LSTREL .eq. SPOUSE .and.

1 (PRIREL .eq. SIBLNG .or. PRIREL .eq. PARENT .or.

2 PRIREL .eq. UNCLE .or. PRIREL .eq. COUSIN)) then

INLAW = .true.

else

INLAW = .false,

end if

end if

set THSCUZ

if (PRIREL .eq. COUSIN) then

THSCUZ = CUZRNK (PRIDEX)

else

THSCUZ = 0

end if
Page 124

c parameters are set - now generate display.

OUTBUF = NAME (PERDEX (FSTDEX)) // ' is ' OUTPTR = NAMLEN + 5 if (PRIREL .eq. PARENT .or. PRIREL .eq. CHILD .or.

1 PRIREL .eq. UNCLE .or. PRIREL .eq. NEPHEW) then

c display generation-qualifier

if (THSGAP .ge. 3) then

call APPEND (OUTBUF, OUTPTR, 'great')

if (THSGAP .gt. 3) then

write (unit=TWODIG, fmt='(i2)') THSGAP - 2

call APPEND (OUTBUF, OUTPTR, '*' // TWODIG)

end if

call APPEND (OUTBUF, OUTPTR, '-')

end if

if (THSGAP .ge. 2) then

call APPEND (OUTBUF, OUTPTR, 'grand-')

end if

else

if (PRIREL .eq. COUSIN .and. THSCUZ .gt. I) then

c display cousin-degree

write (unit=TWODIG, fmt='(i2)') THSCUZ

call APPEND (OUTBUF, OUTPTR, TWODIG)

SUFPTR = mod (THSCUZ, 10)

if (SUFPTR .gt. 3) SUFPTR = 0

SUFPTR = 3 * SUFPTR + 1 SUFCHR = 'th St nd rd ' call APPEND (OUTBUF, OUTPTR, SUFCHR (SUFPTR : SUFPTR +2))

end if

end if

if (THSPRX .eq. STEP) then

call APPEND (OUTBUF, OUTPTR, 'step-')

else

if (THSPRX .eq. HALF) then

call APPEND (OUTBUF, OUTPTR, 'half-')

end if

end if
Page 125

if (GENDER (PERDEX (FSTDEX)) .eq. MALE) then

goto (201,202,203,204,205,206,297,298), PRIREL

201 continue

call APPEND (OUTBUF, OUTPTR, 'father')

goto 300

202 continue

call APPEND (OUTBUF, OUTPTR, 'son')

goto 300

203 continue

call APPEND (OUTBUF, OUTPTR, 'husband')

goto 300

204 continue

call APPEND (OUTBUF, OUTPTR, 'brother')

goto 300

205 continue

call APPEND (OUTBUF, OUTPTR, 'uncle')

goto 300

206 continue

call APPEND (OUTBUF, OUTPTR, 'nephew')

goto 300

else

c gender is FEMALE

goto (251,252,253,254,255,256,297,298), PRIREL

251 continue

call APPEND (OUTBUF, OUTPTR, 'mother')

goto 300

252 continue

call APPEND (OUTBUF, OUTPTR, 'daughter')

goto 300

253 continue

call APPEND (OUTBUF, OUTPTR, 'wife')

goto 300

254 continue

call APPEND (OUTBUF, OUTPTR, 'sister')

goto 300

255 continue

call APPEND (OUTBUF, OUTPTR, 'aunt')

goto 300

256 continue

call APPEND (OUTBUF, OUTPTR, 'niece')

goto 300

end if

297 continue

call APPEND (OUTBUF, OUTPTR, 'cousin')

goto 300

298 continue

call APPEND (OUTBUF, OUTPTR, 'null')

goto 300

300 continue
Page 126

if (INLAW) call APPEND (OUTBUF, OUTPTR, '-in-law')

if (PRIREL .eq. COUSIN .and. THSGAP .gt. 0) then

if (THSGAP .gt. 1) then

write (unit=TWODIG, fmt='(i2)') THSGAP

call APPEND (OUTBUF, OUTPTR, ' '//TWODIG//' times removed')

else

call APPEND (OUTBUF, OUTPTR, ' once removed')

end if

end if

call APPEND (OUTBUF, OUTPTR, 'of')

write (unit=*, fmt='(a77)') OUTBUF

end

subroutine APPEND (STRING, PTR, ADDEND)

c APPEND appends the contents of ADDEND to STRING in the position

c indicated by PTR, and increments PTR

character STRING*(*), ADDEND*(*)

integer PTR, ADDLEN

ADDLEN = len (ADDEND)

STRING (PTR : PTR + ADDLEN - 1) = ADDEND

PTR = PTR + ADDLEN

end

c procedures under FINDRL

subroutine CMPTGN (INDEXl, INDEX2)

c CMPTGN assumes that each ancestor contributes

c half of the genetic material to a PERSON. It finds common

c ancestors between two PERSONS and computes the expected

c value of the proportion of common material.

integer INDEXl, INDEX2

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN

1 MSGLEN = AO, MAXNBR = 20, MAXGVN

character NULLID*( IDLEN)

parameter (NULLID = '000')

c These common blocks hold the PERSON array, which is global to

2 the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSC ID

= 3, BUFLEN = 60, = 3)
Page 127

c The following data items constitute the PERSON array, which

c is the central repository of information about inter-relationships

c static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character*(IDLEN) IDENT (MAXPRS)

character*! GENDER (MAXPRS)

c IDENTs of immediate relatives - father, mother, spouse

character*(IDLEN) RELID (MAXPRS, MAXGVN)

c pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

c data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

c data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

c NUMPER keeps track, of the actual number of persons

integer NUMPER

c STACK is common to the routines which calculate genetic overlap,

c It is used to implement recursive traversal of the ancestor trees.

integer STKSIZ

parameter (STKSIZ =50)

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR,

1 STKPTR

real PROPTN (STKSIZ)

real CONTRB (STKSIZ)

real COUNTD (STKSIZ)

integer PERDEX (STKSIZ)

integer NXTNBR (STKSIZ)

integer STKPTR

c *** end of declarations for common data ***

real CCMPRP
Page 128

c First zero out all ancestors to allow adding. This is necessary

c because there might be two paths to an ancestor.

STKPTR = 1 PERDEX (STKPTR) = INDEXl

NXTNBR (STKPTR) = 0

100 continue

call ZERPRO

if (STKPTR .ge. 1) goto 100

101 continue

c now mark with shared PROPTN

STKPTR =1 . PERDEX (STKPTR) = INDEXl

NXTNBR (STKPTR) = 0

PROPTN (STKPTR) =1.0

200 continue

call MRKPRO (IDENT (INDEXl))

if (STKPTR .ge. 1) goto 200

201 continue

c traverse ancestor tree for INDEX2. summing overlap with

c marked tree of INDEXl

COMPRP =0.0

STKPTR = 1 PERDEX (STKPTR) = INDEX2

NXTNBR (STKPTR) = 0

PROPTN (STKPTR) =1.0

COUNTD (STKPTR) =0.0

300 continue

call CHKCOM (COMPRP, IDENT (INDEXl))

if (STKPTR .ge. 1) goto 300

301 continue

write (unit=*, fmt=9001) COMPRP

9001 formate Proportion of common genetic material = Ip, el2.5e2)

end

subroutine ZERPRO

c ZERPRO recursively seeks out all ancestors and

c zeros them out

.

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN =60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)
These conmon blocks hold the PERSON array, which is global to

the entire program.

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID

The following data items constitute the PERSON array, which

is the central repository of information about inter-relationship;

static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*l GENDER (MAXPRS)

IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

Integer NBREDG (MAXPRS, MAXNBR)

data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS) , data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

NUMPER keeps track of the actual number of persons

integer NUMPER

STACK is common to the routines which calculate genetic overlap.

It is used to implement recursive traversal of the ancestor trees

integer STKSIZ

parameter (STKSIZ = 50)

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR,

1 STKPTR

real

real

real

integer

integer

integer

PROPTN

CONTRB

COUNTD

PERDEX

NXTNBR

STKPTR

(STKSIZ)

(STKSIZ)

(STKSIZ)

(STKSIZ)

(STKSIZ)

*** end of declarations for common data
Page 130

integer ZERDEX, THSNBR

ZERDEX = PERDEX (STKPTR)

if (NXTNBR (STKPTR) .eq. 0) then

DSCGEN (ZERDEX) = 0.0

NXTNBR (STKPTR) = 1 end if

do 100 THSNBR = NXTNBR (STKPTR), NBRCNT (ZERDEX)

if (NBREDG (ZERDEX, THSNBR) .eq. PARENT) goto 101

100 continue

101 continue

if (THSNBR .gt. NBRCNT (ZERDEX)) then

c no more ancestors from this person

STKPTR = STKPTR - 1 else

c set up for next ancestor

NXTNBR (STKPTR) = THSNBR + 1 STKPTR = STKPTR + 1 PERDEX (STKPTR) = NBRDEX (ZERDEX, THSNBR)

NXTNBR (STKPTR) = 0

end if

end

subroutine MRKPRO (MARKER)

c MRKPRO recursively seeks out all ancestors and

c marks them with the sender's proportion of shared

c genetic material. This proportion is diluted by one-half

c for each generation.

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MS GLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN

1 MS GLEN = 40, MAXNBR = 20, MAXGVN

3, BUFLEN

3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

c These common blocks hold the PERSON array, which is global to

c the entire program. common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DST3RC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID
The following data items constitute the PERSON array, which

is the central repository of information about inter-relationship

static information - filled

character* (NAMLEN)

character* (IDLEN)

character*!

from PEOPLE file

NAME (MAXPRS

)

IDENT (MAXPRS)

GENDER (MAXPRS)

IDENTs of immediate relatives - father, mother

character*(IDLEN) RELID (MAXPRS,

pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

Integer NBRDEX (MAXPRS,

integer NBREDG (MAXPRS,

spouse

MAXGVN)

MAXNBR)

MAXNBR)

data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

data used to compute common genetic material

character* (IDLEN) DSCID (MAXPRS)

real DSCGEN (MAXPRS)

NUMPER keeps track of the actual number of persons

integer NUMPER

STACK is common to the routines which calculate genetic overlap.

It is used to implement recursive traversal of the ancestor trees

integer STKSIZ

parameter (STKSIZ = 50)

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR,

1 STKPTR

real

real

real

integer

integer

integer

PROPTN

CONTRB

COUNTD

PERDEX

NXTNBR

STKPTR

(STKSIZ)

(STKSIZ)

(STKSIZ)

(STKSIZ)

(STKSIZ)

*** end of declarations for common data ***

character* (IDLEN) MARKER

integer MRKDEX, THSNBR
Page 132

MRKDEX = PERDEX (STKPTR)

if (NXTNBR (STKPTR) .eq. 0) then

DSCID (MRKDEX) = MARKER

DSCGEN (MRKDEX) = DSCGEN (MRKDEX) + PROPTN (STKPTR)

NXTNBR (STKPTR) =1

end if

do 100 THSNBR = NXTNBR (STKPTR), NBRCNT (MRKDEX)

if (NBREDG (MRKDEX, THSNBR) .eq. PARENT) goto 101

100 continue

101 continue

if (THSNBR .gt. NBRCNT (MRKDEX)) then

c no more ancestors from this person

STKPTR = STKPTR - 1 else

c set up for next ancestor

NXTNBR (STKPTR) = THSNBR + 1 STKPTR = STKPTR + 1 PERDEX (STKPTR) = NBRDEX (MRKDEX, THSNBR)

NXTNBR (STKPTR) =0

PROPTN (STKPTR) = PROPTN (STKPTR - 1) / 2.0

end if

end

subroutine CHKCOM (COMPRP, MTCHID)

C CHKCOM searches all the ancestors of CHKDEX to see if any have

c been marked, and if so adds the appropriate amount to COMPRP.

integer MAXPRS, NAMLEN, IDLEN, BUFLEN,

1 MSGLEN, MAXNBR, MAXGVN

parameter (MAXPRS = 300, NAMLEN = 20, IDLEN = 3, BUFLEN = 60,

1 MSGLEN = 40, MAXNBR = 20, MAXGVN = 3)

character NULLID*( IDLEN)

parameter (NULLID = '000')

integer PARENT, CHILD, SPOUSE, SIBLNG,

1 UNCLE, NEPHEW, COUSIN, NULLRL

parameter (PARENT = 1, CHILD = 2, SPOUSE = 3, SIBLNG = 4,

1 UNCLE = 5, NEPHEW = 6, COUSIN = 7, NULLRL = 8)

c These common blocks hold the PERSON array, which is global to

c the entire program.

common /PERNUM/ NBRCNT, NBRDEX, NBREDG, DSTSRC, PATHPR,

1 EDGPRD, RCHST, DSCGEN, NUMPER

common /PERCHR/ NAME, IDENT, GENDER, RELID, DSCID
The following data items constitute the PERSON array, which

is the central repository of information about inter-relationships

static information - filled from PEOPLE file

character* (NAMLEN) NAME (MAXPRS)

character* (IDLEN) IDENT (MAXPRS)

character*! GENDER (MAXPRS)

IDENTs of immediate relatives - father, mother, spouse

character* (IDLEN) RELID (MAXPRS, MAXGVN)

pointers to immediate neighbors in graph

integer NBRCNT (MAXPRS)

integer NBRDEX (MAXPRS, MAXNBR)

integer NBREDG (MAXPRS, MAXNBR)

data used when traversing graph to resolve user request:

real DSTSRC (MAXPRS)

integer PATHPR (MAXPRS)

integer EDGPRD (MAXPRS)

integer RCHST (MAXPRS)

data used to compute common genetic material

character* (IDLEN) DSC ID (MAXPRS)

real DSCGEN (MAXPRS)

NUMPER keeps track of the actual number of persons

integer NUMPER

STACK is common to the routines which calculate genetic overlap.

It is used to implement recursive traversal of the ancestor trees

integer STKSIZ

parameter (STKSIZ = 50)

common /STACK/ PROPTN, CONTRB, COUNTD, PERDEX, NXTNBR,

1 STKPTR

real PROPTN (STKSIZ)

real CONTRB (STKSIZ)

real COUNTD (STKSIZ)

integer PERDEX (STKSIZ)

integer NXTNBR (STKSIZ)

integer STKPTR

*** end of declarations for common data ***

real COMPRP

character* (IDLEN) MTCHID

integer CHKDEX
Page 134

CHKDEX = PERDEX (STKPTR)

if (NXTNBR (STKPTR) .eq. 0) then

NXTNBR (STKPTR) = 1 if (DSCID (CHKDEX) .eq. MTCHID) then

c Increment COMPRP by the contribution of this

c common ancestor, but discount for the contribution

c of less remote ancestors already counted.

CONTRB (STKPTR) = DSCGEN (CHKDEX) * PROPTN (STKPTR)

COMPRP = COMPRP + CONTRB (STKPTR) - COUNTD (STKPTR)

else

CONTRB (STKPTR) =0.0

end if

end if

do 100 THSNBR = NXTNBR (STKPTR), NBRCNT (CHKDEX)

if (NBREDG (CHKDEX, THSNBR) .eq. PARENT) goto 101

100 continue

101 continue

if (THSNBR .gt. NBRCNT (CHKDEX)) then

c no more ancestors from this person

STKPTR = STKPTR - 1 else

c set up for next ancestor

NXTNBR (STKPTR) = THSNBR + 1 STKPTR = STKPTR + 1 PERDEX (STKPTR) = NBRDEX (CHKDEX, THSNBR)

NXTNBR (STKPTR) = 0

PROPTN (STKPTR) = PROPTN (STKPTR - 1) / 2.0

COUNTD (STKPTR) = CONTRB (STKPTR - 1) / A.O

end if

end
Page 135

7.0 PASCAL

User-defined identifiers are written in mixed upper and lower case, rather than

all upper-case, because Pascal provides no separator character, such as "-" or "_" for identifiers. Therefore, upper-case letters are used for readability,

e.g., EdgeToPredecessor is used in Pascal where EDGE_TO_PREDECESSOR is used in

most of the other languages.

program Relate (input, output, People);

const

MaxPersons = 300;

Name Length = 20;

{ every Person has a unique 3-digit Identifier }

Identifier Length = 3;

BufferLength = 60;

RequestOk = 'Request OK

RequestToStop

'stop

type

IdentifierRange

Buf f erRange

NameRange

Dig it Type

NameType

BufferType

MessageType

IdentifierType

{ each Person's re others directly

Givenldentif iers

RelativeArray

Counter

= 1. . Identif ierLength;

= 1 .. Buf fer Length

;

= 1. .NameLength;

= '0'..'9';

= packed array [NameRange] of char;

= packed array [Buf f erRange] of char;

= packed array [1..40] of char;

= array [ Identif ierRange] of DigitType;

cord in the file identifies at most three

related: father, mother, and spouse } = (Father Ident , Motherldent, Spouseldent)

;

= array [Givenldentif iers] of Identif ierType

;

= 0. .maxint

;

{ this is the format of records in the file to be read in }

FilePersonRecord = record

Name

Identifier

Name Type

;

Identif ierType

;

{ 'M' for Male and 'F' for Female }

Gender

Relative Identifier

end;

char;

RelativeArray
Page 136

IndexType = 0. .MaxPersons

;

GenderType = (Male, Female);

RelationType = (Parent, Child, Spouse, Sibling, Uncle,

Nephew, Cousin, NullRelation)

;

{ directed edges in the graph are of a given type }

Edge Type = Parent .. Spouse;

{ A node in the graph (= Person) has either already been reached,

is immediately adjacent to those reached, or farther away. }

ReachedType = (Reached, Nearby, NotSeen);

{ each Person has a linked list of adjacent nodes, called neighbors }

NeighborPointer = "NeighborRe cord;

NeighborRecord = record

Neighborlndex : IndexType;

NeighborEdge : Edge Type;

NextNeighbor : NeighborPointer

end;

{ All Relationships are captured in the directed graph of which

each record is a node . }

PersonRecord = record

{ static information - filled from People file: }

Name : Name Type;

Identifier : Identif ierType ; ^ Gender : GenderType;

{ Identifiers of immediate relatives - father, mother, spouse }

Relativeldentif ier : Relative Array

;

{ head of linked list of adjacent nodes }

NeighborListHeader : NeighborPointer;

{ data used when traversing graph to resolve user request: }

DistanceFromSource : real;

PathPredecessor : IndexType;

EdgeToPredecessor : EdgeType;

ReachedStatus : ReachedType;

{ data used to compute common genetic material }

Descendantldentif ier : Identif ierType

;

DescendantGenes : real

end;

var

{ The Person array is the central repository of information

about inter-relationships. }

Person : array [IndexType] of PersonRecord;

{ These variables are used when establishing the Person array

from the People file. }

People : file of FilePersonRecord;

Current, Previous, NumberOf Persons

: IndexType

;

Identif ier Index : Identif ierRange

;

Previous Ident , Current Ident , Nullldent

: Identif ierType

;

Relationship : Givenldentif iers

;

RelationLoopDone : boolean;
{ These variables are used to accept and resolve requests for

Relationship information. }

Bufferlndex, SemicolonLocation

: BufferRange;

RequestBuff er : BufferType;

Personlldent, Person2ldent

: Name Type;

PersonlFound, Person2Found

: Counter;

ErrorMessage : MessageType;

Personllndex, Person2lndex

: IndexType;

function IdentsEqual (Identa, Identb: Identif ierType) : boolean

{ Determines whether two numeric Person-Identifiers are equal

A function is necessary because the operator does not

work for arrays of anything but char. } var

Index : 1. . Identif ierLength;

begin

IdentsEqual := true;

for Index := 1 to Identif ierLength do

if Identa [Index] <> Identb [Index] then

IdentsEqual := false

end; { IdentsEqual }
Page 138

procedure LinkRelatives (Fromlndex : IndexType;

Relationship : Givenldentif iers

;

To Index : IndexType);

{ establishes cross- indexing between innnediately related Persons. }

procedure LinkOneWay (Fromlndex : IndexType;

ThisEdge : EdgeType;

To Index : IndexType);

{ Establishes the NeighborRecord from one Person to another } varNewNeighbor : Neighbor Pointer

;

beg in new (NewNeighbor);

with NewNeighbor^ do

begin

Neighbor Index := To Index;

NeighborEdge := ThisEdge;

NextNeighbor := Person [Fromlndex] . NeighborListHeader

end;

Person [Fromlndex] . NeighborListHeader := NewNeighbor

end;

begin { execution of LinkRelatives }

if Relationship = Spouseldent then

begin

LinkOneWay (Fromlndex, Spouse, To Index);

LinkOneWay (Toindex, Spouse, Fromlndex)

end

else { Relationship is Mother or Father }

begin

LinkOneWay (Fromlndex, Parent, Toindex);

LinkOneWay (Toindex, Child, Fromlndex)

end

end; { LinkRelatives }

procedure Prompt AndRead;

{ Issues prompt for user-request, reads in request,

blank-fills buffer, and skips to next line of input. } varBufferlndex : BufferRange;

beg in

writeln (' ');

writeln (' ');

writeln (' Enter two person-identifiers (name or number),');

writeln (' separated by semicolon. Enter "stop" to stop.');

for Bufferlndex := 1 to BufferLength do

if eoln( input) then

RequestBuf f er [Bufferlndex] := '

' else

read (input, RequestBuffer [Bufferlndex] );

readln( input)

end; { PromptAndRead }
procedure CheckRequest (var RequestStatus : MessageType;

var SemicolonLocation : Buf f erRange)

;

{ Performs syntactic check on request in buffer. } var

Buffer Index : Buff erRange;

SemicolonCount : Counter;

PersonlFieldExists , Person2FieldExists

: boolean;

beg in

RequestStatus := RequestOk;

PersonlFieldExists := false;

Person2FieldExists := false;

SemicolonCount := 0;

for Bufferlndex := 1 to BufferLength do

if RequestBuff er [Bufferlndex] <> ' ' then

if RequestBuf fer [Bufferlndex] = ';' then

begin

SemicolonLocation := Bufferlndex;

SemicolonCount := SemicolonCount + 1 end

else { Check for non-blanks before/after semicolon. }

if SemicolonCount < 1 then

PersonlFieldExists := true

else

Person2FieldExists := true;

{ set RequestStatus, based on results of scan of RequestBuf

f

if SemicolonCount <> 1 then

RequestStatus := 'must be exactly one semicolon,

else

if not PersonlFieldExists then

RequestStatus :- 'null field preceding semicolon,

else

if not Person2FieldExists then

RequestStatus := 'null field following semicolon,

end; { CheckRequest }

procedure Buf f erToPerson (var Personid : NameType

;

StartLocation, StopLocation : Buf f erRange)

;

{ fills in the Personid from the designated portion

of the RequestBuffer . } varBufferlndex : 1..61; { cannot say "BufferLength + 1" }

Per son Index : Name Range;

begin

Bufferlndex := StartLocation;

while RequestBuf fer [Bufferlndex] = ' ' do

Bufferlndex := Bufferlndex + 1; for Personlndex := 1 to NameLength do

if Bufferlndex > StopLocation then

Personid [Personlndex] := '

' else

begin

Personid [Personlndex] := RequestBuf fer [Bufferlndex];

Bufferlndex := Bufferlndex + 1 end

end; { Buf f erToPerson }
Page lAO

procedure SearchForRequestedPersons (Personlldent , Person2Ident

var Personllndex, Person2Index : IndexType;

var PersonlFound , Person2Found : Counter);

{ SearchForRequestedPersons scans through the Person array,

looking for the two requested persons. Match may be by name

or unique identifier-number. } var

Current : IndexType;

Thisldent : NameType;

Identifier Index : Identif ierRange

;

begin

PersonlFound := 0;

Person2Found := 0;

Thisldent :=

' for Current := 1 to NumberOf Persons do

with Person [Current] do

begin

{ Thisldent contains Current Person's numeric Identifier

left-justified, padded with blanks. }

for Identif ier Index := 1 to Identif ierLength do

Thisldent [Identif ier Index] := Identifier [Identif ier Index]

;

{ allow identification by name or number. }

if (Personlldent = Thisldent) or (Personlldent = Name) then

NameType

;

PersonlFound +

Current

1;

end:

begin

PersonlFound

Personllndex

end;

if (Person2ldent = Thisldent) or (Person2ldent = Name) then

beg in

Person2Found

Per son 2 Index

end

end { with Person [Current] }

{ SearchForRequestedPersons }

Person2Found + 1; Current

procedure FindRelationship (Targetlndex , Sourcelndex : IndexType);

{ Finds shortest path (if any) between two Persons and

determines their Relationship based on immediate relations

traversed in path. Person array simulates a directed graph,

and algorithm finds shortest path, based on following

weights: Parent-Child edge = 1.0

Spouse-Spouse edge =1.8 } varSearchStatus : (Searching, Succeeded, Failed);

Personlndex, ThisNode, AdjacentNode, BestNearby Index, LastNearby Index

IndexType

;

array [IndexType] of IndexType;

EdgeType;

NeighborPointer

;

Givenldentif iers

;

real;

NearbyNode

ThisEdge

ThisNeighbor

Relationship

MinimalDi stance
procedure ProcessAdjacentNode (BaseNode, NextNode : IndexType;

NextBaseEdge : EdgeType);

{ NextNode is adjacent to last-reached node (= BaseNode).

if NextNode already Reached , do nothing

.

If previously seen, check whether path thru base node is

shorter than current path to NextNode, and if so re-link

next to base

.

If not previously seen, link next to base node. } varWeightThisEdge , DistanceThruBaseNode

: real;

procedure LinkNextNodeToBaseNode

;

{ link next to base by re-setting its predecessor Index to

point to base, note type of edge, and re-set distance

as it is through base node. }

begin { execution of LinkNextNodeToBaseNode } with Person [NextNode] do

begin

DistanceFromSource := DistanceThruBaseNode;

PathPredecessor := BaseNode;

EdgeTo Predecessor := NextBaseEdge

end

end; { LinkNextNodeToBaseNode }

begin { execution of ProcessAdjacentNode }

with Person [NextNode] do

if Reached Status <> Reached then

begin

if NextBaseEdge = Spouse then

WeightThisEdge := 1.8

else

WeightThisEdge := 1.0;

DistanceThruBaseNode := WeightThisEdge +

Person [BaseNode] . DistanceFromSource;

if ReachedStatus = Not Seen then

begin

ReachedStatus := Nearby;

Last Nearby Index := LastNearby Index + 1; NearbyNode [LastNearbylndex] := NextNode;

LinkNextNodeToBaseNode

end

else { ReachedStatus = Nearby }

if DistanceThruBaseNode < DistanceFromSource then

LinkNextNodeToBaseNode

;

end { if ReachedStatus <> Reached }

end; { ProcessAdjacentNode }
Page 142

procedure ResolvePathToEnglish;

{ ResolvePathToEnglish condenses the shortest path to a series of Relationships for which there are English

descriptions . }

type

{ Key Persons are the ones in the Relationship path which remain

after the path is condensed. }

SiblingType = (Step, Half, Full);

KeyPersonRecord = record

Personlndex : IndexType

;

GenerationGap : Counter;

Proximity : SiblingType;

case RelationToNext : RelationType of

Parent, Child, Spouse, Sibling, Uncle, Nephew, NullRelation

: ();

Cousin : (CousinRank : Counter)

end; var

{ these variables are used to condense the path }

Key Person : array [IndexType] of KeyPersonRecord;

KeyRelation, LaterKeyRelation , PrimaryRelation, NextPrimaryRelation

: RelationType;

GenerationCount : Counter;

Keylndex, LaterKey Index , Primarylndex

: IndexType;

AnotherElementPossible : boolean;

function FullSibling (Indexl, Index2 : IndexType) : boolean;

{ Determines whether two Persons are full siblings, i.e.,

have the same two Parents. } varIdentlndex : 1. . Identif ierLength;

begin

with Person [Indexl] do

FullSibling := (not IdentsEqual (Relativeldentif ier [Fatherldent] , Nullldent)) and

(not IdentsEqual (Relat ive Ident if ier [Mother Ident] , Nullldent)) and

(IdentsEqual (Relativeldentif ier [Fatherldent],

Person [Index2] . Relativeldentif ier [Fatherldent] )) and

(IdentsEqual (Relativeldentif ier [Motherldent]

,

Person [Index2] . Relativeldentif ier [Motherldent] ))

end; { FullSibling }

procedure CondenseKeyPersons (Atlndex : IndexType; GapSize : Counter);

{ CondenseKeyPersons condenses superfluous entries from the

KeyPerson array, starting at Atlndex. } varReceivelndex , Sendlndex : IndexType;

begin

Receivelndex := Atlndex;

repeat

Receivelndex := Receivelndex +1;

Sendlndex := Receivelndex + GapSize;

KeyPerson [Receivelndex] := KeyPerson [Sendlndex];

until KeyPerson [Sendlndex] . RelationToNext = NullRelation

end; { CondenseKeyPersons }
procedure DisplayRelation (Firstlndex, Lastlndex, Primarylndex

: IndexType);

{ DisplayRelation takes 1, 2, or 3 adjacent elements in the

condensed table and generates the English description of

the relation between the first and last + 1 elements. } var

Inlaw : boolean;

ThisProximity : Sibling Type;

ThisGender : GenderType

;

Suf f ixindicator : 0..9;

FirstRelation , LastRelation , PrimaryRelation

: RelationType

;

This Generat ionGap , This Cous inRank

: Counter;

begin { execution of DisplayRelation }

FirstRelation := KeyPerson [Firstlndex] . RelationToNext

;

LastRelation := KeyPerson [Lastlndex] . RelationToNext;

PrimaryRelation := KeyPerson [Primarylndex] . RelationToNext;

{ set ThisProximity }

if ((PrimaryRelation = Parent) and (FirstRelation = Spouse)) or ((PrimaryRelation = Child) and (LastRelation = Spouse))

then

ThisProximity := Step

else

if PrimaryRelation in

[Sibling, Uncle, Nephew, Cousin]

then

ThisProximity := KeyPerson [Primarylndex] . Proximity

else

ThisProximity := Full;

{ set This GenerationGap }

if PrimaryRelation in [Parent, Child, Uncle, Nephew, Cousin]

then

ThisGenerationGap := KeyPerson [Primarylndex] . GenerationGap

else

ThisGenerationGap := 0;

{ set Inlaw }

Inlaw := false;

if (FirstRelation = Spouse) and

(PrimaryRelation in [Sibling, Child, Nephew, Cousin] ) then

Inlaw := true;

if (LastRelation = Spouse) and

(PrimaryRelation in [Sibling, Parent, Uncle, Cousin] ) then

Inlaw : = true

;

{ set This Cous inRank }

if PrimaryRelation = Cousin then

This Cous inRank := KeyPerson [Primarylndex] . CousinRank

else

ThisCousinRank := 0;
144

{ parameters are set - now generate display. }

write (' Person [KeyPerson [Firstlndex] . Personlndex] . Name,

is ');

if PrimaryRelation in [Parent, Child, Uncle, Nephew] then

begin { write generation-qualifier }

if ThisGenerationGap >= 3 then

begin

write ('great');

if ThisGenerationGap > 3 then

write ('*', ThisGenerationGap - 2 : 1);

write ('-')

end;

if ThisGenerationGap >= 2 then

write ('grand-')

end

else

if (PrimaryRelation = Cousin) and (ThisCousinRank > 1) then

begin

write (ThisCousinRank : 1);

Suf f ixindicator := ThisCousinRank mod 10; case Suf f ixindicator of

1 : write ('st ')

2 : write ('nd ');

3 : write ('rd ')

0, 4, 5, 6, 7, 8, 9

: write ('th ')

end

end;

if ThisProximity = Step then

write ('step-')

else

if ThisProximity = Half then

write ('half-');

ThisGender := Person [KeyPerson

case PrimaryRelation of

[Firstlndex] . Personlndex] . Gender

Parent :

Child :

Spouse :

Sibling :

Uncle ^ :

Nephew :

Cousin : NullRelation : end; { case }

if ThisGender = else

if ThisGender = else

if ThisGender = else

if ThisGender = else

if ThisGender = else

if ThisGender = else

write ('cousin'

write ('null')

Male then write

write

Male then write

write

Male then write

write

Male then write

write

Male then write

write

Male then write

write

);

'father')

'mother' );

'son'

)

'daughter');

'husband'

)

'wif e' )

;

'brother'

)

' sister' )

;

'uncle'

)

'aunt' )

;

'nephew'

)

'niece');
If Inlaw then

write ('-in-law');

if (PrimaryRelation = Cousin) and (ThisGenerationGap > 0) then

if ThisGenerationGap > 1 then

write (' ', ThisGenerationGap : 1, ' times removed')

else

write (' once removed');

writeln (' of)

end; { DisplayRelation }

begin { execution of ResolvePathToEnglish }

writeln (' Shortest path betwe en identified persons: ');

ThisNode := Target Index;

KeyIndex := 1;

{ Display path and initialize KeyPerson array from path elements

while ThisNode <> Sourcelndex do

with Person [ThisNode] do

begin

write (' ', Name, ' is '); case EdgeToPredecessor of

Parent : writeln ('parent of);

Child : writeln ('child of);

Spouse : writeln ('spouse of)

end;

KeyPerson [Keylndex] . Personlndex := KeyPerson [Keylndex] . RelationToNext := if EdgeToPredecessor = Spouse then

KeyPerson [Keylndex] . GenerationGap

else { Parent or Child }

KeyPerson [Keylndex] . GenerationGap

Keylndex := Keylndex + 1; ThisNode := PathPredecessor

end;

writelnC ', Person [ThisNode] . Name);

KeyPerson [Keylndex] . Personlndex := KeyPerson [Keylndex] . RelationToNext : = KeyPerson [Keylndex +1] . RelationToNext :=

ThisNode;

EdgeToPredecessor

;

;= 0

;= 1;

ThisNode;

NullRelation;

NullRelation;
Page 146

{ Resolve Child-Parent and Child-Spouse-Parent relations

to Sibling relations. }

Keylndex := 1; while KeyPerson [Keylndex] • RelationToNext Ky NullRelation do

with KeyPerson [Keylndex] do

begin

if RelationToNext = Child then

begin

LaterKeyRelation := KeyPerson [Keylndex +1] . RelationToNext;

if LaterKeyRelation = Parent then

{ found either full or half siblings }

begin

RelationToNext := Sibling;

if FullSibling (Personlndex,

KeyPerson [Keylndex +2] . Personlndex)

then

Proximity := Full

else

Proximity := Half;

CondenseKeyPersons (Keylndex, 1)

end { processing of full/half siblings }

else

if (LaterKeyRelation = Spouse) and

(KeyPerson [Keylndex +2] . RelationToNext = Parent)

then { found step-siblings }

begin

RelationToNext := Sibling;

Proximity := Step;

CondenseKeyPersons (Keylndex, 2)

end { processing of step-siblings }

end; { if RelationToNext = Child }

Keylndex := Keylndex + 1 end; { with KeyPerson [Keylndex] }

{ Resolve Child-Child-... and Parent-Parent-... relations to

direct descendant or ancestor relations. }

Keylndex := 1; while KeyPerson [Keylndex] . RelationToNext <> NullRelation do

with KeyPerson [Keylndex] do

begin

if (RelationToNext = Child) or (RelationToNext = Parent) then

begin

LaterKey Index := Keylndex + 1; while KeyPerson [LaterKey Index] . RelationToNext = RelationToNext do

LaterKey Index := LaterKey Index + 1;

GenerationCount := LaterKeylndex - Keylndex;

if GenerationCount > 1 then

begin { compress generations }

GenerationGap := GenerationCount;

CondenseKeyPersons (Keylndex, GenerationCount - 1)

end

end; { if RelationToNext = Child or Parent }

Keylndex := Keylndex + 1 end; { with KeyPerson [Keylndex] }
Page 147

{ Resolve Child-Sib.Ting-Parent to Cousin,

Child-Sibling to Nephew,

Sibling-Parent to Uncle. }

Key Index 1; while KeyPerson [Keylndex] . RelationToNext <> NullRelation do

with KeyPerson [Keylndex] do

begin

LaterKeyRelation := KeyPerson [Keylndex + 1] . RelationToNext;

if (RelationToNext = Child) and

(LaterKeyRelation = Sibling)

then { Cousin or Nephew } if KeyPerson [Keylndex +2] . RelationToNext = Parent then

{ found Cousin }

begin

RelationToNext := Cousin;

Proximity := KeyPerson [Keylndex +1] . Proximity;

if GenerationCap < KeyPerson [Keylndex +2] . GenerationGap

then

CousinRank := GenerationGap

else

CousinRank := KeyPerson [Keylndex +2] . GenerationGap;

GenerationGap := abs (GenerationGap - KeyPerson [Keylndex +2] . GenerationGap);

CondenseKey Per sons (Keylndex, 2)

end

else { found Nephew }

begin

RelationToNext := Nephew;

Proximity := KeyPerson [Keylndex + 1] . Proximity;

CondenseKeyPer sons (Keylndex, 1)

end

else { not Cousin or Nephew }

if (RelationToNext = Sibling) and (LaterKeyRelation = Parent)

then { found Uncle }

begin

RelationToNext := Uncle;

GenerationGap := KeyPerson [Keylndex + 1] • GenerationGap;

CondenseKeyPersons (Keylndex, 1)

end;

Keylndex := Keylndex + 1 end; { with KeyPerson [Keylndex] }
;e 148

{ Loop below will pick out valid adjacent strings of elements

to be displayed. Key Index points to first element,

LaterKeylndex to last element, and Primarylndex to the

element which determines the primary English word to be used.

Associativity of adjacent elements in condensed table

is based on English usage. }

Key Index := 1; writeln (' Condensed path:');

while KeyPerson [Keylndex] . RelationToNext <> NullRelation do

begin

KeyRelation := KeyPerson [Keylndex] . RelationToNext;

LaterKeylndex := Keylndex;

Primarylndex := Keylndex;

if KeyPerson [Keylndex + 1] . RelationToNext <> NullRelation then

begin { seek multi-element combination }

AnotherElementPossible := true;

if KeyRelation = Spouse then

begin

LaterKeylndex := LaterKeylndex + 1; Primarylndex := LaterKeylndex;

if (KeyPerson [LaterKeylndex] . RelationToNext = Sibling) or (KeyPerson [LaterKeylndex] . RelationToNext = Cousin)

then { Nothing can follow Spouse-Sibling or Spouse-Cousin }

AnotherElementPossible := false

end;

{ Primarylndex is now correctly set. Next if-statement

determines if a following Spouse relation should be

appended to this combination or left for the next

combination. }

if AnotherElementPossible and

(KeyPerson [Primarylndex +1] . RelationToNext = Spouse)

{ Only a Spouse can follow a Primary }

then

begin { check primary preceding and following Spouse. }

PrimaryRelation := KeyPerson [Primarylndex] . RelationToNext;

NextPrimaryRelation := KeyPerson [Primarylndex +2] . RelationToNext;

if (NextPrimaryRelation in [Nephew, Cousin, NullRelation] ) or (PrimaryRelation = Nephew)

or ( ( PrimaryRelation in [Sibling, Parent] ) and (NextPrimaryRelation <> Uncle ) ) then { append following Spouse with this combination. }

LaterKeylndex := LaterKeylndex + 1 end { check primary preceding and following Spouse }

end; { multi-element combination }

DisplayRelation (Keylndex, LaterKeylndex, Primarylndex);

Keylndex := LaterKeylndex + 1 end; { while }

writeln (' Person [KeyPerson [Keylndex] . Personlndex] . Name)

end; , { ResolvePathToEnglish }
procedure Compute CommonGenes (Indexl, Index2 : IndexType);

{ Compute CommonGenes assumes that each ancestor contributes

half of the genetic material to a Person. It finds common ancestors between two Persons and computes the expected

value of the Proportion of common material. } varCommonProportion : real;

procedure ZeroProportion (Zerolndex : IndexType);

{ ZeroProportion recursively seeks out all ancestors and zeros them out. } varThisNelghbor : NeighborPolnter

;

begin

with Person [Zerolndex] do

begin

DescendantGenes := 0.0;

ThisNelghbor := NeighborLlstHeader

end;

while ThisNelghbor <> nil do

with ThisNelghbor" do

begin

if NeighborEdge = Parent then

ZeroProportion (Neighbor Index)

;

ThisNelghbor := NextNeighbor

end { with }

end; { ZeroProportion }

procedure MarkProportion (Marker : Identlf lerType

;

Proportion : real; Markedlndex : IndexType);

{ MarkProportion recursively seeks out all ancestors and

marks them with the sender's Proportion of shared

genetic material. This Proportion is diluted by one-half

for each generation. } varThisNelghbor : NeighborPolnter;

begin

with Person [Markedlndex] do

begin

Descendantldentifier := Marker;

DescendantGenes := DescendantGenes + Proportion;

ThisNelghbor := NeighborLlstHeader

end;

\ih±le ThisNelghbor <> nil do

with ThisNelghbor" do

begin

if NeighborEdge = Parent then

MarkProportion (Marker, Proportion / 2.0,

Neighborlndex );

ThisNelghbor := NextNeighbor

end

end; { MarkProportion }
Page 150

procedure CheckCommonProportion

(var CommonProportlon : real;

Matchldentif ier : Identif ierType

;

Proportion : real;

AlreadyCounted : real;

Checklndex : IndexType);

{ CheckCommonProportion searches all the ancestors of

Checklndex to see if any have been marked, and if so adds the appropriate amount to CommonProportlon. } varThisNeighbor : NeighborPointer

;

ThisContribution : real;

begin

with Person [Checklndex] do

begin

if IdentsEqual (Descendantldentif ier , Matchldentif ier ) then

begin

{ Increment CommonProportlon by the contribution of

this common ancestor, but discount for the contribution

of less remote ancestors already counted. }

ThisContribution := DescendantGenes * Proportion;

CommonProportlon := CommonProportlon +

ThisContribution - AlreadyCounted

end

else

ThisContribution := 0.0;

ThisNeighbor := NeighborListHeader

end; { with Person [Checklndex] }

while ThisNeighbor O nil do

with ThisNeighbor" do

beg in

if NeighborEdge = Parent then

CheckCommonProportion (CommonProportlon

,

Matchldentif ier , Proportion / 2.0,

ThisContribution / 4.0,

Neighborlndex );

ThisNeighbor := NextNeighbor

end

end; { CheckCommonProportion }

begin { ComputeCommonGenes }

{ First zero out all ancestors to allow adding. This is necessary

because there might be two paths to an ancestor. }

ZeroProportion (Indexl);

{ now mark with shared Proportion }

MarkProportion ( Person [Indexl] . Identifier, 1.0, Indexl);

CommonProportlon := 0.0;

CheckCommonProportion (CommonProportlon

,

Person [Indexl] . Identifier, 1.0, 0.0, Index2);

writeln (' Proportion of common genetic material = CommonProportlon : 12)

end; { ComputeCommonGenes }
begin { execution of FindRelationshlp }

{ initialize Person-array for processing - mark all nodes as not seen }

for Personlndex := 1 to NumberOf Persons do

Person [Personlndex] . ReachedStatus := NotSeen;

{ mark source node as Reached } ThisNode := Sourcelndex;

with Person [ThisNode] do

begin

ReachedStatus := Reached;

DistanceFromSource := 0.0

end;

{ no Nearby nodes exist yet }

Last Nearby Index := 0;

if ThisNode = Targetlndex then

SearchStatus := Succeeded

else

SearchStatus := Searching;

{ Loop keeps processing closest-to-source , unreached node

until target Reached, or no more connected nodes. }

while SearchStatus = Searching do

begin

{ Process all nodes adjacent to ThisNode }

ThisNeighbor := Person [ThisNode] . NeighborListHeader

;

while ThisNeighbor <> nil do

with ThisNeighbor" do

begin

ProcessAd jacentNode (ThisNode, Neighborlndex , NeighborEdge)

;

ThisNeighbor := NextNeighbor

end;

{ All nodes adjacent to ThisNode are set. Now search for

shortest-distance unreached (but Nearby) node to process next,

if LastNearbylndex = 0 then

SearchStatus := Failed

else

begin

MinimalDistance := l.Oe+18;

for Personlndex := 1 to LastNearbylndex do

with Person [NearbyNode [Personlndex]] do

if DistanceFromSource < MinimalDistance then

begin

BestNearbylndex := Personlndex;

MinimalDistance := DistanceFromSource

end;

{ Establish new ThisNode } ThisNode := NearbyNode [BestNearbylndex];

{ change ThisNode from being Nearby to Reached }

Person [ThisNode] . ReachedStatus := Reached;

{ remove ThisNode from Nearby list }

NearbyNode [BestNearbylndex] := NearbyNode [LastNearbylndex];

LastNearbylndex := LastNearbylndex - 1; if ThisNode = Targetlndex then

SearchStatus := Succeeded

end { determination of next node to process }

end; { while SearchStatus = Searching }
Page 152

{ Shortest path between Persons now established. Next task is

to translate path to English description of Relationship. }

if SearchStatus = Failed then

writeln (' Person [Targetlndex] . Name, ' is not related to

Person [ Sourcelndex] . Name)

else { success ~ parse path to find and display Relationship }

beg in

ResolvePathToEnglish;

ComputeCommonGenes (Sourcelndex, Targetlndex)

end

end; { FindRelationship }

{ *** execution of main sequence begins here *** }

begin

for Identif ierlndex := 1 to Identif ierLength do

Nullldent [Identif ierlndex] := '0';

reset (People);

{ Current location in array being filled }

Current := 0;

{ This loop reads in the People file and constructs the Person

array from it (one Person = one record = one array entry).

As records are read in, links are constructed to represent the

Parent-Child or Spouse relationship. The array then implements

a directed graph which is used to satisfy subsequent user requests. The file is assumed to be correct - no validation

is performed on it. }

while not eof (People) do

begin

Current := Current+1;

with Person [Current] do

begin

{ copy direct information from file to array }

Name := People'' . Name;

Identifier := People" . Identifier;

if People" . Gender = 'M' then

Gender := Male

else

Gender := Female;

Relativeldentif ier := People" . Relativeldentif ier

;

{ Location of adjacent persons as yet undetermined }

NeighborListHeader := nil;

{ Descendants as yet undetermined. }

Descendantldentif ier := Nullldent;

Current Ident := Identifier;
{ Compare this Person against all previously entered Persons

to search for Relationships. } for Previous := 1 to (Current-1) do

begin

Previous Ident := Person [Previous] . Identifier;

RelatlonLoopDone := false;

Relationship := Fatherldent;

{ Search for father, mother, or spouse Relationship in

either direction between this and previous Person.

Assume at most one Relationship exists. } repeat

If IdentsEqual (Relatlveldentlf ier [Relationship],

Previous Ident) then

begin

LlnkRelatlves (Current, Relationship, Previous);

RelatlonLoopDone := true

end

else

If IdentsEqual (Currentldent

,

Person [Previous] . Relatlveldentlf ier [Relationship])

then

begin

LlnkRelatlves (Previous, Relationship, Current);

RelatlonLoopDone := true

end;

If Relationship < Spouseldent then

Relationship := succ(Relatlonship)

else

RelatlonLoopDone := true;

until RelatlonLoopDone

end; { for Previous }

get(People)

end { with Person [Current] }

end; { while not eof (People) }

NumberOf Persons := Current;

{ Person array Is now loaded and edges between Immediate relatives

(Parent-Child or Spouse-Spouse) are established.

While-loop accepts requests and finds Relationship (if any)

between pairs of Persons. }
Page 154

reset( Input)

;

Prompt AndRead

;

while RequestBuf f er <> RequestToStop do

{ The following code retrieves and validates a user request

for the Relationship between two identified Persons. }

begin

CheckRequest (ErrorMessage , SemicolonLocation)

;

{ Syntax check of request completed. Now either display error message or search for the two Persons. }

if ErrorMessage = RequestOk then

begin { Request syntactically correct - search for requested Persons. }

Buf f erToPerson (Personlldent , 1, SemicolonLocation - 1);

Buf f erToPerson (Person2ldent , SemicolonLocation + 1, Buf f erLength)

;

SearchForRequestedPersons (Personlldent, Person2Ident

,

Per s on 1 Index, Per son 2 Index,

PersonlFound , Person2Found)

;

if (PersonlFound =1) and (Person2Found =1) then

{ Exactly one match for each Person - proceed to

determine Relationship, if any. }

if Personllndex = Person2lndex then

begin

write (' Person [Personllndex] . Name,

is identical to ');

if Person [Personllndex] . Gender = Male then

writeln('himself . ')

else

writeln( 'herself

)

end

else

FindRelationship (Personllndex, Person2lndex)

else { either not found or more than one found }

begin

if PersonlFound = 0 then

writeln (' First person not found.')

else

if PersonlFound > 1 then

writeln (' Duplicate names for first person - use',

numeric identifier.');

if Person2Found = 0 then

writeln (' Second person not found.')

else

if Person2Found > 1 then

writeln (' Duplicate names for second person - use',

numeric identifier.')

end

end { processing of syntactically legal request }

else

writeln (' Incorrect request format: ', ErrorMessage);

Prompt AndRead

end; { while RequestBuf fer }

writeln (' End of relation-finder.');

end

.
Page 155

8.0 PL/I

In keeping with the general convention of the examples, language-supplied

keywords and identifiers are written in lower case in the program. To conform

strictly to the PL/I standard, however, programs must use only upper-case

letters. In the following program, the logical "Not" operator is represented by

the graphic character

RELATE: procedure options (main);

/* Begin declaration of global data */

declare

/* Used to index relative array, pointing to immediate relatives */

( FATHER_IDENT initial (1),

MOTHER_IDENT initial (2),

SPOUSE_IDENT initial (3),

/* Used as mnemonics to represent basic English-word relationships. */

PARENT initial (1),

CHILD initial (2),

SPOUSE initial (3),

SIBLING initial (4),

UNCLE initial (5),

NEPHEW initial (6),

COUSIN initial (7),

NULL_RELATION initial (8),

/* Used as mnemonics to represent status of nodes during search

for shortest path thru graph. */

REACHED initial (1),

NEARBY initial (2),

NOT_SEEN initial (3) ) fixed binary (4,0),

/* Used as mnemonics to represent truth-values */

( TRUE initial ('I'b),

FALSE initial ('O'b))

bit (1),

/* Used to control user requests. */

( REQUEST_OK character (10) initial ('Request OK'),

REQUEST_TO_STOP character (4) initial ('stop')),

/* Used as mnemonics to represent GENDER */

( MALE initial ('M'),

FEMALE initial ('F'))

character (1);
Page 156

declare

/* the PERSON array is the central repository of information

about inter-relationships . */

/* All relationships are captured in the directed graph of which

each record is a node . */

01 PERSON dimension (1:300),

/* static information - filled from PEOPLE file: */

05 NAME character (20),

05 IDENTIFIER picture '999',

05 GENDER character (1),

/* IDENTIFIERS of immediate relatives - father, mother, spouse

05 RELATIVE_IDENTIFIER (1:3)

picture '999',

/* head of linked list of adjacent nodes */

05 NEIGHBOR_LIST_HEADER pointer,

/* data used when traversing graph to resolve user request: */

05 DISTANCE_FROM_SOURCE float decimal (6),

05 PATH_PREDECESSOR fixed binary (10,0),

05 EDGE_T0_PREDECESS0R fixed binary (4,0),

05 REACHED_STATUS fixed binary (4,0),

/* data used to compute common genetic material */

05 DESCENDANT_IDENTIFIER picture '999',

05 DESCENDANT GENES float decimal (6);

declare

/* each PERSON has a linked list of adjacent nodes, called neighbors */

01 NEIGHBOR_RECORD based (NEW_NEIGHBOR)

,

05 NEIGHBOR_INDEX fixed binary (10,0),

05 NEIGHBOR_EDGE fixed binary (4,0),

05 NEXT_NEIGHB0R pointer;

/* End declaration of global data. */

declare

/* This is the format of records in the file to be read in. */

01 PE0PLE_REC0RD,

05 NAME character (20),

05 IDENTIFIER picture '999',

/* 'M' for MALE and 'F' for FEMALE */

05 GENDER character (1),

05 RELATIVE_IDENTIFIER (1:3) picture '999';

declare

/* These variables are used when establishing the PERSON array

from the PEOPLE file. */

PEOPLE file record sequential input,

(CURRENT, PREVIOUS, NUMBER_OF_PERSONS

)

fixed binary (10,0),

(PREVIOUS_IDENT, CURRENT_IDENT)

picture '999',

NULL_IDENT picture '999' static initial (000),

RELATIONSHIP fixed binary (4,0),

RELATI0N_L00P_D0NE bit (1),

END OF PEOPLE bit (1);
Page 157

declare

/* These variables are used to accept and resolve requests for

RELATIONSHIP Information. */

sysin file record input environment (AREAD),

(BUFFER_INDEX, SEMICOLON_LOCATION)

fixed binary (10,0),

REQUEST_BUFFER character (60) varying,

(PERS0N1_IDENT, PERS0N2_IDENT)

character (20),

( PERSON1_F0UND, PERS0N2_F0UND)

fixed binary (10,0),

ERR0R_MESSAGE character (40),

(PERS0N1_INDEX, PERS0N2_INDEX)

fixed binary (10,0);

/* This on-block captures exceptions from the following code */ on end file (PEOPLE)

begin;

END_OF_PEOPLE = TRUE;

end;
Page 158

/* *** begin execution of main sequence RELATE *** */

open file (PEOPLE) title ('PEOPLE.DAT');

END_OF_PEOPLE = FALSE;

/* This loop reads in the PEOPLE file and constructs the PERSON

array from it (one PERSON = one record = one array entry).

As records are read in, links are constructed to represent the

PARENT-CHILD or SPOUSE RELATIONSHIP. The array then implements

a directed graph which is used to satisfy subsequent user requests. The file is assumed to be correct - no validation

is performed on it. */

read file (PEOPLE) into (PEOPLE_RECORD)

;

READ_IN_PEOPLE:

do CURRENT = 1 to 300 while (~ END_OF_PEOPLE);

/* copy direct information from file to array */

PERSON (CURRENT) = PEOPLE_RECORD, by name;

/* Location of adjacent persons as yet undetermined. */

PERSON (CURRENT) . NEIGHBOR_LIST_HEADER = null();

/* Descendants as yet undetermined */

PERSON (CURRENT) . DESCENDANT_IDENTIFIER = NULL_IDENT;

CURRENT_IDENT = PERSON (CURRENT) . IDENTIFIER;

/* Compare this PERSON against all previously entered PERSONS

to search for RELATIONSHIPS. */

COMPARE_TO_PREVIOUS

:

do PREVIOUS = 1 to (CURRENT-1);

PREVIOUS_IDENT = PERSON (PREVIOUS) . IDENTIFIER;

RELATION_LOOP_DONE = FALSE;

/* Search for father, mother, or spouse relationship in

either direction between this and PREVIOUS PERSON.

Assume at most one RELATIONSHIP exists. */

TRY_ALL_RELATIONSHIPS

:

do RELATIONSHIP = FATHER_IDENT to SPOUSE_IDENT

while C RELATION_LOOP_DONE ) ; if PERSON (CURRENT) . RELATIVE_IDENTIFIER (RELATIONSHIP) = PREVIOUS_IDENT then

do

;

call LINK_RELATIVES (CURRENT, RELATIONSHIP, PREVIOUS);

RELATION_LOOP_DONE = TRUE;

end;

else

if CURRENT_IDENT = PERSON (PREVIOUS) . RELATIVE_IDENTIFIER (RELATIONSHIP)

then

do

;

call LINK_RELATIVES (PREVIOUS, RELATIONSHIP, CURRENT);

RELATION_LOOP_DONE = TRUE;

end;

end TRY_ALL_RELATIONSHIPS

;

end COMPARE_TO_PREVIOUS;

read file (PEOPLE) into (PEOPLE_RECORD)

;

end READ_IN_PEOPLE

;

NUMBER_OF_PERSONS = CURRENT - 1; close file (PEOPLE);

/* PERSON array is now loaded and edges between immediate relatives

(PARENT -CHILD or SPOUSE-SPOUSE) are established.
Page 159

While-loop accepts requests and finds RELATIONSHIP (if any)

between pairs of PERSONS. */

call PROMPT_AND_READ();

READ_AND_PROCE S S_REQUE ST

:

do while (REQUESTJBUFFER ~= REQUEST_TO_STOP)

;

/* The following code retrieves and validates a user request

for the RELATIONSHIP between two identified PERSONS. */

call CHECK_REQUEST (ERROR_MESSAGE, SEMICOLON_LOCATION)

;

/* Syntax check of request completed. Now either display error message or search for the two PERSONS. */

if ERROR_MESSAGE = REQUEST_OK then

do; /* Request syntactically correct - search for requested PERSONS. */

call BUFFER_TO_PERSON ( PERSON 1_I DENT, 1, SEMICOLON_LOCATION - 1);

call BUFFER_TO_PERSON (PERS0N2_IDENT , SEMICOLON_LOCATION + 1,

length (REQUEST_BUFFER));

call SEARCH_FOR_REQUESTED_PERSONS (PERS0N1_IDENT, PERS0N2_IDENT

,

PERSON 1_INDEX, PERS0N2_INDEX,

PERS0N1_F0UND, PERS0N2_F0UND);

if (PERS0N1_F0UND = 1) & (PERS0N2_F0UND = 1) then

/* Exactly one match for each PERSON - proceed to

determine RELATIONSHIP, if any. */

if PERS0N1_INDEX = PERS0N2_INDEX then

if PERSON (PERS0N1_INDEX) . GENDER = MALE then

put skip list (' '

II PERSON (PERS0N1_INDEX) . NAME || ' is identical to himself.');

else

put skip list (' ' II PERSON (PERSON 1_INDEX) . NAME || ' is identical to herself.');

else

call FIND_RELATIONSHIP (PERS0N1_INDEX, PERSON 2_INDE X) ;

•

else /* either not found or more than one found */

do

;

if PERS0N1_F0UND = 0 then

put skip list (' First person not found.');

else

if PERSON 1_F0UND > 1 then

put skip list (' Duplicate names for first person - use' I I ' numeric identifier.');

if PERS0N2_F0UND = 0 then

put skip list (' Second person not found.');

else

if PERS0N2_F0UND > 1 then

put skip list (' Duplicate names for second person - use' I I ' numeric identifier.');

end;

end; /* processing of syntactically legal request */

else

put skip list (' Incorrect request format: '

II ERROR_MESSAGE )

;

call PROMPT_AND_READ ( ) ; end READ_AND_PROCESS_REQUEST;

put skip list (' End of relation-finder.');

/* End execution of main sequence RELATE
Page 160

procedures under RELATE begin here */

LINK RELATIVES: procedure (FROM_INDEX, RELATIONSHIP, TO_INDEX);

/* begin execution of LINK_RELATIVES */

if RELATIONSHIP = SPOUSE_IDENT then

do

;

call LINK_ONE_WAY (FROM_INDEX, SPOUSE, TO_INDEX);

call LINK_ONE_WAY (TO_INDEX, SPOUSE, FROM_INDEX);

end;

else /* RELATIONSHIP is mother or father */

do

;

call LINK_ONE_WAY (FROM_INDEX, PARENT, TO_INDEX);

call LINK_ONE_WAY (TO_INDEX, CHILD, FROM_INDEX);

end;

LINK ONE WAY: procedure (FROM INDEX, THIS EDGE, TO INDEX);

FROM_INDEX fixed binary (10,0),

THIS_EDGE fixed binary (4,0),

TO_INDEX fixed binary (10,0);

declare

NEW_NEIGHBOR pointer;

/* begin execution of LINK_ONE_WAY */

allocate NEIGHBOR_RECORD set (NEW_NEIGHBOR)

;

NEW_NEIGHBOR -> NEIGHBOR_INDEX = TO_INDEX;

NEW_NEIGHBOR -> NEIGHBOR_EDGE = THIS_EDGE

;

NEW_NEIGHBOR -> NEXT_NEIGHBOR = PERSON (FROM_INDEX) . NEIGHBOR_LIST_HEADER;

PERSON (FROM_INDEX) . NEIGHBOR_LIST_HEADER = NEW_NEIGHBOR;

end LINK_ONE_WAY;

end LINK_RELATIVES

;

PROMPT_AND_READ: procedure;

/* Issues prompt for user-request, reads in request,

blank-fills buffer, and skips to next line of input. */

declare

FROM_INDEX

RELATIONSHIP

TO INDEX

fixed binary (10,0),

fixed binary (4,0),

fixed binary (10,0);

declare

declare BUFFER_INDEX fixed binary (10,0),

SEMICOLON COUNT fixed binary (4,0);
/* begin execution of PROMPT_AND_READ */

put skip (2) list (' ')

put skip list (' Enter two person-identifiers (name or number),');

put skip list (' separated by semicolon. Enter "stop" to stop.');

put skip list (' ');

/* The use of sysin for record-oriented, rather than stream-oriented,

input may not be considered to be standard usage. It is done here

because stream input cannot recognize line boundaries, so as to

read an entire line from the terminal. */

read file (sysin) into (REQUESTJBUFFER);

end PROMPT_AND_READ;

CHECK_REQUEST: procedure (REQUESTJSTATUS , SEMICOLON_LOCATION)

;

/* Performs syntactic check on request in buffer. */

declare

REQUEST_STATUS character (40),

SEMICOLONJLOCATION fixed binary (10,0);

/* begin execution of CHECKREQUEST */

SEMICOLON_LOCATION = index (REQUESTJBUFFER, ';');

if SEMICOLON_LOCATION = 0 | index (substr (REQUEST_BUFFER, SEMICOLON_LOCATION + 1), ';') > 0

then

REQUEST_STATUS = 'must be exactly one semicolon.';

else

if before (REQUESTJBUFFER, ';') = ' ' then

REQUEST_STATUS = 'null field preceding semicolon.';

else

if after (REQUEST_BUFFER, ';') = ' ' then

REQUEST STATUS = 'null field following semicolon.';

else

REQUEST_STATUS = REQUESTJ)K;

end CHECK_RE QUEST;

BUFFERjr0_PERS0N: procedure (PERSON_ID, STARTJLOCATION, STOPJ.OCATION)

;

/* fTlls in the PERSON_ID from the designated portion

of the REQUEST_BUFFER. */

declare

PERSON_ID character (20),

(START_L0CATI0N, STOPJLOCATION)

fixed binary (10,0);

declare

FIRSTJION_BLANK fixed binary (10,0);

/* begin execution of BUFFER_T0_PERS0N */

do FIRST_NONJBLANK = STARTJLOCATION to ST0PJ.0CATI0N

while (substr (REQUEST_BUFFER, FIRST_NON_BLANK, 1) = ' ');

end;

PERSON ID = substr (REQUESTJBUFFER, FIRSTJ^ON_BLANK,

STOP_LOCATION - FIRST_NON_BLANK +1);

end BUFFER TO PERSON;
Page 162

SEARCH_FOR_REQUESTED_PERSONS: procedure (PERS0N1_IDENT, PERS0N2_IDENT,

PERS0N1_INDEX, PERS0N2_INDEX,

PERS0N1_F0UND, PERS0N2_F0UND)

;

/* SEARCH_FOR_REQUESTED_PERSONS scans through the PERSON array,

looking for the two requested PERSONS. Match may be by NAME

or unique IDENTIFIER-number . */

declare

(PERS0N1_IDENT, PERS0N2_IDENT) character (20),

(PERS0N1_INDEX, PERS0N2_INDEX) fixed binary (10,0),

(PERS0N1_F0UND, PERS0N2_F0UND) fixed binary (10,0);

declare

THIS_IDENT character (20),

CURRENT fixed binary (10,0);

/* begin execution of SEARCH_FOR_REQUESTED_PERSONS */

PERSON1_F0UND =0;

PERS0N2_F0UND = 0;

SCAN_ALL_PERSONS

:

do CURRENT = 1 to NUMBER_OF_PERSONS

;

/* THIS_IDENT contains CURRENT PERSON'S numeric IDENTIFIER

left- justified , padded with blanks. */

THIS_IDENT = PERSON (CURRENT) . IDENTIFIER;

/* allow identification by name or number. */

if (PERS0N1_IDENT = THIS_IDENT) | (PERS0N1_IDENT = PERSON (CURRENT) . NAME)

then

do

;

PERS0N1_F0UND = PERS0N1_F0UND + 1; PERS0N1_INDEX = CURRENT;

end;

if (PERS0N2_IDENT = THIS_IDENT) | (PERS0N2_IDENT = PERSON (CURRENT) . NAME)

then

do

;

PERS0N2_F0UND = PERS0N2_F0UND + 1; PERS0N2_INDEX = CURRENT;

end;

end SCAN_ALL_PERSONS

;

end SEARCH_FOR_REQUESTED_PERSONS;

/* End of utility procedures under RELATE.
FIND_RELATIONSHIP does major work of program: determines

relationship between any two people In PERSON array. */

FIND_RELATIONSHIP: procedure (TARGET_INDEX, SOURCE_INDEX)

;

/* Finds shortest path (if any) between two PERSONS and

determines their RELATIONSHIP based on Immediate relations

traversed In path. PERSON array simulates a directed graph,

and algorithm finds shortest path, based on following

weights: PARENT-CHILD edge =1.0

SPOUSE -SPOUSE edge =1.8 */

declare

( TARGE T_INDEX, SOURCE_INDEX) fixed binary (10,0);

declare

SEARCH_STATUS character (1),

/* values for SEARCH_STATUS */

(SEARCHING Initial ('?'),

SUCCEEDED initial ('!'),

FAILED initial ('X')) character (1),

(PERSON_INDEX, THIS_NODE, ADJACENT_NODE , BEST_NEARBY_INDEX,

LAST_NEARBY_INDEX) fixed binary (10,0),

NEARBY_NODE dimension (1:300) fixed binary (10,0),

THIS_EDGE fixed binary (4,0),

THIS_NEIGHBOR . pointer

,

RELATIONSHIP fixed binary (4,0),

MINIMAL_DI STANCE float decimal (6);

/* begin execution of FIND_RELATIONSHIP */

/* initialize PERSON-array for processing - mark all nodes as not seen */

PERSON . REACHED_STATUS = NOT_SEEN;

/* mark source node as REACHED */

THIS_NODE = SOURCE_INDEX;

PERSON (THIS_NODE) . REACHED_STATUS = REACHED;

PERSON (THIS_NODE) . DISTANCE_FROM_SOURCE =0.0;

/* no NEARBY nodes exist yet */

LAST_NEARBY_INDEX = 0;

if THISJNODE = TARGET_INDEX then

SEARCH_STATUS = SUCCEEDED;

else

SEARCH STATUS = SEARCHING;
Page 164

/* Loop keeps processing closest-to-source , unREACHED node

until target REACHED, or no more connected nodes. */

SEARCH_FOR_TARGET

:

do while (SEARCH_STATUS = SEARCHING);

/* Process all nodes adjacent to THIS_NODE */

THIS_NEIGHBOR = PERSON (THIS_NODE) . NEIGHBOR_LIST_HEADER;

do while (THIS_NEIGHBOR ~= null());

call PROCESS_ADJACENT_NODE (THISJJODE,

THISJNEIGHBOR -> NEIGHBOR_INDEX,

THIS_NEIGHBOR -> NEIGHBOR_EDGE )

;

THIS_NEIGHBOR = THIS_NEIGHBOR -> NEXT_NEIGHBOR;

end;

/* All nodes adjacent to THIS_NODE are set. Now search for

shortest-distance unREACHED (but NEARBY) node to process next. */

if LAST_NEARBY_INDEX = 0 then

SEARCH_STATUS = FAILED;

else

do

;

MINIMAL_DISTANCE = l.Oe+18;

do PERSON_INDEX = 1 to LAST_NEARBY_INDEX;

if PERSON (NEARBY_NODE (PERSON_INDEX) ) . DISTANCE_FROM_SOURCE

< MINIMAL_DISTANCE then

do;

BEST_NEARBY_INDEX = PERSON_INDEX;

MINIMAL_DI STANCE = PERSON (NEARBY_NODE (PERSON_INDEX) ) . DISTANCE_FROM_SOURCE

;

end;

end; /* PERSON_INDEX loop */

/* establish new THIS_NODE */

THIS_NODE = NEARBY_NODE (BEST_NEARBY_INDEX)

;

/* change THIS_NODE from being NEARBY to REACHED */

PERSON (THIS_NODE) . REACHED_STATUS = REACHED;

/* remove THIS_NODE from NEARBY list */

NEARBY_NODE (BEST_NEARBY_INDEX) = NEARBYJJODE (LAST_NEARBY_INDEX)

;

LAST_NEARBY_INDEX = LAST_NEARBY_INDEX - 1;

if THIS_NODE = TARGET_INDEX then

SEARCH_STATUS = SUCCEEDED;

end; /* determination of next node to process */

end SEARCH_FOR_TARGET;

/* Shortest path between PERSONS now established. Next task is

to translate path to English description of RELATIONSHIP. */

if SEARCH_STATUS = FAILED then

put skip list C PERSON (TARGET_INDEX) . NAME, ' is not related to

PERSON (SOURCE_INDEX) . NAME);

else /* success - parse path to find and display RELATIONSHIP */

do

;

call RESOLVE_PATH_TO_ENGLISH;

call COMPUTE_COMMON_GENES ( SOURCE_INDEX, TARGET_INDEX)

;

end;

/* End execution of FIND RELATIONSHIP.
Page 165

Utility procedures begin here. */

PROCESS_ADJACENT_NODE: procedure (BASE_NODE, NEXT_NODE , NEXT_BASE_EDGE )

;

/* NEXT_NODE is adjacent to last-REACHED node (= BASE_NODE).

if NEXT_NODE already REACHED, do nothing. ~

If previously seen, check whether path thru BASE_NODE is

shorter than current path to NEXT_NODE, and if so re-link

next to base

.

If not previously seen, link next to base node. */

declare

(BASE_NODE, NEXT_NODE ) fixed binary (10,0),

NEXT_BASE_EDGE fixed binary (4,0);

declare

(WEIGHT_THIS_EDGE , DISTANCE_THRU_BASE_NODE

)

float decimal (6);

/* begin execution of PROCESS_ADJACENT NODE */

if PERSON (NEXT_NODE) . REACHED_STATUS ~= REACHED then

do

;

if NEXT_BASE_EDGE = SPOUSE then

WEIGHT_THIS_EDGE = 1.8;

else

WEIGHTJIHISJEDGE = 1.0;

DISTANCE_THRU_BASE_NODE = WEIGHT_THIS_EDGE +

PERSON (BASEJJODE) . DISTANCE_FROM_SOaRCE

;

if PERSON (NEXT_NODE) . REACHED_STATUS = NOT_SEEN then

do

;

PERSON (NEXTJIODE) . REACHED_STATUS = NEARBY;

LAST_NEARBY_INDEX = LAST_NEARBY_INDEX + 1; NEARBY_NODE (LAST_NEARBY_INDEX) = NEXT_NODE

;

call LINK_NEXT_NODE_TO_BASE_NODE

;

end;

else /* REACHED_STATUS = NEARBY */

if DISTANCE_THRU_BASE_NODE < PERSON (NEXT_NODE) . DISTANCE_FROM_SOURCE then

call LINK_NEXT_NODE_TO_BASE_NODE

;

end; /* if REACHED_STATUS not = REACHED */

LINK_NEXT_NODE_TO_BASE_NODE : procedure

;

/* link next to base by re-setting its predecessor index to

point to base, note type of edge, and re-set distance

as it is through base node. */

/* begin execution of LINK_NEXr_NODE_TO_BASE_NODE */

PERSON (NEXT_NODE) . DISTANCE_FROM_SOURCE = DISTANCE_THRU_BASE_NODE

;

PERSON (NEXT_NODE) . PATH_PREDECESSOR = BASE_NODE

;

PERSON (NEXT_NODE) . EDGE_TO_PREDECESSOR = NEXT_BASE_EDGE

;

end LINK_NEXT_NODE_TO_BASE_NODE;

end PROCESS_ADJACENT_NODE

;

/* End utility procedures under FIND_RELATIONSHIP.
Page 166

Begin two major procedures: RESOLVE_PATH_TO_ENGLISH and

COMPUTE_COMMON_GENES */

RESOLVE_PATH_TO_ENGLISH: procedure

;

/* RESOLVE_PATH_TO_ENGLISH condenses the shortest path to a series of RELATIONSHIPS for which there are English

descriptions. */

/* Key persons are the ones in the RELATIONSHIP path which remain

after the path is condensed. */

declare

/* values for sibling proximity

(STEP initial ('S'),

HALF initial ('H'),

FULL initial ('F')) character (1);

declare

01 KEY PERSON dimension (1:300),

05

' PERSON INDEX fixed binary (10,0),

05 GENERATION_GAP fixed binary (10,0),

05 PROXIMITY character (1),

05 RELATION TO NEXT fixed binary (4,0),

05 COUSIN RANK fixed binary (10,0);

declare

/* these variables are used to condense the path */

(KEY_RELATION, LATER_KEY_RELATION, PRIMARY_RELATION,

NEXT_PRIMARY_RELATION) fixed binary (4,0),

GENERATION_COUNT fixed binary (10,0),

(KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX)

fixed binary (10,0),

ANOTHER_ELEMENT_POSSIBLE bit (1);

/* begin execution of RESOLVE_PATH_TO_ENGLISH */

put skip list (' Shortest path between identified persons: ');

THIS_NODE = TARGET_INDEX;

/* Display path and initialize KEY_PERSON array from path elements

TRAVERSE_SHORTEST_PATH

:

do KEY_INDEX = 1 to 300 while (THIS_NODE ~= SOURCE_INDEX)

;

begin;

declare

EDGE_TYPE dimension (1:3) character (9) static

initial ('parent of, 'child of, 'spouse of);

put skip list (' '

II PERSON (THIS_NODE) . NAME || ' is '

||

EDGE_TYPE (PERSON (THIS_NODE) . EDGE_TO_PREDECESSOR) )

;

end;

KEY_PERSON (KEY_INDEX) . PERSON_INDEX = THIS_NODE

;

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = PERSON (THIS_NODE) . EDGE_TO_PREDECESSOR;

if PERSON (THIS_NODE) . EDGE_TO_PREDECESSOR = SPOUSE then

KEY_PERSON (KEY_INDEX) . GENERATIONjSAP = 0;

else

KEY_PERSON (KEY_INDEX) . GENERATIONjSAP = 1; THIS_NODE = PERSON (THIS_NODE) . PATH_PREDECESSOR;

end TRAVERSE_SHORTEST_PATH;

put skip listC '

II PERSON (THIS_NODE) . NAME);
Page 167

KEY_PERSON (KEY_INDEX) . PERSON_INDEX = THIS_NODE

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = NULL RELATION;

KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT = NULL_RELATION;

/* Resolve CHILD-PARENT and CHILD-SPOUSE-PARENT relations

to SIBLING relations. */

FIND_SIBLINGS:

do KEY_INDEX = 1 to 300

while (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT ~= NULL_RELATION)

if KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD then

do

LATER_KEY_RELATION = KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT

if LATER_KEY_RELATION = PARENT then

/* found either full or half SIBLINGS */

do

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = SIBLING;

if FULL_SIBLING (KEY_PERSON (KEY_INDEX) . PERSON_INDEX,

KEY_PERSON (KEY_INDEX + 2) . PERSON_INDEX)

then

KEY_PERSON (KEY_INDEX) . PROXIMITY = FULL;

else

KEY_PERSON (KEY_INDEX) . PROXIMITY = HALF;

call CONDENSE_KEY_PERSONS (KEY_INDEX, 1);

end; /* processing of full/half SIBLINGS */

else

if (LATER_KEY_RELATION = SPOUSE) & (KEY_PERSON (KEY_INDEX + 2) . RELATION_TO_NEXT = PARENT)

then /* found step-SIBLINGs */

do

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = SIBLING;

KEY_PERSON (KEY_INDEX) . PROXIMITY = STEP;

call CONDENSE_KEY_PERSONS (KEY_INDEX, 2);

end; /* processing of step-SIBLINGs */

end; /* if RELATION_TO_NEXr = CHILD */

end FIND_SIBLINGS;

/* Resolve CHILD-CHILD-... and PARENT-PARENT-.. . relations to

direct descendant or ancestor relations. */

FIND_ANCESTORS_OR_DESCENDANTS

do KEY_INDEX = 1 to 300

while (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT ~= NULL_RELATION)

if (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD) | (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXr = PARENT)

then

do

do LATER_KEY_INDEX = KEY_INDEX + 1 to 300

while (KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = KEYJPERSON (KEY_INDEX) . RELATION_TO_NEXT )

end;

GENERATIONJCOUNT = LATER_KEY_INDEX - KEY_INDEX;

If GENERATION_COUNT > 1 then

do; /* compress generations */

KEY_PERSON (KEY_INDEX) . GENERATION_GAP = GENERATIONJCOUNT

call CONDENSE_KEY_PERSONS (KEY_INDEX, GENERATION_COUNT - 1);

end;

end; /* if RELATIONJTOJJEXT = CHILD or PARENT */

end FIND ANCESTORS OR DESCENDANTS;
Page 168

/* Resolve CHILD-SIBLING-PARENT to COUSIN,

CHILD-SIBLING to NEPHEW,

SIBLING-PARENT to UNCLE. */

FIND_COUSINS_NEPHEWS_UNCLES

:

do KEY_INDEX = 1 to 300

while (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT ~= NULL_RELATION)

;

LATER_KEY_RELATION = KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT

;

if (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = CHILD) &

(LATER_KEY_RELATION = SIBLING)

then /* COUSIN or NEPHEW */

If KEY_PERSON (KEY_INDEX + 2) . RELATION_TO_NEXT = PARENT then

/* found COUSIN */

do

;

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = COUSIN;

KEY_PERSON (KEY_INDEX) . PROXIMITY = KEYJPERSON (KEY_INDEX + 1) . PROXIMITY;

KEY_PERSON (KEY_INDEX) . COUSIN_RANK = min (KEY_PERSON (KEY_INDEX) . GENERATION_GAP,

KEY_PERSON (KEY_INDEX + 2) . GENERATION_GAP )

;

KEY_PERSON (KEY_INDEX) . GENERATION_GAP = abs (KEY_PERSON (KEY_INDEX) . GENERATION_GAP - KEYJPERSON (KEY_INDEX + 2) . GENERATION_GAP)

;

call CONDENSE_KEY_PERSONS (KEY_INDEX, 2);

end;

else /* found NEPHEW */

do;

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = NEPHEW;

KEY_PERSON (KEY_INDEX) . PROXIMITY = KEY_PERSON (KEY_INDEX + 1) . PROXIMITY;

call CONDENSE_KEY_PERSONS (KEY_INDEX, 1);

end;

else /* not COUSIN or NEPHEW */

if (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = SIBLING) &

(LATER_KEY_RELATION = PARENT)

then /* found UNCLE */

do

;

KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT = UNCLE;

KEY_PERSON (KEY_INDEX) . GENERATION_GAP = KEY_PERSON (KEY_INDEX + 1) . GENERATION_GAP;

call CONDENSE_KEY_PERSONS (KEY_INDEX, 1);

end;

end FIND COUSINS NEPHEWS UNCLES;
Page 169

/* Loop below will pick out valid adjacent strings of elements

to be displayed. KEY_1NDEX points to first element,

LATER_KEY_INDEX to last element, and PRIMARY_INDEX to the

element which determines the primary English word to be used.

Associativity of adjacent elements in condensed table

is based on English usage. */

KEY_INDEX = 1; put skip list (' Condensed path:');

CONSOLIDATE_ADJACENT_PERSONS

:

do while (KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT ~= NULL_RELATION)

;

KEY_RELATION = KEY_PERSON (KEY_INDEX) . RELATION_TO_NEXT

;

LATER_KEY_INDEX = KEY_INDEX;

PRIMARY_INDEX = KEY_1NDEX;

if KEY_PERSON (KEY_INDEX + 1) . RELATION_TO_NEXT ~= NULL_RELATION then

do; /* seek multi-element combination */

AN0THER_ELEMENT_P0SS1BLE = TRUE;

if KEY_RELATION = SPOUSE then

do

;

LATER_KEY_INDEX = LATER_KEY_INDEX + 1; PRIMARY_INDEX = LATER_KEY_INDEX;

if (KEYJPERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = SIBLING) | (KEY_PERSON (LATER_KEY_INDEX) . RELATION_TO_NEXT = COUSIN)

then /* Nothing can follow SPOUSE-SIBLING or SPOUSE -COUSIN */

ANOTHER_ELEMENT_POSSIBLE = FALSE;

end;

/* PRIMARY_INDEX is now correctly set. Next if-statement

determines if a following SPOUSE relation should be

appended to this combination or left for the next

combination. */

if ANOTHER_ELEMENT_POSSIBLE & (KEY_PERSON (PRIMARY_INDEX + I) . RELATION_TO_NEXT = SPOUSE)

/* Only a SPOUSE can follow a Primary */

then

do; /* check primary preceding and following SPOUSE. */

PRIMARY_RELATION

KEY_PERSON (PRIMARY_INDEX) . RELATION_TO_NEXT

;

NEXT_PRIMARY_RELATION = KEY_PERSON (PRIMARY_INDEX + 2) . RELATION_TO_NEXT

;

if (NEXT_PRIMARY_RELATION = NEPHEW | NEXT_PRIMARY_RELATION = COUSIN | NEXT_PRIMARY_RELATION = NULL_RELATION

)

I (PRIMARY_RELATION = NEPHEW)

I ( ( PRIMARY_RELATION = SIBLING I PRIMARY_RELATION = PARENT)

& (NEXT_PRIMARY_RELATION ~= UNCLE ) ) then /* append following SPOUSE with this combination. */

LATER_KEY_INDEX = LATER_KEY_INDEX + 1; end; /* check primary preceding and following SPOUSE */

end; /* multi-element combination */

call DISPLAY_RELATION (KEY_INDEX, LATER_KEY_INDEX, PRIMARY_INDEX)

;

KEY_INDEX = LATER_KEY_INDEX + 1; end CONSOLIDATE_ADJACENT_PERSONS

;

put skip list (' '

II PERSON (KEY_PERSON (KEY_INDEX) . PERSON_INDEX) . NAME);

/* End execution of RESOLVE PATH_TO_ENGLISH.
e 170

Begin utility procedures for RESOLVE_PATH_TO_ENGLISH. */

FULL_SIBLING: procedure (INDEXl, INDEX2)

returns (bit(l));

/* Determines whether two PERSONS are full siblings, i.e.,

have the same two parents . */

declare

(INDEXl, INDEX2) fixed binary (10,0);

return

((PERSON (INDEXl) . RELATIVE_IDENTIFIER (FATHER_IDENT) ~= NULL_IDENT) & (PERSON (INDEXl) . RELATIVE_IDENTIFIER (MOTHER_IDENT) ~= NULL_IDENT) & (PERSON (INDEXl) . RELATIVE_IDENTIFIER (FATHER_IDENT) = PERSON (INDEX2) . RELATIVE_IDENTIFIER ( FATHER_IDENT) ) &

(PERSON (INDEXl) . RELATIVE_IDENTIFIER (MOTHER_IDENT) = PERSON (INDEX2) . RELATIVE_IDENTIFIER (MOTHER_IDENT) ) );

end FULL_SIBLING;

CONDENSE_KEY_PERSONS: procedure (AT_INDEX, GAP_SIZE);

/* CONDENSE_KEY_PERSONS condenses superfluous entries from the

KEY_PERSON array, starting at AT_INDEX. */

declare

AT_INDEX fixed binary (10,0),

GAP_SIZE fixed binary (10,0);

declare

(RECEIVE_INDEX, SENDJLNDEX) fixed binary (10,0);

/* begin execution of CONDENSE_KEY_PERSONS */

RECEIVE_INDEX = AT_INDEX + 1; SEND_INDEX = RECEIVE_INDEX + GAP_SIZE;

KEY_PERSON (RECEIVE_INDEX) = KEY_PERSON (SEND_INDEX)

;

do while (KEY_PERSON (SEND_INDEX) . RELATION_TO_NEXT ~= NULL_RELATION)

;

RECEIVE_INDEX = RECEIVE_INDEX + 1; SEND_INDEX = RECEIVE_INDEX + GAP_SIZE;

KEY_PERSON (RECEIVE_INDEX) = KEY_PERSON (SEND_INDEX)

;

end;

end CONDENSE KEY PERSONS;

* End utility procedures.
Begin DISPLAY_RELATION, which does major work of displaying

under RESOLVE_PATH_TO_ENGLISH. */

DISPLAY_RELATION: procedure (FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX)

;

/* DISPLAY_RELATION takes 1, 2, or 3 adjacent elements in the

condensed table and generates the English description of

the relation between the first and last + 1 elements. */

declare

(FIRST_INDEX, LAST_INDEX, PRIMARY_INDEX) fixed binary (10,0);

declare

DISPLAYJBUFFER character (80) varying,

INLAW bit (1),

THIS_PROXIMITY character (1),

THIS_GENDER character (1),

SUFFIX_INDICATOR fixed binary (6,0),

(FIRST_RELATION, LAST_RELATI0N, PRIMARY_RELATION)

fixed binary (4,0),

(THIS_GENERATION_GAP, THIS_COUSIN_RANK)

fixed binary (10,0);

/* begin execution of DISPLAY_RELATION */

FIRST_RELATION = KEY_PERS0N (FIRST_INDEX) . RELATI0N_T0_NEXT

;

LAST_RELATI0N = KEY_PERS0N (LAST_INDEX) . RELATI0N_T0_NEXT

;

PRIMARYJRELATION = KEY_PERS0N (PRIMARY_INDEX) . RELATI0N_T0_NEXT

;

/* set THIS_PROXIMITY */

if ((PRIMARY_RELATION = PARENT) & (FIRST_RELATION = SPOUSE)) | ((PRIMARY_RELATION = CHILD) & (LAST_RELATION = SPOUSE))

then

THIS_PROXIMITY = STEP; • else

if PRIMARY_RELATION = SIBLING | PRIMARY_RELATION = UNCLE | PRIMARY_RELATION = NEPHEW | PRIMARY_RELATION = COUSIN

then

THIS_PROXIMITY = KEY_PERSON (PRIMARY_INDEX) . PROXIMITY;

else

THIS_PROXIMITY = FULL;

/* set THIS_GENERATION_GAP */

if PRIMARY_RELATION = PARENT | PRIMARY_RELATION = CHILD | PRIMARY_RELATION = UNCLE | PRIMARY_RELATION = NEPHEW | PRIMARY_RELATION = COUSIN

then

THIS_GENERATION_GAP = KEYJPERSON (PRIMARY_INDEX) . GENERATION_GAP

else

THIS GENERATION GAP = 0;
Page 172

/* set INLAW */

INLAW = FALSE;

if (FIRST_RELATION = SPOUSE) & (PRIMARY_RELATION = SIBLING I PRIMARY_RELATION = CHILD I PRIMARY_RELATION = NEPHEW | PRIMARY_RELATION = COUSIN)

then

INLAW = TRUE;

if (LAST_RELATION = SPOUSE) & (PRIMARY_RELATION = SIBLING | PRIMARY_RELATION = PARENT | PRIMARY_RELATION = UNCLE | PRIMARY_RELATION = COUSIN)

then

INLAW = TRUE;

/* set THIS_COUSIN_RANK */

If PRIMARY_RELATION = COUSIN then

THIS_COUSIN_RANK = KEY_PERSON (PRIMARY_INDEX) . COUSIN_RANK;

else

THIS_COUSIN_RANK = 0;

/* parameters are set - now generate display. */

DISPLAY BUFFER =

' ' Tl PERSON (KEY_PERSON (FIRST_INDEX) . PERSON_INDEX) . NAME || ' is '; if PRIMARY_RELATION = PARENT | PRIMARY_RELATION = CHILD | PRIMARY_RELATION = UNCLE | PRIMARY_RELATION = NEPHEW

then

do; /* write generation-qualifier */

if THIS_GENERATION_GAP >= 3 then

do

;

DISPLAY_BUFFER = DISPLAY_BUFFER || 'great';

if THIS_GENERATION_GAP > 3 then

DISPLAY_BUFFER = DISPLAY_BUFFER | | '*' |

|

TRIM (THIS_GENERATION_GAP - 2);

DISPLAY_BUFFER = DISPLAYJBUFFER ||

'-';

end;

if THIS_GENERATION_GAP >= 2 then

DISPLAY_BUFFER = DISPLAY_BUFFER || 'grand-';

end;

else

if (PRIMARY_RELATION = COUSIN) & (THIS_COUSIN_RANK > 1) then

do

;

DISPLAY_BUFFER = DISPLAYJBUFFER || TRIM (THIS_COUSIN_RANK)

;

SUFFIX_INDICATOR = mod (THIS_COUSIN_RANK, 10);

if SUFFIX_INDICATOR > 3 then

SUFFIX_INDICATOR =0;

DISPLAYJBUFFER = DISPLAY_BUFFER |

|

substr ('th St nd rd ', 3 * SUFFIX_INDICATOR + 1, 3);

end;

\
Page 173

if THIS_PROXIMITY = STEP then

DISPLAY_BUFFEPv = DISPLAYJBUFFER || 'step-';

else

If THISJPROXIMITY = HALF then

DISPLAY BUFFER = DISPLAY BUFFER || 'half-'

THIS_GENDER = PERSON (KEY_PERSON (FIRST_INDEX)

if PRIMARY_RELATION = PARENT then

if THIS_GENDER = MALE then DISPLAY_BUFFER = else DISPLAYJBUFFER = else if PRIMARY RELATION = CHILD then

. PERSON INDEX) . GENDER;

if THIS_GENDER = MALE

else

then DISPLAY_BUFFER

DISPLAY BUFFER

else if PRIMARY RELATION = SPOUSE then

MALE then DISPLAY_BUFFER

DISPLAY BUFFER

if THIS_GENDER

else _

else if PRIMARY_RELATION = SIBLING then

if THIS_GENDER = MALE then DISPLAYJBUFFER

else DISPLAYJBUFFER

else if PRIMARYJIELATION = UNCLE then

if THISJSENDER = MALE then DISPLAY_BUFFER

else DISPLAY_BUFFER

else if PRIMARYJIELATION = NEPHEW then

if THISJ3ENDER = MALE then DISPLAY_BUFFER

else DISPLAY_BUFFER

else if PRIMARYJIELATION = COUSIN then

DISPLAYJBUFFER

else

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAY_BUFFER

DISPLAYJBUFFER

DISPLAY BUFFER _ DISPLAY_BUFFER

DISPLAY BUFFER = DISPLAY BUFFER

'father'

;

'mother'

;

' son'

;

'daughter'

;

'husband'

;

'wif e'

;

'brother'

;

'sister'

;

'uncle'

;

'aunt'

;

'nephew'

;

'niece'

;

'cousin'

;

'null'

;

if INLAW then

DISPLAYJBUFFER = DISPLAY_BUFFER || '-in-law';

if (PRIMARY_RELATION = COUSIN) & (THIS_GENERATION_GAP > 0) then

if THISJ3ENERATIONJ3AP > 1 then

DISPLAYJBUFFER = DISPLAYJBUFFER |

| ' '

I I TRIM (THISJ3ENERATIONJ3AP) il ' times removed';

else

DISPLAY BUFFER = DISPLAY BUFFER || ' once removed';

DISPLAY_BUFFER = DISPLAYJBUFFER || ' of;

put skip list (DISPLAY_BUFFER);
Page 174

/* Begin utility procedure for DISPLAY_RELATION */

TRIM: procedure (NUMERIC_VALUE) returns (character (20) varying);

/* Returns character representation of numeric values

with no leading or trailing spaces. */

declare

NUMERIC_VALUE fixed binary (10,0);

declare

STRING_REPRESENTATION character (20),

(START_LOCATION, STOP_LOCATION)

fixed binary (10,0);

/* Begin execution of TRIM */

STRING_REPRESENTATION = NUMERIC_VALUE

;

do START_L0CATI0N = 1 to 20

while (substr (STRING_REPRESENTATION, START_L0CATI0N, 1) = ' ');

end;

do ST0P_L0CATI0N = 20 to 1 by -1

while (substr (STRING_REPRESENTATION, ST0P_L0CATI0N, 1) = ' ');

end;

' return (substr (STRING_REPRESENTATION, START_L0CATI0N,

ST0P_L0CATI0N - STARTJLOCATION +1));

end TRIM;

end DISPLAY_RELATION;

end RE SOLVE_PATH_T0_ENGLI SH

;

/* C0MPUTE_C0MM0N_GENES is second major procedure (after

RESOLVE_PATH_TO_ENGLISH) under FIND_RELATIONSHIP. */

COMPUTE_COMMON_GENES: procedure (INDEXl, INDEX2);

/* COMPUTE_COMMON_GENES assumes that each ancestor contributes

half of the genetic material to a PERSON. It finds common

ancestors between two PERSONS and computes the expected

value of the PROPORTION of common material. */

declare

(INDEXl, INDEX2) fixed binary (10,0);

declare

C0MM0N_PR0P0RTI0N float decimal (6);

/* begin execution of C0MPUTE_C0MM0N_GENES */

/* First zero out all ancestors to allow adding. This is necessary

because there might be two paths to an ancestor. */

call ZERO_PROPORTION (INDEXl);

/* now mark with shared PROPORTION */

call MARK_PROPORTION (PERSON (INDEXl) . IDENTIFIER, 1.0, INDEXl);

COMMON_PRO PORTION =0.0;

call CHECK_COMMON_PROPORTION (COMMONJPROPORTION,

PERSON (INDEXl) . IDENTIFIER, 1.0, 0.0, INDEX2 )

;

put skip list (' Proportion of common genetic material = ');

put edit (C0MM0N_PR0 PORTION) (e(13,5,6));

/* End execution of COMPUTE COMMON GENES.
Page 175

Begin utility procedures. */

ZERO_PROPORTION: procedure (ZERO_INDEX) recursive;

/* ZERO_PROPORTION recursively seeks out all ancestors and zeros them out. */

declare

ZERO_INDEX fixed binary (10,0),

THIS_NEIGHBOR pointer;

/* begin execution of ZERO_PROPORTION */

PERSON (ZERO_INDEX) . DESCENDANT_GENES = 0.0;

THIS_NEIGHB0R = PERSON (ZERO_INDEX) . NEIGHBOR_LIST_HEADER

;

do while (THIS_NEIGHBOR ~= null());

if THIS_NEIGHBOR -> NEIGHBOR_EDGE = PARENT then

call ZERO_PRO PORTION (THIS_NEIGHBOR -> NEIGHBOR_INDEX)

;

THISJJEIGHBOR = THIS_NEIGHBOR -> NEXTJJEIGHBOR;

end;

end ZERO_PROPORTION;

MARKPROPORTION: procedure (MARKER, PROPORTION, MARKED_INDEX) recursive;

/* MARK_PROPORTION recursively seeks out all ancestors and

marks them with the sender's PROPORTION of shared

genetic material. This PROPORTION is diluted by one-half

for each generation. */

declare

MARKER picture '999',

PROPORTION float decimal (6),

MARKED_INDEX fixed binary (10,0),

THIS_NEIGHBOR pointer

;

/* begin execution of MARK_PROPORTION */

PERSON (MARKED_INDEX) . DESCENDANT_IDENTIFIER = MARKER;

PERSON (MARKED_INDEX) . DESCENDANT_GENES

PERSON (MARKED_INDEX) . DESCENDANT_GENES + PROPORTION;

THISJJEIGHBOR = PERSON (MARKED_INDEX) . NEIGHBOR_LIST_HEADER;

do while (THIS_NEIGHBOR ~= null());

if THIS_NEIGHBOR -> NEIGHBOR_EDGE = PARENT then

call MARK_PROPORTION (MARKER, PROPORTION / 2.0,

THISJJEIGHBOR -> NEIGHBOR_INDEX)

;

THIS_NEIGHBOR = THISJJEIGHBOR -> NEXTJJEIGHBOR;

end;

end MARK PROPORTION;
Page 176

CHECK_COMMON_PROPORTION: procedure

(COMMON_PROPORTION, MATCH_IDENTIFIER, PROPORTION,

ALREADY_COUNTED, CHECK_INDEX) recursive;

/* CHECK_COMMON_PROPORTION searches all the ancestors of

CHECK_INDEX to see if any have been marked, and if so adds The appropriate amount to COMMON_PROPORTION. */

declare

COMMON_PROPORTION float decimal (6),

MATCH_IDENTIFIER picture '999',

PROPORTION float decimal (6),

ALREADY_COUNTED float decimal (6),

CHECK_INDEX fixed binary (10,0),

THIS_NEIGHBOR pointer,

THIS_CONTRIBUTION float decimal (6);

/* begin execution of CHECK_COMMON_PROPORTION */

if PERSON (CHECK_INDEX) . DESCENDANT_IDENTIFIER = MATCH_IDENTIFIER then

/* Increment COMMON_PROPORTION by the contribution of

this common ancestor, but discount for the contribution

of less remote ancestors already counted. */

do

;

THIS_CONTRIBUTION = PERSON (CHECK_INDEX) . DESCENDANT_GENES

* PROPORTION;

COMMON_PROPORTION = COMMON_PROPORTION

+ THISJGONTRIBUTION - ALREADY_COUNTED;

end;

else

THISJGONTRIBUTION = 0.0;

THIS_NEIGHBOR = PERSON (CHECK_INDEX) . NEIGHBOR_LIST_HEADER;

do while (THIS_NEIGHBOR ~= null());

if THIS_NEIGHBOR -> NEIGHBOR_EDGE = PARENT then

call CHECK_COMMON_PROPORTION (COMMON_PRO PORTION,

MATCH_IDENTIFIER, PROPORTION / 2.0,

THISJGONTRIBUTION / 4.0,

THISJJEIGHBOR -> NEIGHBOR_INDEX)

;

THIS_NEIGHBOR = THIS_NEIGHBOR -> NEXT_NEIGHBOR;

end;

end CHECKjGOMMON_PROPORTION;

end COMPUTEjGOMMON_GENES

;

end FIND RELATIONSHIP;

end RELATE;
NBS-n4A iREv. 2-8C) U.S. DEPT. OF COMM. BIBLIOGRAPHIC DATA

SHEET (See instructions)

1. PUBLICATION OR

REPORT NO

NBS/SP-500-117/2

2. Performing Organ. Report No . 3. Publ ication Dare

October 1984

4. TITLE AND SUBTITLE ^ 4. r • -r , . Lomputer Science and Technology:

Selection and Use of General-Purpose Programming Languages--Program Examples

5. AUTHOR(S)

John V. Cugini

6. PERFORMING ORGANIZATION (If joint or other than NBS, see in struction sj

NATIONAL BUREAU OF STANDARDS

DEPARTMENT OF COMMERCE

GAITHERSBURG, MD 20899

7. Contract/Grant No.

8. Type of Report & Period Covered

Fi nal

9. SPONSORING ORGANIZATION NAME AND COMPLETE ADDRESS (Street. City. State. ZIP)

Same as in item 6 above.

10. SUPPLEMENTARY NOTES

Library of Congress Catalog Card Number: 84-601120

[^J Document describes a computer program; SF-185, FlPS Software Summary, is attached.

11. ABSTRACT (A 200-word or /ess factual summary of most si gnificant information. If document includes a significant

bi bliography or literature survey, mention it here) Programming languages have been and will continue to be an important instrument

for the automation of a wide variety of functions within industry and the Federal

Government. Other instruments, such as program generators, application packages,

query languages, and the like, are also available and their use is preferable in some circumstances.

Given that conventional programming is the appropriate technique for a particular application, the choice among the various languages becomes an important issue.

There are a great number of selection criteria, not all of which depend directly on the language itself. Broadly speaking, the criteria are based on 1) the language

and its implementation, 2) the application to be programmed, and 3) the user's

existing facilities and software.

This study presents a survey of selection factors for the major general -purpose

languages: Ada, BASIC, C, COBOL, FORTRAN, Pascal, and PL/I. The factors covered

include not only the logical operations within each language, but also the advantages

and disadvantages stemming from the current computing environment, e.g

packages, microcomputers, and standards. The criteria associated with

tion and the user's facilities are explained. Finally, there is a set

examples to illustrate the features of the various languages.

This volume includes the program examples. Volume 1 contains the discussion of

li^nguagp t;p1prtinn rritpri;^ . _

12. KEY WORDS (Six to twelve entries; alphabetical order; capitalize only proper names; and separate key words by semicolon s/ Ada; alternatives to programming; BASIC; C; COBOL; FORTRAN; Pascal; PL/I; programming 1 anguage features ; programming languages; selection of programming language.

software

the applicaof program

13. AVAILABILITY

[]X] U n I i m i ted gFor Official Distribution. Do Not Release to NTIS

Order From Superintendent of Documents, U.S. Government Printing Office, Washington, D.C

20402. Q Order From National Technical Information Service (NTIS), Springfield, VA. 22161

14. NO. OF

PRINTED PAGES

178

15. Price

USCOMM-DC 6043-P80

ANNOUNCEMENT OF NEW PUBLICATIONS ON

COMPUTER SCIENCE & TECHNOLOGY

Superintendent of Documents,

Government Printing Office,

Washington, DC 20402

Dear Sir:

Please add my name to the announcement list of new publications to be issued in the

series: National Bureau of Standards Special Publication 500-.

N,ame Company

Address

City State Zip Code

(Notification key N-S03)

•U.S. GOVERNMENT PRINTING OFFICE 1984 0-461-105/10087

I Technical Publications

Periodicals

Journal of Research—The Journal of Research of the National Bureau of Standards reports NBS research and development in those disciplines of the physical and engineering sciences in which the Bureau is active. These include physics, chemistry, engineering, mathematics, and computer sciences. Papers cover a broad

range of subjects, with major emphasis on measurement methodology and the basic technology underlying

standardization. Also included from time to time are survey articles on topics closely related to the Bureau's

technical and scientific programs. As a special service to subscribers each issue contains complete citations to

all recent Bureau publications in both NBS and non-NBS media. Issued six times a year.

Nonperiodiccds

Monographs—Major contributions to the technical literature on various subjects related to the Bureau's scientific and technical activities. Handbooks—Recommended codes of engineering and industrial practice (including safety codes) developed in cooperation with interested industries, professional organizations, and regulatory bodies.

Special Publications—Include proceedings of conferences sponsored by NBS, NBS annual reports, and other

special publications appropriate to this grouping such as wall charts, pocket cards, and bibliographies.

Applied Mathematics Series—Mathematical tables, manuals, and studies of special interest to physicists,

engineers, chemists, biologists, mathematicians, computer programmers, and others engaged in scientific and

technical work.

National Standard Reference Data Series—Provides quantitative data on the physical and chemical properties

of materials, compiled from the world's literature and critically evaluated. Developed under a worldwide pro- gram coordinated by NBS under the authority of the National Standard Data Act (Public Law 90-396).

NOTE: The Journal of Physical and Chemical Reference Data (JPCRD) is published quarterly for NBS by

the American Chemical Society (ACS) and the American Institute of Physics (AIP). Subscriptions, reprints,

and supplements are available from ACS, 1155 Sixteenth St., NW, Washington, DC 20056.

Building Science Series—Disseminates technical information developed at the Bureau on building materials,

components, systems, and whole structures. The series presents research results, test methods, and perfor- mance criteria related to the structural and environmental functions and the durability and safety

characteristics of building elements and systems.

Technical Notes—Studies or reports which are complete in themselves but restrictive in their treatment of a

subject. Analogous to monographs but not so comprehensive in scope or definitive in treatment of the subject

area. Often serve as a vehicle for final reports of work performed at NBS under the sponsorship of other government agencies.

Voluntary Product Standards—Developed under procedures published by the Department of Commerce in Part 10, Title 15, of the Code of Federal Regulations. The standards establish nationally recognized re- quirements for products, and provide all concerned interests with a basis for common understanding of the

characteristics of the products. NBS administers this program as a supplement to the activities of the private sector standardizing organizations.

Consumer Information Series—Practical information, based on NBS research and experience, covering areas of interest to the consumer. Easily understandable language and illustrations provide useful background

knowledge for shopping in today's technological marketplace.

Order the above NBS publications from: Superintendent of Documents, Government Printing Office,

Washington, DC 20402. Order the following NBS publications—FIPS and NBSIR 's—from the National Technical Information Service, Springfield, VA 22161.

Federal Information Processing Standards Publications (FIPS PUB)—Publications in this series collectively constitute the Federal Information Processing Standards Register. The Register serves as the official source of

information in the Federal Government regarding standards issued by NBS pursuant to the Federal Property

and Administrative Services Act of 1949 as amended. Public Law 89-306 (79 Stat. 1127), and as implemented

by Executive Order 11717 (38 FR 12315, dated May II, 1973) and Part 6 of Title 15 CFR (Code of Federal

Regulations).

NBS Interagency Reports (NBSIR)—A special series of interim or final reports on work performed by NBS

for outside sponsors (both government and non-government). In general, initial distribution is handled by the sponsor; public distribution is by the National Technical Information Service, Springfield, VA 22161, in paper copy or microfiche form.
U.S. Department of Commerce

National Bureau of Standards

Gaithersburg, MD 20899

Official Business

Penalty for Private Use $300