File: cousins.ll

package info (click to toggle)
lifelines 3.0.50-2
  • links: PTS
  • area: main
  • in suites: etch-m68k
  • size: 11,140 kB
  • ctags: 6,517
  • sloc: ansic: 57,468; xml: 8,014; sh: 4,255; makefile: 848; yacc: 601; perl: 170; sed: 16
file content (442 lines) | stat: -rw-r--r-- 13,595 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
/*
 * @progname       cousins.ll
 * @version        6.0
 * @author         Wetmore
 * @category       
 * @output         Text
 * @description    

  Finds the relationship between two persons in a
  LifeLines database.   If there is no common ancestor, the program
  will attempt to find a sequence of genetic relations that link the two
  persons.

  In the cases where the two persons are
  genetically related (have a common ancestor), the program will
  find and display the relationship.  If the two persons are not
  genetically related, the program will attempt to discover a
  sequence of genetic relationships that link the two persons.
  For example, the program will display the relationship between
  your two grandmothers as a sequence of two genetic relations with
  a grandchild as the link between.  Note that two persons may be
  related to each other in many ways; this program finds only the
  shortest one (or ones if there are different, equally short paths).

  This program requires version 3 of LifeLines.

author -- Tom Wetmore, ttw@beltway.att.com

version history
  1 - 08 Sep 1993 -- modified from the relate program
  2 - 08 Sep 1993 -- fixed niece/nephew bug
  3 - 09 Sep 1993 -- extensive modification
  4 - 13 Aug 1994 -- more modifications
  5 - 2 Mar 1995 -- check for direct descendants first.  Chris Bone
  6 - 2 Mar 1995 -- Neater cousin removes, find all short paths.  J.F. Chandler
*/

global(links)   /* table of links back one person */
global(rels)    /* table showing direction of the links */
global(klist)   /* list of found persons not linked back to yet */
global(numb)    /* number of persons considered so far */

/*======================================================================
 * notes on global data structures --
 *   o links -- implements the function link(key1) --> key2, where key1
 *     is the key of a person, and key2 is the key of the person that
 *     person key1 links back to
 *   o rels -- implements the function rels(key1) --> dir, where key1 is
 *     the key of a person, and dir is the relationship direction (up or
 *     down) between this person and person link(key1)
 *=====================================================================*/

/*=====================================================================
 * main -- Get the user to identify two persons; if all goes well, call
 *   relate to do the hard stuff.
 *===================================================================*/
proc main ()
{
	print("This program finds the relationship between two persons.\n\n")
	getindimsg(from, "Please identify the first person.")
	set(to, 0)
	if (from) {
		getindimsg(to, "Please identify the second person.")
	}
	if (and(from, to)) {
		print("Searching for relationships between:\n\t")
		print(name(from), " and ", name(to))
		print(".\n\nThis may take a while -- ")
		print("each dot is 25 persons considered.\n")
		set(fkey, save(key(from)))
		set(tkey, save(key(to)))
		call relate(tkey, fkey)
	} else {
		print("Please call again.\n")
	}
}

/*======================================================================
 * relate -- Attempt to find a relationship between two persons by
 *   constructing a path of parent and/or child links between them; if a
 *   path is found, call foundpath to display the results; else report
 *   that there is no relation between the persons.
 *====================================================================*/
proc relate (fkey, tkey)
{
	table(links)	/* table of links back one person */
	table(rels)
	list(klist)	/* keys of persons not linked back to yet */

	set(up, 1)
	set(down, neg(1))
	set(numb, 0)
	set(pathlength, 0)
	set(toolong, 0)
	set(found, 0)

/* Link the first person to him/herself with no direction, and make
   him/her the first entry in the list of unlinked back to persons.
   A "zero" person in the list marks the start of next-longer paths. */

	insert(links, fkey, fkey)
	insert(rels, fkey, 0)
	enqueue(klist, fkey)
	enqueue(klist, 0)

/* Iterate through the list of unlinked back to persons; remove them one by
   one; link their parents and children back to them; add their parents and
   children to the unlinked back to list; check each iteration to see if
   one of the new parents or children is the searched for person; if so
   quit the iteration and call foundpath; else continue iterating. */

	while ( gt(length(klist),1) ) {
		set(key, dequeue(klist))
		if(not(key)) {
			set(pathlength, add(1,pathlength))
			if(eq(pathlength,toolong)) { break() }
			enqueue(klist, 0)
			continue()
		}
		set(indi, indi(key))
		set(dir, lookup(rels, key))
		call include(key, father(indi), down)
		call include(key, mother(indi), down)
		families(indi, fam, spouse, num1) {
			children(fam, child, num2) {
				call include(key, child, up)
			}
		}
		if (key, lookup(links, tkey)) {
			if(found) {
				"\n\nAlternate relationship"
			} else {
				"Relationship from " name(indi(tkey))
				" to " name(indi(fkey))
			}
			":\n"
			set(found, 1)
			call foundpath(tkey)
			call fullpath(tkey)
			set(toolong, add(1,pathlength))
			insert(links, tkey, 0)
		}
	}

/* Check to see if there is no relation between the persons, and if there
   is none let the user know and quit. */

	if (not(found)) {
		print("\nThey are not blood-related to one another.")
		"They are not blood-related to one another."
	}
}

/*=========================================================================
 * include -- Links a newly discovered person (indi) back to another person
 *   (key), with a specified direction (rel); the new person is then put on
 *   the list of unlinked back to persons.
 *=======================================================================*/
proc include (key, indi, rel)
{
/* Only include the person if he/she has not been found before. */

	if (and(indi, not(lookup(links, key(indi))))) {

/* Keep user happy watching those dots! */

		set(numb, add(numb, 1))
		if (eq(0, mod(numb, 25))) {
			print(".")
		}

/* Update the data structures. */

		set(new, save(key(indi)))
		insert(links, new, key)
		insert(rels, new, rel)
		enqueue(klist, new)
	}
}

/*=================================================================
 * foundpath -- Show the relationship path between the two persons.
 *===============================================================*/
proc foundpath (key)
{
	print("\n") "\n"
	list(nexkeys)
	list(nexlens)

/* Init the nexus person from the first (to) person. */

	set(nexus, key)
	set(dir, lookup(rels, key))
	set(len, dir)
	set(again, 1)

/* Create the nexus list, the list of persons where relationships change
   direction; a nexus person is either the first person, the last person,
   or the common ancestor or descendent of two other nexus persons. */

	while (again) {

/* Get the next person from the path. */

		set(key, lookup(links, key))
		set(rel, lookup(rels, key))

/* If the new person's direction is 0 this is the last person in the path
   (the from person) so add the current nexus person and the last person
   to the nexus list and quit the loop */

		if (eq(0, rel)) {
			enqueue(nexkeys, nexus)
			enqueue(nexlens, len)
			enqueue(nexkeys, key)
			enqueue(nexlens, 0)
			set(again, 0)

/* if new person changes direction, add the current nexus person to the
   nexus list, and make the new person the new current nexus person */

		} elsif (ne(rel, dir)) {
			enqueue(nexkeys, nexus)
			enqueue(nexlens, len)
			set(nexus, key)
			set(dir, rel)
			set(len, rel)

/* if the new person continues in the same direction, record the step */

		} else {
			set(len, add(len, rel))
		}
	}

	set(one, dequeue(nexkeys))
	set(len, dequeue(nexlens))
	set(again, 1)

/* step down the nexus list, computing and displaying the relationships
   between either two nexus persons (where it is appropriate to show pure
   ancestry or descendency) or three nexus persons (where it is appropriate
   to show two nexus persons as cousins with their common ancestor) */

	while (and(again, length(nexkeys))) {
		set(llen, length(nexkeys))

/* If the initial direction is down, show first nexus person as a simple
   ancestor of the second nexus person; this condition can only be true
   in the first iteration */

		if (lt(len, 0)) {
			set(two, dequeue(nexkeys))
			set(new, dequeue(nexlens))
			call showancs(one, two, neg(len))
			set(one, two)
			set(len, new)

/* If the direction is up, there are two subcases: */

		} elsif (gt(len, 0)) {

/* If the nexus list has only one remaining entry then show the (last-1)th
   nexus person as a simple descendent of the last nexus person */

			if (eq(1, llen)) {
				set(two, dequeue(nexkeys))
				set(new, dequeue(nexlens))
				call showdesc(one, two, len)
				set(again, 0)

/* If the nexus list has more than one remaining entry then show the
   current nexus person and the next two as two "cousins" with an
   intervening common ancestor, and make the last of the three persons the
   current nexus person for the next loop iteration */

			} else {
				set(two, dequeue(nexkeys))
				set(tmp, dequeue(nexlens))
				set(three, dequeue(nexkeys))
				set(new, dequeue(nexlens))
				call showcous(one, two, three, len, neg(tmp))
				set(one, three)
				set(len, new)
			}

/* This is the special case where a person is related to him/herself. */

		} else {
			print("They're the same person.\n")
			"They're the same person.\n"
			set(again, 0)
		}
	}
}

/*=================================================
 * showancs -- Show a direct ancestry relationship.
 *==============================================*/
proc showancs (one, two, len)
{
	set(indi, indi(one))
	if (male(indi))	     { set(pword, "father ") }
	elsif (female(indi)) { set(pword, "mother ") }
	else		     { set(pword, "parent ") }
	if (eq(1, len))	     { set(aword, "the ") }
	else		     { set(aword, "a ") }

	print(name(indi), " is ", aword)
	name(indi) " is " aword
	if (eq(2, len))	   { print("grand") "grand" }
	elsif (eq(3, len)) { print("great grand") "great grand" }
	elsif (lt(3, len)) {
		print("great(", d(sub(len, 2)), ") grand")
		"great(" d(sub(len, 2)) ") grand"
	}
	print(pword, "of\n  ", name(indi(two)), ".\n")
	pword "of\n  " name(indi(two)) ".\n"
}

/*====================================================
 * showdesc -- Show a direct descendency relationship.
 *==================================================*/
proc showdesc (one, two, len)
{
	set(indi, indi(one))
	if (male(indi))	     { set(pword, "son ") }
	elsif (female(indi)) { set(pword, "daughter ") }
	else		     { set(pword, "child ") }

	print(name(indi), " is a ")
	name(indi) " is a "
	if (eq(2, len))	   { print("grand") "grand" }
	elsif (eq(3, len)) { print("great grand") "great grand" }
	elsif (lt(3, len)) {
		print("great(", d(sub(len, 2)), ") grand")
		"great(" d(sub(len, 2)) ") grand"
	}
	print(pword, "of\n  ", name(indi(two)), ".\n")
	pword "of\n  " name(indi(two)) ".\n"
}

/*=========================================================================
 * showcous -- Show a cousin relationship; for the purposes of this
 *   program, siblings, uncles, aunts, nieces and nephews are considered to
 *   be special cases of cousins.
 *=======================================================================*/
proc showcous (one, two, three, up, down)
{
	set(indi, indi(one))
	if (male(indi)) {
		set(sword, " brother ")
		set(nword, " nephew ")
		set(uword, " uncle ")
	} elsif (female(indi)) {
		set(sword, " sister ")
		set(nword, " niece ")
		set(uword, " aunt ")
	} else {
		set(sword, " sibling ")
		set(nword, " niece or nephew ")
		set(uword, " uncle or aunt ")
	}
	print(name(indi(one)), " is a")
	name(indi(one)) " is a"
	if (and(eq(up,1), eq(down, 1))) {	/* sibling cases */
		print(sword, "of")
		sword "of"
	} elsif (eq(up, 1)) {			/* uncle/aunt cases */
		if (eq(down, 2)) {
			print("n", uword, "of")
			"n" uword "of"
		} elsif (eq(down, 3)) {
			print(" great", uword, "of")
			" great" uword "of"
		} else {
			print(" great(", d(sub(down, 2)), ")", uword, "of")
			" great(" d(sub(down, 2)) ")" uword "of"
		}
	} elsif (eq(down, 1)) {			/* niece/nephew cases */
		if (eq(up, 2)) {
			print(nword, "of")
			nword "of"
		} elsif (eq(up, 3)) {
			print(" great", nword, "of")
			" great" nword "of"
		} else {
			print(" great(", d(sub(up, 2)), ")", nword, "of")
			" great(" d(sub(up, 2)) ")" nword "of"
		}
	} else {				/* cousin cases */
		if (gt(up, down)) {
			set(gen, down)
			set(rem, sub(up, down))
		} else {
			set(gen, up)
			set(rem, sub(down, up))
		}
		print(" ", ord(sub(gen,1)), " cousin ")
		" " ord(sub(gen,1)) " cousin "
		if (ne(rem, 0)) {
			if (eq(rem,1)) {print("once") "once"}
			elsif (eq(rem,2)) {print("twice") "twice"}
			elsif (eq(rem,3)) {print("thrice") "thrice"}
			else {
				print(card(rem), " times")
				card(rem) " times" }
			print(" removed ") " removed "
		}
		print("of") "of"
	}
	print("\n  ", name(indi(three)))
	"\n  " name(indi(three))
	print(", through their ancestor,\n  ", name(indi(two)), ".\n")
	", through their ancestor,\n  " name(indi(two)) ".\n"
}

/*=======================================================================
 * fullpath -- Show full path between the two persons.
 *======================================================================*/
proc fullpath (key)
{
	"\nThe full relationship path between them is:\n\n"
	set(again, 1)
	while (again) {
		name(indi(key))
		set(new, lookup(links, key))
		set(dir, lookup(rels, key))
		if (gt(dir, 0)) {
			" is the child of"
		}
		if (lt(dir, 0)) {
			" is the parent of"
		}
		"\n"
		if (eq(0, strcmp(key, new))) {
			set(again, 0)
		} else {
			set(key, new)
		}
	}
}