View this PageEdit this PageAttachments to this PageHistory of this PageHomeRecent ChangesSearch the SwikiHelp Guide
Hotspots: Admin Pages | Turn-in Site |
Current Links: Cases Final Project Summer 2007

M5 Code

Object subclass: #AutoCompleter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AutoCompleter class
	instanceVariableNames: ''!

!AutoCompleter class methodsFor: 'as yet unclassified'!
fillPersonInfo: t1 
	| t2 t3 t4 t5 t6 t7 t8 t9 |
	t3 _ String new.
	t3 _ t3 , 'http://worldconnect.rootsweb.com/cgi-bin/igm.cgi?father='.
	t3 _ t3
				, [t1 getFather isNil
						ifFalse: [t1 getFather getGivenName , '+' , t1 getFather getSurName]].
	t3 _ t3 , '&given='.
	t3 _ t3 , t1 getGivenName.
	t3 _ t3 , '&surname='.
	t3 _ t3 , t1 getSurName.
	t3 _ t3 , '&stype=Exact&mother='.
	t3 _ t3
				, [t1 getMother isNil
						ifFalse: [t1 getMother getGivenName , '+' , t1 getMother getSurName]].
	t3 _ t3 , '&dyear='.
	t3 _ t3
				, [t1 getDeathDate isNil
						ifFalse: [t1 getDeathDate]].
	t4 _ t3 asUrl retrieveContents content.
	t5 _ HtmlParser parse: t4.
	t7 _ OrderedCollection new.
	t2 _ OrderedCollection new.
	t5
		allSubentitiesDo: [:t10 | (t10 tagName = 'table'
					and: [(t10 getAttribute: 'cellspacing')
							= '0']
					and: [(t10 getAttribute: 'border')
							= '1'])
				ifTrue: [t10
						allSubentitiesDo: [:t11 | t11 isTableDataItem
								ifTrue: [t11
										allSubentitiesDo: [:t12 | t7 add: t12 textualContents]]]]].
	t8 _ 1.
	[[t8 < t7 size]
		whileTrue: [((t7 at: t8) asString asLowercase beginsWith: t1 getSurname asString asLowercase)
				ifTrue: [t6 _ OrderedCollection new.
					(t7 at: t8 + 2) size < 6
						ifTrue: [t6 add: nil]
						ifFalse: [t6 add: (t7 at: t8 + 2) asDate].
					(t7 at: t8 + 3) size < 2
						ifTrue: [t6 add: nil]
						ifFalse: [t6 add: (t7 at: t8 + 3) asString].
					(t7 at: t8 + 4) size < 6
						ifTrue: [t6 add: nil]
						ifFalse: [t6 add: (t7 at: t8 + 4) asDate].
					(t7 at: t8 + 5) size < 2
						ifTrue: [t6 add: nil]
						ifFalse: [t6 add: (t7 at: t8 + 5) asString].
					t9 _ t8.
					[(t7 at: t9)
						= 'Father: ']
						whileFalse: [t9 _ t9 + 1].
					(t7 at: t9 + 1) size < 2
						ifTrue: [t6 add: nil]
						ifFalse: [t6 add: (t7 at: t9 + 1) asString].
					(t7 at: t9 + 4) size < 2
						ifTrue: [t6 add: nil]
						ifFalse: [t6 add: (t7 at: t9 + 4) asString].
					t2 add: t6.
					t8 _ t8 + 1].
			t8 _ t8 + 1].
	nil]
		on: MessageNotUnderstood , Error
		do: [:t13 | Transcript show: t13 description;
				 cr].
	^ t2! !


Object subclass: #Conflict
	instanceVariableNames: ''
	classVariableNames: 'MasterList2 '
	poolDictionaries: ''
	category: 'Geneology'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Conflict class
	instanceVariableNames: ''!

!Conflict class methodsFor: 'initializers' stamp: 'JW 10/22/2002 00:37'!
new
	"initializer"
MasterList2 _ (OrderedCollection new: 1).! !


!Conflict class methodsFor: 'printing' stamp: 'AWP 11/3/2002 22:59'!
printMyself
	"this method prints out all of the errors for all of the people in MasterList2"
| index |
index _ MasterList2 size.
1 to: index do: [:i | (MasterList2 at: i) printConflictList].
Transcript show: 'End of Conflict Report' ; cr.! !

!Conflict class methodsFor: 'printing' stamp: 'AWP 11/3/2002 19:58'!
sendBlock
	"this method returns the block of code that Traversal will ned to run on each person"
^[:myPerson |
MasterList2 add: myPerson.
myPerson setConflictList:(OrderedCollection new).

((myPerson getBirthDate) notNil and: [(myPerson getDeathDate) notNil]) ifTrue: [((myPerson getBirthDate) > (myPerson getDeathDate)) ifTrue: [(myPerson getConflictList) add: ('death date before birth date')]].

(myPerson getMarriages) notNil ifTrue:
[
(myPerson getMarriages) do: 
[:aMarriage | 
	(aMarriage getDate isNil)
	ifFalse:[((aMarriage getDate < myPerson getBirthDate) or: [(aMarriage getDate > myPerson getDeathDate)]) ifTrue: [(myPerson getConflictList) add: 'marriage date not between birth and death date']].]
].


(myPerson getGender = 'female') ifTrue:[(myPerson getChildren) do:
[:aChild | (aChild getBirthDate < myPerson getDeathDate) ifTrue: [(myPerson getConflictList) add: ('Mother died before my child''s birth')]]].

(myPerson getGender = 'male') ifTrue:[(myPerson getChildren) do:
[:aChild |	
((aChild getBirthDate) notNil and: [(myPerson getDeathDate) notNil]) ifTrue: 
[
	((aChild getBirthDate) < ((myPerson getDeathDate) subtractDays: 270)) ifTrue: 
	[
		(myPerson getConflictList) add: ('Father died more than 9 months before child''s birth')]
	]
]
].

((myPerson getFather) notNil and: [(myPerson getMother) notNil]) ifTrue:
[
(((myPerson getFather) getGender = 'male') and: [((myPerson getMother) getGender = 'female')]) ifFalse: [(myPerson getConflictList) add: ('Parents of same gender not allowed')].
].

(myPerson getSiblings) do:
[:aSibling | 
(((aSibling getFather) notNil and: [(myPerson getFather) notNil]) 
and: [(aSibling getMother) notNil and: [(myPerson getMother) notNil]])
ifTrue: 
[
	((aSibling getFather = myPerson getFather) and: [(aSibling getMother = myPerson getMother)]) ifFalse:
	[
		(myPerson getConflictList) add: ('Does not have the same parents as all siblings')
	]
]
].

	 
] ! !


MonthMorph subclass: #CustomMonth
	instanceVariableNames: 'name holder '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 11/2/2002 19:22'!
chooseYear: aString

	| newYear yearString |
	newYear _ (SelectionMenu selections: {'today'} , (month year - 5 to: month year + 5) , {'other...'}) startUpWithCaption: aString.
	newYear ifNil: [^ self].
	newYear isNumber ifTrue:
		[^ self month: (Month newDay: 1 month: month monthName year: newYear)].
	newYear = 'today' ifTrue:
		[^ self month: (Month fromDate: Date today)].
	yearString _ FillInTheBlank request: 'Type in a year' initialAnswer: Date today year asString.
	yearString ifNil: [^ self].
	newYear _ yearString asNumber.
	(newYear between: 0 and: 9999) ifTrue:
		[^ self month: (Month newDay: 1 month: month monthName year: newYear)].
! !

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 11/3/2002 15:30'!
getHolder

"Version 1.0 by Adam Parker on 11/3/2002"
	"returns the holder for this calendar "
	
	^holder.! !

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 11/2/2002 19:18'!
highlightDate: aDate

"Version 1.0 by Adam Parker on 11/2/2002"
	" highlights a certain date "

	(aDate isNil)
	ifFalse: 
	[
		todayCache _ aDate.
		self allMorphsDo:
			[:m | (m isKindOf: SimpleSwitchMorph) ifTrue:
					[(m arguments isEmpty not and: [m arguments first = todayCache])
						ifTrue: [m borderWidth: 2; borderColor: Color yellow]
						ifFalse: [m borderWidth: 1; setSwitchState: m color = m onColor]]].
	]
! !

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 11/2/2002 16:06'!
highlightToday



! !

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 10/30/2002 00:09'!
initialize
	super initialize.
	tileRect _ 0@0 extent: 23@19.
	self layoutInset: 1;
		color: (Color r:0.484 g:0.528 b:1.0);
		listDirection: #topToBottom;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		month: Date today month.
	self rubberBandCells: false.
	self extent: 160@130.! !

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 10/30/2002 00:27'!
initializeWeeks
	| weeks firstWeek lastWeek |
	self removeAllMorphs.
	weeks _ OrderedCollection new.
	(firstWeek _ month firstDate week) asDate dayOfMonth = 1 ifTrue:
		["If the entire first week is this month, then insert prior week"
		weeks add: (CustomWeek newWeek: firstWeek previous month: month tileRect: tileRect model: model)].
	month eachWeekDo:
		[:each |
		weeks add: (CustomWeek newWeek: (lastWeek _ each) month: month tileRect: tileRect model: model)].
	weeks size < 6 ifTrue:
		["If there's room at the bottom, add another week of next month."
		weeks add: (CustomWeek newWeek: lastWeek next month: month tileRect: tileRect model: model)].
	weeks reverseDo: [:each | 
		each hResizing: #spaceFill; vResizing: #spaceFill.
		"should be done by CustomWeek but isn't"
		each submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
		self addMorph: each].
	self initializeHeader.
	self highlightToday.! !

!CustomMonth methodsFor: 'as yet unclassified' stamp: 'AWP 11/3/2002 15:30'!
setHolder: aPerson

"Version 1.0 by Adam Parker on 11/3/2002"
	"Fills the holder for this calendar "
	
	holder := aPerson.! !


WeekMorph subclass: #CustomWeek
	instanceVariableNames: 'model '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!CustomWeek methodsFor: 'as yet unclassified' stamp: 'AWP 11/2/2002 16:00'!
modelOrNil

^model.! !


Object subclass: #ErrorReport
	instanceVariableNames: ''
	classVariableNames: 'MasterList '
	poolDictionaries: ''
	category: 'Geneology'!

!ErrorReport methodsFor: 'methods' stamp: 'ssc 9/18/2002 02:09'!
sendBlock
	"this method returns the block of code that Traversal will need to run on each person"
| aPerson |
MasterList add: self.
^[
(aPerson getGivenName isNil) ifTrue: [errorList add: ('given name not given')].
(aPerson getSurName isNil) ifTrue: [errorList add: 'sur name not given'].
(aPerson getBirthDate isNil) ifTrue: [errorList add: 'birth date not given'].
(aPerson getBirthLocation isNil) ifTrue: [errorList add: 'birth place not given'].
(aPerson getDeathDate isNil) ifTrue: [errorList add: 'death date not given'].
(aPerson getFather isNil) ifTrue: [errorList add: 'father is not given'].
(aPerson getMother isNil) ifTrue: [errorList add: 'mother is not given'].
(aPerson getGender isNil) ifTrue: [errorList add: 'gender is not given'].
]! !

!ErrorReport methodsFor: 'methods' stamp: 'ssc 9/18/2002 02:08'!
sendBlock: aPerson
	"this method returns the block of code that Traversal will need to run on each person"
MasterList add: self.
(aPerson getGivenName isNil) ifTrue: [errorList add: ('given name not given')].
(aPerson getSurName isNil) ifTrue: [errorList add: 'sur name not given'].
(aPerson getBirthDate isNil) ifTrue: [errorList add: 'birth date not given'].
(aPerson getBirthLocation isNil) ifTrue: [errorList add: 'birth place not given'].
(aPerson getDeathDate isNil) ifTrue: [errorList add: 'death date not given'].
(aPerson getFather isNil) ifTrue: [errorList add: 'father is not given'].
(aPerson getMother isNil) ifTrue: [errorList add: 'mother is not given'].
(aPerson getGender isNil) ifTrue: [errorList add: 'gender is not given'].! !

!ErrorReport methodsFor: 'methods' stamp: 'ssc 9/18/2002 01:57'!
setErrorList: aCollection
	"modifier"
errorList := aCollection.! !

!ErrorReport methodsFor: 'methods' stamp: 'ssc 9/18/2002 01:57'!
setMasterList: aCollection
	"modifier"
MasterList := aCollection.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ErrorReport class
	instanceVariableNames: ''!

!ErrorReport class methodsFor: 'initializer' stamp: 'ssc 9/19/2002 02:03'!
new
	"initializer"
ErrorReport setMasterList: (OrderedCollection new: 1).! !

!ErrorReport class methodsFor: 'initializer' stamp: 'ssc 9/19/2002 02:03'!
setMasterList: aCollection
	"modifier"
MasterList _ aCollection.! !


!ErrorReport class methodsFor: 'printing' stamp: 'ssc 9/19/2002 04:38'!
printMyself
	"this method prints out all of the errors for all of the people in MasterList"
| index |
index _ MasterList size.
1 to: index do: [:i | (MasterList at: i) printErrorList].
Transcript show: 'End of Error Report - suggested solution follows ' ; cr ; show: 'search www.cyndislist.com.  It is a good site, with links to over 150,000 other genealogy sites.  The class recommends the following URLs:  www.ancestry.com, www.rootsweb.com, www.genealogy.com, www.mytrees.com, and genealogy.about.com'; cr.! !


!ErrorReport class methodsFor: 'method' stamp: 'blg 11/3/2002 19:08'!
sendBlock
	"this method returns the block of code that Traversal will ned to run on each person"
^[:myPerson |
myPerson setErrorList:(OrderedCollection new).
MasterList add: myPerson.
(myPerson getGivenName = '') ifTrue: [(myPerson getErrorList) add: ('given name not given')].
(myPerson getSurName = '') ifTrue: [(myPerson getErrorList) add: 'sur name not given'].
(myPerson getBirthDate isNil) ifTrue: [(myPerson getErrorList) add: 'birth date not given'].
(myPerson getBirthLocation = '') ifTrue: [(myPerson getErrorList) add: 'birth location not given'].
(myPerson getDeathDate isNil) ifTrue: [(myPerson getErrorList) add: 'death date not given'].
(myPerson getFather isNil) ifTrue: [(myPerson getErrorList) add: 'father is not given'].
(myPerson getMother isNil) ifTrue: [(myPerson getErrorList) add: 'mother is not given'].
(myPerson getGender isNil) ifTrue: [(myPerson getErrorList) add: 'gender is not given'].
((((myPerson getChildren size)) > 0) and: [((myPerson getMarriages size) = 0)]) ifTrue: [(myPerson getErrorList) add: 'person has children, but has never been married.']. ]! !


SystemWindow subclass: #GeneologyMap
	instanceVariableNames: 'scrollPane topMenu optionsMenu family selectedPerson relations makingRelation relationPlaceHolder relationPlaceHolder2 relationType maps '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!GeneologyMap methodsFor: 'menu option handling' stamp: 'AWP 11/1/2002 01:34'!
menuAddKey

"Version 1.0 written by Adam Parker on 12/31/2002"
	" displays the relationship color key"

	| keyMenu |
	keyMenu := MVCMenuMorph new.

	keyMenu position: (self position + (50@50)).
	keyMenu stayUp: true.
	keyMenu lock.
	keyMenu addTitle: 'KEY'.
	keyMenu add: '--- marriage' action: nil. 
	keyMenu add: '--- sibling' action: nil. 
	keyMenu add: '--- child' action: nil. 
	keyMenu add: '--- parent' action: nil. 	
	
	keyMenu dragEnabled:false.
	self addMorph: keyMenu.

	(topMenu itemWithWording: '      SHOW KEY') contents: '      HIDE KEY'; selector: #menuRemoveKey:; arguments: (Array with:keyMenu).


! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'blg 11/3/2002 19:10'!
menuCheck
"Version 1.2 Bruce Goodwin 11/03/2002"
	"when someone clicks the 'new person' option from the menu, this method will hopefully be called."

	Transcript open.

	selectedPerson isNil ifTrue:
	[
		Transcript show: 'You need to select someone first.';cr.
	]
	ifFalse:
	[
		(selectedPerson getDisplayFor) check.
	].
! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'BLG 10/30/2002 12:53'!
menuChild
"Version 1.0 Bruce Goodwin 10/30/2002"
	"when someone clicks the 'Sibling' option from the connection submenu, this method will hopefully be called."

selectedPerson ifNotNilDo: [:sel| sel makeConnection: 3 ].! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'blg 10/28/2002 17:39'!
menuConnect
"Version 1.0 Bruce Goodwin 10/21/2002"
	"when someone clicks the 'new person' option from the menu, this method will hopefully be called."

	| |
	relations add:(RelationLine newFrom: (family atRandom)).! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'BLG 10/30/2002 12:54'!
menuMarriage
"Version 1.0 Bruce Goodwin 10/30/2002"
	"when someone clicks the 'Marriage' option from the connection submenu, this method will hopefully be called."

selectedPerson ifNotNilDo: [:sel| sel makeConnection: 4 ].! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'blg 10/30/2002 17:19'!
menuNew
"Version 1.2 Bruce Goodwin 10/28/2002"
	"when someone clicks the 'new person' option from the menu, this method will hopefully be called."

	|newGuy|
	newGuy _ Person new.
	"family add: newGuy."
	self drawPerson: newGuy.
	(self getStickFor: newGuy) ifNotNilDo: [:stick| stick setNamePopup].! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'BLG 10/22/2002 01:54'!
menuQuery
"Version 1.0 Bruce Goodwin 10/21/2002"
	"when someone clicks the 'new person' option from the menu, this method will hopefully be called."

	| |
	Transcript show: 'don''t bother';cr.! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'AWP 10/31/2002 13:08'!
menuRemoveKey: aMenu

"Version 1.0 written by Adam Parker on 12/31/2002"
	" removes the key from the system."

	aMenu abandon.

	(topMenu itemWithWording: '      HIDE KEY') contents: '      SHOW KEY'; selector: #menuAddKey; arguments: Array new.

! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'BLG 10/30/2002 12:53'!
menuSibling
"Version 1.0 Bruce Goodwin 10/30/2002"
	"when someone clicks the 'Sibling' option from the connection submenu, this method will hopefully be called."

selectedPerson ifNotNilDo: [:sel| sel makeConnection: 1 ].! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'AWP 11/5/2002 03:08'!
menuWebQuery

"Version 1.0 by Adam Parker on 11/4/2002"
	"Updates a person with information found on the web"

	| tmpCollection selectionsMenu |

(selectedPerson isNil) ifTrue: [ ^false.].
	tmpCollection := AutoCompleter fillPersonInfo: (selectedPerson getDisplayFor).

	tmpCollection := tmpCollection reject: [:each | (((each at: 1) isNil)&((each at: 2) isNil)&((each at: 3) isNil)&((each at: 4) isNil))].

	selectionsMenu := MenuMorph new.

	(tmpCollection isEmpty)
	ifTrue:
	[
		selectionsMenu title: 'There were no results found!!'.
	]
	ifFalse: 
	[
		selectionsMenu title: 'Multiple Results occurred, Select Correct Result'.
		tmpCollection do: [:each | selectionsMenu add:'born on: ',((each at: 1) asString),' - died on: ',((each at: 3) asString) target:self selector:#menuWebUpdate: argument: each.].
	].

	self addMorph: selectionsMenu.
	selectionsMenu position: (self center).! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'AWP 11/5/2002 02:29'!
menuWebUpdate: resultCollection

"Version 1.0 by Adam Parker on 11/4/2002"
	"Updates the selected person after a correct dataset is chosen"

	(selectedPerson getDisplayFor) born: (resultCollection at: 1) location: (resultCollection at: 2).
	(selectedPerson getDisplayFor) died: (resultCollection at: 3).


Transcript show: 'updating';cr.! !

!GeneologyMap methodsFor: 'menu option handling' stamp: 'blg 10/29/2002 21:59'!
menuWriteOut

	Transcript open.
	PersonPrinter printPeople: (self getFamily).! !


!GeneologyMap methodsFor: 'Initialize' stamp: 'AWP 11/7/2002 14:46'!
addMenu

"Version 1.3 Bruce Goodwin 10/30/2002"
	"A method that makes a menu and displays it on the geneology window"

	|connectMenu|

"---------------making connect submenu---------------"
connectMenu _ MenuMorph new.
connectMenu title: 'Connection Type'.
connectMenu defaultTarget: self.

	connectMenu add: 'Marriage' action: #menuMarriage.
	connectMenu balloonTextForLastItem: 'Marry the selected person to someone'.
	connectMenu add: 'Sibling' action: #menuSibling.
	connectMenu balloonTextForLastItem: 'Give the selected person a sibling'.
	connectMenu add: 'Child' action: #menuChild.
	connectMenu balloonTextForLastItem: 'Give the selected person a child, and give that child its other parent. First drag the connection line to the child - then drag the new selection line to its other parent'.

"--------------done with connect submenu-------------"


	optionsMenu := MenuMorph new.
	optionsMenu title: 'Options'.

"	self addMorph: optionsMenu frame: (0.84@0.03 extent: 0.1@0.2)."
	self addMorph: optionsMenu.
	optionsMenu stayUp: true.
	optionsMenu defaultTarget: self.
	optionsMenu color: Color white.
	optionsMenu borderColor: Color blue.

"
	optionsMenu add: '' action: #.
	optionsMenu balloonTextForLastItem: ''.
"

	optionsMenu add: 'New Person' action: #menuNew.
	optionsMenu balloonTextForLastItem: 'Add a new person to this family'.
	optionsMenu add: 'Make Connection' subMenu: connectMenu.
	optionsMenu balloonTextForLastItem: 'Make a new family relationship between two people. i.e. make somebody somebody else''s husband'.
	"optionsMenu add: 'Edit Info' action:#menuEditInfo.
	optionsMenu balloonTextForLastItem: 'Edit a person''s vital information. This includes changing such things as a person''s name, date of birth, and place of death'."
	optionsMenu add: 'CheckFamily' action: #menuCheck.
	optionsMenu balloonTextForLastItem: 'Run a thorough check of completeness and validity on the current family tree. All family members will be scanned to find any missing vital information (such as a missing first name), and for conflicting information (such as someone being born after they died). The resulting error report will be put in the transcript.'.
	optionsMenu add: 'Query' action: #menuQuery.
"	optionsMenu addLine."
	optionsMenu addLine.
	optionsMenu add: 'Write out' action:#menuWriteOut.
	optionsMenu balloonTextForLastItem: 'Search in this family for a person with certain attributes.'.
	optionsMenu add: 'Map Relations' action: #fillLines.
	optionsMenu balloonTextForLastItem: 'All relations (i.e. mother, sister, husband, father) between people that aren''t currently drawn in the map will be drawn.'.

	optionsMenu addLine.
	optionsMenu add: 'Web Complete' action: #menuWebQuery.
	optionsMenu addLine.


	"A bunch of empty rows to scrunch the line above Write out"
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: ' ' action: nil.
	optionsMenu add: 'testing' action: #makeMaps.
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 
	optionsMenu add: ' ' action: nil. 

	optionsMenu addLine.
	optionsMenu add: '      SHOW KEY' target: self selector: #menuAddKey argument:nil.
	optionsMenu addLine.

	topMenu := optionsMenu.

! !

!GeneologyMap methodsFor: 'Initialize' stamp: 'AWP 11/1/2002 13:44'!
addMenu: aMenu

"Version 1.0 Adam Parker 9/20/2002"
	"A method that takes in a menu and displays it on the geneology window"

	| |

	(aMenu isNil) 
	ifTrue: [ 
				optionsMenu := MenuMorph new.
				optionsMenu addTitle: 'Options'.
				self addMorph: optionsMenu.
				optionsMenu position: (self bounds upRight) - 200@100.
				optionsMenu height: 100; width: 100.
				optionsMenu stayUp: true.
Transcript show: 'tettetetete'.
			]
	ifFalse: [
				
			].
	! !

!GeneologyMap methodsFor: 'Initialize' stamp: 'AWP 11/5/2002 00:32'!
addScrollPane

"Version 1.0 Adam Parker 9/21/2002"
	"Makes a new two way scroll pane and adds it to the Geneology window."

	scrollPane := MyTwoWayScrollPane new.
"	scrollPane openAsMorph."
	self addMorph: scrollPane frame: (0@0 extent: 1@1).
	! !

!GeneologyMap methodsFor: 'Initialize' stamp: 'AWP 10/29/2002 21:10'!
getFamilyStickNotSelected
"Version 1.0 Bruce Goodwin 10/21/2002"

^family reject: [:each | (each=selectedPerson) | (each=relationPlaceHolder)]. ! !

!GeneologyMap methodsFor: 'Initialize' stamp: 'AWP 11/4/2002 21:24'!
open
	"to facilitate the GeneologyMap new open use structure required by the 2340 squeak overlords"

	|passedInFamily|

	relations _ OrderedCollection new.
	self allowReframeHandles: false.
	"self allowReframeHandles: true."
	self openInWorld.
	self extent: 800@600.
	topMenu position: (self position)+((self width-130)@20).
	self position: 0@0.
	
	family ifNotNilDo: [:fam| passedInFamily _ fam].

	self setFamily: (OrderedCollection new).
	
	passedInFamily ifNotNilDo: [:passedIn| passedIn do:
		[:person|
			self drawPerson: person.
		].
		self fillLines.
	].

! !

!GeneologyMap methodsFor: 'Initialize' stamp: 'AWP 10/31/2002 00:43'!
select: aStickFigure
"Version 1.0 Bruce Goodwin 10/27/2002"
	"selected person holds the currently selected stick figure. this is used several places"

	(selectedPerson isNil)
	ifFalse:
	[
		self undoColoredLinesFor: selectedPerson.
		selectedPerson deselect.
	].
	selectedPerson _ aStickFigure.
	self doColoredLinesFor: aStickFigure.! !


!GeneologyMap methodsFor: 'event handling' stamp: 'fd 9/25/2002 16:13'!
handlesMouseDown: evt 

"Version 1.0 Adam Parker 9/25/2002"
	"Method overridden from super class to eliminate Bring to Front action of clicking"

	^ true.! !

!GeneologyMap methodsFor: 'event handling' stamp: 'BLG 10/27/2002 19:16'!
selectedStickFigure
"Version 1.0 Bruce Goodwin 10/27/2002"
	"selected person holds the currently selected stick figure. this is used several places"


	^selectedPerson.! !


!GeneologyMap methodsFor: 'drawing' stamp: 'blg 10/28/2002 17:01'!
drawPerson: aPerson
"Version 1.2 Bruce Goodwin 10/28/2002"
	"put person on the screen"

	|stickDude newPos doOver|
Transcript show: 'testing'.
	doOver _ true.
	newPos _  (scrollPane scroller extent)/2.
	stickDude _ StickFigure createFor: aPerson at: newPos.
	stickDude setGeneologyMap: self.
	
	[doOver] whileTrue:
	[
		doOver _ false.
		scrollPane scroller submorphsDo:
		[:submorph|
			(submorph bounds intersects: (Rectangle origin: newPos extent: (stickDude extent))) ifTrue:
			[
				doOver _ true.
				newPos _ (newPos x)@((newPos y) + (stickDude extent y) + 20).
				stickDude setLocation: newPos.
			]
		]
	].

	family add: stickDude.
	stickDude position:newPos.
	scrollPane scroller addMorph: stickDude.
	scrollPane doLayoutIn: ((scrollPane scroller extent x) max: (stickDude bounds bottomRight x))@((scrollPane scroller extent y) max: (stickDude bounds bottomRight y)).
	scrollPane resizeScroller.
	scrollPane scrollIntoView: (stickDude bounds) extra: 0.
	scrollPane setScrollDeltas.! !

!GeneologyMap methodsFor: 'drawing' stamp: 'AWP 11/5/2002 00:13'!
fillLines
"Version 1.0 Bruce Goodwin 10/29/2002"
	"represent all existing relations on the map"

relations do: [:each | each abandon.].
relations := OrderedCollection new.

self getFamilyStick do:
[:stick|
	((stick getDisplayFor) getFather isNil)
	ifFalse:
	
[
		relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
			[:atStick| atStick getDisplayFor = (stick getDisplayFor) getFather])]
		ifNone:
		[
			relations add: (RelationLine newFrom: stick to: (self getStickFor: (stick getDisplayFor) getFather) type: 2)
		].
	
].
	
	
((stick getDisplayFor) getMother isNil)
	ifFalse:
	
[
		relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
			[:atStick| atStick getDisplayFor = (stick getDisplayFor) getMother])]
		ifNone:
		[
			relations add: (RelationLine newFrom: stick to: (self getStickFor: (stick getDisplayFor) getMother) type: 2).
		].
	
].
	
	
(((stick getDisplayFor) getChildren size) = 0) ifFalse:
	
[
	
	((stick getDisplayFor) getChildren) do:
	
	[:child|
			relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = child])]
			ifNone:
			[
				relations add: (RelationLine newFrom: stick to: (self getStickFor: child) type: 3).
			].
	
	
	].
	
].
	
	(((stick getDisplayFor) getSiblings size) = 0) ifFalse:
	[
		((stick getDisplayFor) getSiblings) do:
		[:sibling|
			relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = sibling])]
			ifNone:
			[
				relations add: (RelationLine newFrom: stick to: (self getStickFor: sibling) type: 1).
			].
		].
	].
	
	(((stick getDisplayFor) getMarriages size) = 0) ifFalse:
	[
		((stick getDisplayFor) getMarriages) do:
		[:marriage|
			relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = (marriage getSpouse)])]
			ifNone:
			[
				relations add: (RelationLine newFrom: stick to: (self getStickFor: (marriage getSpouse)) type: 4).
			].
		].
	].

].! !

!GeneologyMap methodsFor: 'drawing' stamp: 'AWP 10/31/2002 11:44'!
fillLinesOnOpen
"Version 1.0 Bruce Goodwin 10/29/2002"
	"represent all existing relations on the map"

self getFamilyStick do:
[:stick|

	((stick getDisplayFor) getFather isNil)
	ifFalse:
	
[
		relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
			[:atStick| atStick getDisplayFor = (stick getDisplayFor) getFather])]
		ifNone:
		[
			relations add: (RelationLine newFrom: stick to: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = (stick getDisplayFor) getFather]) type: 2)
		].
	
].
	
	
((stick getDisplayFor) getMother isNil)
	ifFalse:
	
[
		relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
			[:atStick| atStick getDisplayFor = (stick getDisplayFor) getMother])]
		ifNone:
		[
			relations add: (RelationLine newFrom: stick to: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = (stick getDisplayFor) getMother]) type: 2).
		].
	
].
	
	
(((stick getDisplayFor) getChildren size) = 0) ifFalse:
	
[
	
	((stick getDisplayFor) getChildren) do:
	
	[:child|
			relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = child])]
			ifNone:
			[
				relations add: (RelationLine newFrom: stick to: (self getFamilyStick detect:
					[:atStick| atStick getDisplayFor = child]) type: 3).
			].
	
	
	].
	
].
	
	(((stick getDisplayFor) getSiblings size) = 0) ifFalse:
	[
		((stick getDisplayFor) getSiblings) do:
		[:sibling|
			relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = sibling])]
			ifNone:
			[
				relations add: (RelationLine newFrom: stick to: (self getFamilyStick detect:
					[:atStick| atStick getDisplayFor = sibling]) type: 1).
			].
		].
	].
	
	(((stick getDisplayFor) getMarriages size) = 0) ifFalse:
	[
		((stick getDisplayFor) getMarriages) do:
		[:marriage|
			relations detect: [:rel| rel containsAsEnds: stick and: (self getFamilyStick detect:
				[:atStick| atStick getDisplayFor = (marriage getSpouse)])]
			ifNone:
			[
				relations add: (RelationLine newFrom: stick to: (self getFamilyStick detect:
					[:atStick| atStick getDisplayFor = (marriage getSpouse)]) type: 4).
			].
		].
	].

].! !

!GeneologyMap methodsFor: 'drawing' stamp: 'AWP 11/5/2002 00:28'!
handleMouseUp: anEvent
	"The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	anEvent blueButtonChanged
		ifTrue:[self blueButtonUp: anEvent]
		ifFalse:[self mouseUp: anEvent].
	self setIndexInOwner: 1.
	optionsMenu comeToFront.
! !

!GeneologyMap methodsFor: 'drawing' stamp: 'blg 10/28/2002 20:37'!
handleMove: stickDude

	((scrollPane scroller extent x) max: (stickDude bounds bottomRight x))@((scrollPane scroller extent y) max: (stickDude bounds bottomRight y)).
	scrollPane resizeScroller.
	scrollPane scrollIntoView: (stickDude bounds) extra: 0.
	scrollPane setScrollDeltas.

	"the person has been moved, so refresh his location"
	stickDude setLocation: stickDude position.

	"relations do: 
	[:rel| 
		(rel containsAsEnd: stickDude) ifTrue:
		[
			rel endMoved.
		]
	]."! !

!GeneologyMap methodsFor: 'drawing' stamp: 'AWP 11/1/2002 14:26'!
spawnReframeHandle: evt

"Version 1.0 written by Adam Parker on 11/1/2002"

	super spawnReframeHandle: evt.
	topMenu position: (self position)+((self width-130)@20).
	^ true.! !


!GeneologyMap methodsFor: 'access' stamp: 'blg 10/28/2002 18:07'!
getFamily
"Version 1.0 Bruce Goodwin 10/21/2002"

^family collect: [:member| member getDisplayFor]. ! !

!GeneologyMap methodsFor: 'access' stamp: 'AWP 10/29/2002 00:02'!
getFamilyStick
"Version 1.0 Bruce Goodwin 10/21/2002"

^family. ! !

!GeneologyMap methodsFor: 'access' stamp: 'AWP 10/30/2002 23:27'!
getRelations

"Version 1.0 by Adam Parker on 10/30/2002"
	"Returns the relations collection"

^ relations.! !

!GeneologyMap methodsFor: 'access' stamp: 'blg 10/30/2002 17:18'!
getStickFor: aPerson
"Version 1.0 Bruce Goodwin 10/21/2002"

^family detect: [:thisStick| (thisStick getDisplayFor) = aPerson] ifNone: [^nil]. ! !

!GeneologyMap methodsFor: 'access' stamp: 'blg 10/28/2002 18:10'!
setFamily: anOrderedCollection
	"Version 1.0 Bruce Goodwin 10/22/2002"

	family _ anOrderedCollection.! !

!GeneologyMap methodsFor: 'access' stamp: 'AWP 10/30/2002 23:28'!
setRelations: aCollection

"Version 1.0 by Adam Parker on 10/30/2002"
	"sets the relations array"

relations := aCollection.! !


!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/30/2002 23:43'!
addRelation: aRelation

"Version 1.0 by Adam Parker on 10/30/2002"
	"Adds a relation to the map"

relations add: aRelation.! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 11/4/2002 21:48'!
connectChild

"Version 1.0 Adam Pakrer 10/29/2002"
	"Function to set the geneologyMap's state so mouse-over higlights can occurr"
	
	(relationPlaceHolder isNil)
	ifTrue:
	[
		makingRelation := 'b'.
		relationType := 3.
	]
	ifFalse:
	[
		(relationPlaceHolder2 isNil)
		ifTrue:
		[
			selectedPerson select: 'r'.
			relationPlaceHolder select: 'b'.
			RelationLine newFrom: relationPlaceHolder type: 3.
			makingRelation := 'g'.
			relationType := 3.
		]
		ifFalse:
		[
			(((selectedPerson getDisplayFor) hasChild: (relationPlaceHolder getDisplayFor) with: (relationPlaceHolder2 getDisplayFor)) = 1)
			ifTrue:
			[
				selectedPerson select: 'r'.
				relationPlaceHolder select: 'b'.
				relationPlaceHolder2 select: 'g'.
				self displayActionAlert: selectedPerson getDisplayFor getName,' and ',relationPlaceHolder2 getDisplayFor getName,' have a child: ',relationPlaceHolder getDisplayFor getName.
				self stopMakingRelation.
			]
			ifFalse:
			[
				self displayActionAlert:'Parents can not be of the same gender.'.
				self removeRelationFrom: selectedPerson to:relationPlaceHolder type:4.
				selectedPerson deleteLineWith: relationPlaceHolder.
				self removeRelationFrom: relationPlaceHolder to:relationPlaceHolder2 type:4.
				relationPlaceHolder deleteLineWith: relationPlaceHolder2.
				self stopMakingRelation.
			]
		]
	].! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 11/4/2002 21:44'!
connectMarriage

"Version 1.0 Adam Parker 11/3/2002"
	"Function to set the geneologyMap's state so mouse-over higlights can occurr"
	
	(relationPlaceHolder isNil)
	ifTrue:
	[
		makingRelation := 'b'.
		relationType := 4.
	]
	ifFalse:
	[
			(((selectedPerson getDisplayFor) married: (relationPlaceHolder getDisplayFor) on:nil) = 1)
			ifTrue:
			[
				selectedPerson select: 'r'.
				relationPlaceHolder select: 'b'.
				relationPlaceHolder marriageDatePopup:(selectedPerson getDisplayFor).
				self stopMakingRelation.
			]
			ifFalse:
			[
				self displayActionAlert:'Same sex mariages are not allowed.  Try again.'.
				self removeRelationFrom: selectedPerson to:relationPlaceHolder type:4.
				selectedPerson deleteLineWith: relationPlaceHolder.
				self stopMakingRelation.
			]
	].! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 21:16'!
connectParent

"Version 1.0 Adam Pakrer 10/29/2002"
	"Function to set the geneologyMap's state so mouse-over higlights can occurr"
	
	(relationPlaceHolder isNil)
	ifTrue:
	[
		makingRelation := 'b'.
		relationType := 2.
	]
	ifFalse:
	[
		selectedPerson select: 'r'.
		relationPlaceHolder select: 'b'.
		((relationPlaceHolder getDisplayFor) getGender)
		ifTrue: 	
		[
			(selectedPerson getDisplayFor) hasFather: (relationPlaceHolder getDisplayFor).		
			self displayActionAlert: selectedPerson getDisplayFor getName,'''s father is now ',relationPlaceHolder getDisplayFor getName.
		]
		ifFalse:	
		[
			(selectedPerson getDisplayFor) hasMother: (relationPlaceHolder getDisplayFor).
			self displayActionAlert: selectedPerson getDisplayFor getName,'''s mother is now ',relationPlaceHolder getDisplayFor getName.
		].
		self stopMakingRelation.
	].! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 16:50'!
connectSibling

"Version 1.0 Adam Pakrer 10/29/2002"
	"Function to set the geneologyMap's state so mouse-over higlights can occurr"
	
	(relationPlaceHolder isNil)
	ifTrue:
	[
		makingRelation := 'b'.
		relationType := 1.
		Transcript show: 'setup';cr.
	]
	ifFalse:
	[
		selectedPerson select: 'r'.
		relationPlaceHolder select: 'b'.
		(selectedPerson getDisplayFor) hasSibling: (relationPlaceHolder getDisplayFor).
		self displayActionAlert: selectedPerson getDisplayFor getName,' is now a sibling with ',relationPlaceHolder getDisplayFor getName.
		self stopMakingRelation.
	].! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 16:38'!
displayActionAlert: aMessage

"Version 1.0 Adam Parker 10/29/2002"
	"modifier to popup a window to edit the user's name "

	| window okBtn msgLabel messageBox |
	
	window := FillInTheBlankMorph new.

	window position: (60@0).
	window height: 100.
	
	messageBox := TextMorph new.
	window addMorph: messageBox.
	messageBox position: (68@22).
	messageBox borderWidth: 1.
	messageBox height: 90.
	messageBox width: 185.
	messageBox contents: aMessage wrappedTo: 185.
	messageBox backgroundColor: (Color gray: 0.8).


	okBtn := SimpleButtonMorph newWithLabel: ' ok '.
	window addMorph: okBtn.
	okBtn position: (140@73).
	okBtn target: window.
	okBtn actionSelector: #abandon.

	msgLabel := StringMorph contents: 'Status Message'.
	window addMorph: msgLabel.
	msgLabel position: (120@6).

	self addMorph: window.
     window hasFocus.
	window position: (self bounds bottomRight)//2-(100@50).
	
! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 11/3/2002 17:01'!
doColoredLinesFor: aStickFigure

"Version 1.0 by Adam Parker on 10/30/2002"
	"Color codes the lines for a specific person:"
	" black = parents "
	" blue = siblings "
	" red = children "
	" yellow = marriages "

 | directRelations |

directRelations := relations select: [:each | each containsAsEnd: aStickFigure].


	directRelations do: 
		[:each | 
			(each getType = 1) 
				ifTrue: [each setColor: Color blue.]
				ifFalse: 
				[
					((each getType = 2) | (each getType = 3))
					ifTrue: 
					[
						((((each getEndNot: aStickFigure) getDisplayFor getMother) = aStickFigure getDisplayFor) | (((each getEndNot: aStickFigure) getDisplayFor getFather) = aStickFigure getDisplayFor))
						ifTrue: [each setColor: Color red.]
						ifFalse: [each setColor: Color black.]
					]
					ifFalse: 
					[
						(each getType = 4)
						ifTrue: [each setColor: Color yellow.]
						ifFalse: [each setColor: Color green.]
					]
				].
		].	
! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 21:14'!
getMakingRelation

	^makingRelation.! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 11/3/2002 15:37'!
handleConnection: aStickFigure

	(relationPlaceHolder isNil)
		ifTrue:[	relationPlaceHolder := aStickFigure.]
		ifFalse:[	relationPlaceHolder2 := aStickFigure.].

	(relationType = 1)	ifTrue: [self connectSibling.^true.].
	(relationType = 2)	ifTrue: [self connectParent.^true.].
	(relationType = 3)	ifTrue: [self connectChild.^true.].
	(relationType = 4)	ifTrue: [self connectMarriage.^true.].! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 09:31'!
isMakingRelation

"Version 1.0 Adam Pakrer 10/29/2002"
	"returns the makingRelation variable"

	^makingRelation.! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 11/3/2002 20:38'!
removeRelationFrom: aStick to: aStick2 type: aType

"Version 1.0 by Adam Parker on 10/30/2002"
	"Removes all lines of a specific type for a person"


 | relationsToDelete |

relationsToDelete := relations select: [:each | each containsAsEnds: aStick and: aStick2].

	relationsToDelete do: 
		[:each | 
				(each getType = 4)
				ifTrue:
				[
					Transcript show: each.
					relations remove: each.
					each abandon.
				]
		].	
! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 14:47'!
startMakingRelation: aRelationType

"Version 1.0 Adam Pakrer 10/29/2002"
	"Function to set the geneologyMap's state so mouse-over higlights can occurr"
	"
	'b' - represents the first stage of a selection 
	'g' - represents the second stage of a selection
	"
	makingRelation := aRelationType.! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/29/2002 21:30'!
stopMakingRelation

"Version 1.0 Adam Pakrer 10/29/2002"
	"Clears the Making Relation variable."

	makingRelation := nil.
	relationPlaceHolder := nil.
	relationPlaceHolder2 := nil.
	relationType := nil.! !

!GeneologyMap methodsFor: 'relations' stamp: 'AWP 10/31/2002 10:58'!
undoColoredLinesFor: aStickFigure

"Version 1.0 by Adam Parker on 10/30/2002"
	"Color codes the lines for a specific person:"
	" Black = parents "
	" blue = siblings "
	" red = children "

 | directRelations |

directRelations := relations select: [:each | each containsAsEnd: aStickFigure].


	directRelations do: [:each | each setColor: Color green.].	
! !


!GeneologyMap methodsFor: 'maps' stamp: 'AWP 11/7/2002 14:28'!
addMapCollectionFor: aPerson

"Version 1.0 written by Adam Parker on 10/7/2002"
	"adds a person's family map as a collection"

	| collection |
	collection:=OrderedCollection new.
	Traversal traverseFrom: aPerson do: [:each| collection add: each.].

	maps add: collection.		! !

!GeneologyMap methodsFor: 'maps' stamp: 'AWP 11/7/2002 14:25'!
addMapCollectionForSelected

"Version 1.0 written by Adam Parker on 10/7/2002"
	"adds a person's family map as a collection"

	| aPerson collection |
	aPerson := selectedPerson getDisplayFor.
	collection:=OrderedCollection new.
	Traversal traverseFrom: aPerson do: [:each| collection add: each.].

	maps add: collection.		! !

!GeneologyMap methodsFor: 'maps' stamp: 'AWP 11/7/2002 13:29'!
clearMap

"Version 1.0 written by Adam Parker on 11/7/2002"
	"Resets the maps collection"

maps := OrderedCollection new.! !

!GeneologyMap methodsFor: 'maps' stamp: 'AWP 11/7/2002 14:44'!
makeMaps

"Version 1.0 by Adam Parker on 11/7/2002"
	"Clears the maps list and rebuilds it"

	self clearMap.
	
	family do: 
	[:each |
		(self mapsContains: (each getDisplayFor))
		ifFalse:
			[self addMapCollectionFor: (each getDisplayFor).]
	
	].

	Transcript show: maps.
	! !

!GeneologyMap methodsFor: 'maps' stamp: 'AWP 11/7/2002 14:49'!
mapsContains: aPerson.

"Version 1.0 by Adam Parker on 11/7/2002"
	"Checks to see if the person is already in the maps"

maps do: [:collection | collection do: [:each | (each = aPerson) ifTrue: [^true.] ] ].

^ false.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

GeneologyMap class
	instanceVariableNames: ''!

!GeneologyMap class methodsFor: 'as yet unclassified' stamp: 'AWP 11/7/2002 13:29'!
new
"Version 2.0 Bruce Goodwin 10/21/2002"
	| tempWindow |
	tempWindow := super labelled: 'Geneology Display'.
	"tempWindow extent: 800@600.
	tempWindow clearMap.
	tempWindow position: 0@0."
	tempWindow setWindowColor: Color blue.
	tempWindow addScrollPane.
	tempWindow addMenu.
	tempWindow setFamily: OrderedCollection new.
^tempWindow
! !

!GeneologyMap class methodsFor: 'as yet unclassified' stamp: 'AWP 11/7/2002 13:29'!
with: aCollection
"Version 1.0 Bruce Goodwin 10/22/2002"
	| tempWindow |
	tempWindow := super labelled: 'Geneology Display'.
	"tempWindow extent: 800@600.
	tempWindow position: 0@0."
	tempWindow clearMap.
	tempWindow setWindowColor: Color blue.
	tempWindow addScrollPane.
	tempWindow addMenu.
	tempWindow setFamily: (OrderedCollection withAll: aCollection).
^tempWindow
! !


MenuMorph subclass: #Info
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!Info methodsFor: 'as yet unclassified' stamp: 'fd 10/25/2002 15:41'!
delete

	parent clearMenu.
	super delete.! !


!Info methodsFor: 'modifiers' stamp: 'fd 10/25/2002 15:42'!
addParent: aStickFigure

	parent := aStickFigure.! !


Object subclass: #Marriage
	instanceVariableNames: 'date isDivorced divorceDate spouse '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!Marriage methodsFor: 'methods' stamp: 'AWP 9/19/2002 06:27'!
getSpouse


"Version 1.0 Adam Parker 9/14/2002"
	
"Get the Person that self is married to."


^spouse! !

!Marriage methodsFor: 'methods' stamp: 'AWP 9/19/2002 06:28'!
isDivorced


"Version 1.0 Adam Parker 9/14/2002"
	
"Sets the isDivorced variable to true"


isDivorced := true.! !

!Marriage methodsFor: 'methods' stamp: 'AWP 9/19/2002 06:28'!
isNotDivorced


"Version 1.0 Adam Parker 9/14/2002"
	
"Sets the isDivorced variable to false"


isDivorced := false.! !

!Marriage methodsFor: 'methods' stamp: 'AWP 11/3/2002 22:00'!
setDate: aDate

"Version 1.0 Adam Parker 9/14/2002"
"Set the mariage date"

date := aDate.
! !

!Marriage methodsFor: 'methods' stamp: 'AWP 9/19/2002 06:30'!
setDivorceDate: aDate


"Version 1.0 Adam Parker 9/14/2002"
	
"modifier"


divorceDate := aDate.! !

!Marriage methodsFor: 'methods' stamp: 'AWP 9/19/2002 06:30'!
setSpouse: aPerson


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the spouse object to aPerson "


spouse := aPerson.! !


!Marriage methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:32'!
married: aPerson on: aDate


"Version 1.1 Scott Camp 9/17/2002"
	
"Creates a Marriage object between aPerson and this Person."
	"Add that Marriage object to the marriageDates Collection."
	"Makes sure that aperson knows that that he/she is married to this person"



| aMarriage |


spouse := aPerson.

aMarriage := Marriage new: aDate with: aPerson.

self addMarriage: aMarriage.

self isMarried.

aPerson marriedMirror: self on: aDate.! !


!Marriage methodsFor: 'Accessors' stamp: 'ssc 10/21/2002 21:54'!
getDate
	"get the date of the marriage"

^date! !

!Marriage methodsFor: 'Accessors' stamp: 'ssc 10/21/2002 22:02'!
getDivorceDate
	"get the date of the marriage"

^divorceDate! !

!Marriage methodsFor: 'Accessors' stamp: 'ssc 10/21/2002 21:59'!
getDivorceState
	"get a boolean telling whether or not this marriage has resulted in a divorce"

	^ isDivorced! !

!Marriage methodsFor: 'Accessors' stamp: 'ssc 10/21/2002 21:59'!
getDivorced
	"get a boolean telling whether or not this marriage has resulted in a divorce"

	^ isDivorced! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Marriage class
	instanceVariableNames: ''!

!Marriage class methodsFor: 'as yet unclassified' stamp: 'AWP 11/3/2002 22:08'!
new: aDate with: aPerson

"Version 1.0 Adam Parker 9/14/2002"
"instantiator"


| aMarriage |
aMarriage := super new.
aMarriage setSpouse: aPerson.
aMarriage setDate: aDate.
aMarriage isNotDivorced.
^aMarriage


! !

!Marriage class methodsFor: 'as yet unclassified' stamp: 'ssc 9/14/2002 00:01'!
new: aDate with: aPerson divorced: secondDate


"Version 1.0 Adam Parker 9/14/2002"


"instantiator"


| aMarriage |


aMarriage := super new.


aMarriage setSpouse: aPerson.


aMarriage setDate: aDate.


aMarriage isDivorced.


aMarriage setDivorceDate: secondDate.


^aMarriage


! !


TwoWayScrollPane subclass: #MyTwoWayScrollPane
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!MyTwoWayScrollPane methodsFor: 'as yet unclassified' stamp: 'AWP 11/5/2002 00:32'!
handleMouseUp: anEvent

"Version 1.0 by Adam Parker on 11/4/2002"
	"The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before"

	owner setIndexInOwner: 1.
	super handleMouseUp: anEvent.
	^true.
! !


Object subclass: #PersonPrinter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PersonPrinter class
	instanceVariableNames: ''!

!PersonPrinter class methodsFor: 'main methods' stamp: 'AWP 11/4/2002 12:19'!
printPeople: aCollection
	"this is the main reason this class was created.  to take in a collection and print to the transcript the method calls necessary to create this person"
| sizeOfCollection variableString collectionString genealogyMapString instantiationString |
sizeOfCollection _ aCollection size.
instantiationString _ Text fromString: ''.
variableString _ Text fromString: '| collection '.
collectionString _ Text fromString: 'collection _ OrderedCollection new: 1. '.
genealogyMapString _ Text fromString: '(GeneologyMap with: (collection)) open.'.
Transcript show: 'Beginning to print the Collection of People'; cr.
1 to: sizeOfCollection do: [:index |
						instantiationString append: 'P'.
						instantiationString append: index asStringWithCommas.
						instantiationString append: ' _ Person new. '.
						variableString append: ' P'.
						variableString append: index asStringWithCommas.
						collectionString append: ' collection add: '.
						collectionString append: 'P'.
						collectionString append: index asStringWithCommas.
						collectionString append: '. '.
						].
Transcript show: (variableString asString); show: ' |'; cr.
Transcript show: (instantiationString asString); cr.
1 to: sizeOfCollection do: [:index | PersonPrinter printPerson: (aCollection at: index) with: index in: aCollection].
Transcript show: (collectionString asString); cr.
Transcript show: (genealogyMapString asString); cr.! !

!PersonPrinter class methodsFor: 'main methods' stamp: 'AWP 11/3/2002 20:52'!
printPerson: aPerson
	"takes in a person and prints out all the method calls necessary to create this person"

| mainIndex mainCollection |
(aPerson getGivenName = '') ifFalse: [Transcript show: 'givenName: '; show: (aPerson getGivenName); cr].

(aPerson getSurName = '') ifFalse: [Transcript show: 'surName: '; show: (aPerson getSurName); cr].

(aPerson getBirthDate isNil) ifFalse: [Transcript show: 'born: '; show: (aPerson getBirthDate); cr].

(aPerson getBirthLocation = '') ifFalse: [Transcript show: ' location: '; show: (aPerson getBirthLocation); cr].

(aPerson getDeathDate isNil) ifFalse: [Transcript show: 'died: '; show: (aPerson getDeathDate); cr].

(aPerson getFather isNil) ifFalse: [Transcript show: 'hasFather: '; show: ((aPerson getFather) getGivenName); cr].

(aPerson getMother isNil) ifFalse: [Transcript show: 'hasMother: '; show: ((aPerson getMother) getGivenName); cr].

(aPerson getGender isNil) ifFalse: [(aPerson getGender) ifTrue: [Transcript show: 'isMale'; cr] ifFalse: [Transcript show: 'isFemale'; cr].].

mainIndex _ aPerson getNumOfSiblings.
(mainIndex = 0) ifFalse: [mainCollection _ aPerson getSiblings.
						1 to: mainIndex do: [:index | Transcript show: 'hasSibling: '; 						show: (mainCollection at: index) getGivenName ; cr].].

mainIndex _ aPerson getNumOfChildren.
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: 'hasChild: '; 
						show: (aPerson getChild: index) getGivenName.
						(aPerson getGender) ifTrue: [Transcript show: ' with: '; show:
						((aPerson getChild: index) getMother) getGivenName; cr] 
						ifFalse: [Transcript show: ' with: '; show:
						((aPerson getChild: index) getFather) getGivenName; cr].].].

mainIndex _ ((aPerson getAliases) size).
mainCollection _ (aPerson getAliases).
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: 'addAlias: ';
						show: (mainCollection at: index); cr].].

mainIndex _ ((aPerson getMarriages) size).
mainCollection _ (aPerson getMarriages).
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: 'married: ';
						show: (((mainCollection at: index) getSpouse) getGivenName); 
						show: ' on: '; show: ((mainCollection at: index) getDate). 
						((mainCollection at: index) getDivorceState)
							ifTrue:	[ Transcript show: ' divorced: ';
							show: ((mainCollection at: index) getDivorceDate)].
						Transcript cr.].].

mainIndex _ ((aPerson getRecords) size).
mainCollection _ (aPerson getRecords).
Transcript show: mainIndex; cr.
"(mainIndex = 0) ifFalse: [(mainCollection valuesDo: []).]."! !

!PersonPrinter class methodsFor: 'main methods' stamp: 'ssc 10/22/2002 02:54'!
printPerson: aPerson with: varNameIndex
	"takes in a person and prints out all the method calls necessary to create this person.  The varNameIndex is used to make the variable name printed out unique"

| mainIndex mainCollection varName date |

varName _ Text fromString: 'P'.
varName append: varNameIndex asStringWithCommas.
varName _ varName asString.

(aPerson getGivenName = '') ifFalse: [Transcript show: varName; show: ' givenName: '; show: $' ;show: (aPerson getGivenName); show: $' ;show: '.'; cr].

(aPerson getSurName = '') ifFalse: [Transcript show: varName; show: ' surName: '; show: $' ;show: (aPerson getSurName); show: $' ; show: '.'; cr].

(aPerson getBirthDate isNil) ifFalse: [ date _ ((aPerson getBirthDate) asGregorian). 
									Transcript show: varName; show: ' born: (Date newDay: ';
									show: (date at: 1); show: ' month: '; show: (date at: 2); 
									show: ' year: '; show: (date at: 3); show: ') '].

(aPerson getBirthLocation = '') ifFalse: [Transcript show: 'location: '; show: $' ; show: (aPerson getBirthLocation); show: $' ; show: '.'; cr].

(aPerson getDeathDate isNil) ifFalse: [ date _ ((aPerson getDeathDate) asGregorian). 
									Transcript show: varName; show: ' died: (Date newDay: ';
									show: (date at: 1); show: ' month: '; show: (date at: 2); 
									show: ' year: '; show: (date at: 3); show: ').'; cr
									].

(aPerson getFather isNil) ifFalse: [Transcript show: varName; show: ' hasFather: '; show: ((aPerson getFather) getGivenName); show: '.'; cr].

(aPerson getMother isNil) ifFalse: [Transcript show: varName; show: ' hasMother: '; show: ((aPerson getMother) getGivenName); show: '.'; cr].

(aPerson getGender isNil) ifFalse: [(aPerson getGender) ifTrue: [Transcript show: varName; show: ' isMale '; show: '.'; cr] ifFalse: [Transcript show: varName; show: ' isFemale'; show: '.'; cr].].

mainIndex _ aPerson getNumOfSiblings.
(mainIndex = 0) ifFalse: [mainCollection _ aPerson getSiblings.
						1 to: mainIndex do: [:index | Transcript show: varName; show: ' hasSibling: '; 						show: (mainCollection at: index) getGivenName ; show: '.'; cr].].

mainIndex _ aPerson getNumOfChildren.
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: varName; show: ' hasChild: ';
						show: (aPerson getChild: index) getGivenName.
						(aPerson getGender) ifTrue: [Transcript show: ' with: '; show:
						((aPerson getChild: index) getMother) getGivenName; show: '.'; cr] 
						ifFalse: [Transcript show: ' with: '; show:
						((aPerson getChild: index) getFather) getGivenName; show: '.'; cr].].].

mainIndex _ ((aPerson getAliases) size).
mainCollection _ (aPerson getAliases).
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: varName; show: ' addAlias: ';
						show: (mainCollection at: index); show: '.'; cr].].

mainIndex _ ((aPerson getMarriages) size).
mainCollection _ (aPerson getMarriages).
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: varName; show: ' married: ';
						show: (((mainCollection at: index) getSpouse) getGivenName); 
						show: ' on: '; show: ((mainCollection at: index) getDate). 
						((mainCollection at: index) getDivorceState)
							ifTrue:	[ Transcript show: ' divorced: ';
							show: ((mainCollection at: index) getDivorceDate)].
						Transcript show: '.'; cr.].].

mainIndex _ ((aPerson getRecords) size).
mainCollection _ (aPerson getRecords).
"Transcript show: mainIndex; cr.
(mainIndex = 0) ifFalse: [(mainCollection valuesDo: []).]."! !

!PersonPrinter class methodsFor: 'main methods' stamp: 'AWP 11/4/2002 12:24'!
printPerson: aPerson with: varNameIndex in: familyCollection
	"takes in a person and prints out all the method calls necessary to create this person.  The varNameIndex is used to make the variable name printed out unique"

| mainIndex mainCollection varName date |

varName _ Text fromString: 'P'.
varName append: varNameIndex asStringWithCommas.
varName _ varName asString.

(aPerson getGivenName = '') ifFalse: [Transcript show: varName; show: ' givenName: '; show: $' ;show: (aPerson getGivenName); show: $' ;show: '.'; cr].

(aPerson getSurName = '') ifFalse: [Transcript show: varName; show: ' surName: '; show: $' ;show: (aPerson getSurName); show: $' ; show: '.'; cr].

(aPerson getBirthDate isNil) ifFalse: [ date _ ((aPerson getBirthDate) asGregorian). 
									Transcript show: varName; show: ' born: (Date newDay: ';
									show: (date at: 1); show: ' month: '; show: (date at: 2); 
									show: ' year: '; show: (date at: 3); show: ')';show:'.';cr.].

(aPerson getBirthLocation = '') ifFalse: [Transcript show: varName; show: ' bornLocation: '; show: $' ; show: (aPerson getBirthLocation); show: $' ; show: '.'; cr].

(aPerson getDeathDate isNil) ifFalse: [ date _ ((aPerson getDeathDate) asGregorian). 
									Transcript show: varName; show: ' died: (Date newDay: ';
									show: (date at: 1); show: ' month: '; show: (date at: 2); 
									show: ' year: '; show: (date at: 3); show: ').'; cr
									].

(aPerson getFather isNil) ifFalse: [Transcript show: varName; show: ' hasFather: '; show: 'P',(familyCollection indexOf:(aPerson getFather)) asStringWithCommas; show: '.'; cr].

(aPerson getMother isNil) ifFalse: [Transcript show: varName; show: ' hasMother: '; show: 
'P',(familyCollection indexOf:(aPerson getMother)) asStringWithCommas; show: '.'; cr].

(aPerson getGender isNil) ifFalse: [(aPerson getGender) ifTrue: [Transcript show: varName; show: ' isMale'; show: '.'; cr] ifFalse: [Transcript show: varName; show: ' isFemale'; show: '.'; cr].].

aPerson getSiblings do:
[:sib|
	Transcript show: varName; show: ' hasSibling: '; 
	show: 'P',(familyCollection indexOf: sib)asStringWithCommas; show: '.'; cr.
].

aPerson getChildren do: 
[:kid | 
	(aPerson getGender) ifTrue: 
	[
		(kid getMother) notNil ifTrue:
		[
		Transcript show: varName; show: ' hasChild: '; show: 'P',
			(familyCollection indexOf: kid)asStringWithCommas.
		Transcript show: ' with: '; show: 
		'P',(familyCollection indexOf: (kid getMother))asStringWithCommas; show: '.'; cr
		]
		ifFalse:
		[
			Transcript show: 'P',(familyCollection indexOf: kid)asStringWithCommas;
			show: ' hasFather: ', varName, '.';cr.
		]
	] 
	ifFalse: 
	[
		(kid getFather) notNil ifTrue:
		[
			Transcript show: varName; show: ' hasChild: '; show: 'P',
				(familyCollection indexOf: kid)asStringWithCommas.
			Transcript show: ' with: '; show: 
			'P',(familyCollection indexOf: (kid getFather))asStringWithCommas; show: '.'; cr.
		]
		ifFalse:
		[
			Transcript show: 'P',(familyCollection indexOf: kid)asStringWithCommas;
			show: ' hasMother: ', varName, '.';cr.
		]
	].
].


mainIndex _ ((aPerson getAliases) size).
mainCollection _ (aPerson getAliases).
(mainIndex = 0) ifFalse: [1 to: mainIndex do: [:index | Transcript show: varName; show: ' addAlias: ';
						show: '''',(mainCollection at: index),''''; show: '.'; cr].].

mainIndex _ ((aPerson getMarriages) size).
aPerson getMarriages do: 
[:marriage|
	Transcript show: varName; show: ' married: ';
	show: ('P',(familyCollection indexOf: (marriage getSpouse))asStringWithCommas); 
	show: ' on: '.
	(marriage getDate isNil)
	ifFalse:
	[ 
		Transcript show: '(Date newDay: ',(marriage getDate day) asStringWithCommas,
				' year: ', (marriage getDate year) asString,')'.
	]
	ifTrue:
	[
		Transcript show: 'nil'.
	].

	(marriage getDivorceState) ifTrue:
	[
		Transcript show: ' divorced: ';
		show: 'Date newDay: ',(marriage getDivorceDate day) asStringWithCommas,
			' year: ', (marriage getDivorceDate year) asString.
	].
	Transcript show: '.'; cr.
].

mainIndex _ ((aPerson getRecords) size).
mainCollection _ (aPerson getRecords).
"Transcript show: mainIndex; cr.
(mainIndex = 0) ifFalse: [(mainCollection valuesDo: []).]."! !


Object subclass: #ProtoPerson
	instanceVariableNames: 'givenName surName aliases birthDate birthPlace deathDate deathPlace marriageDates mother father spouse siblings children isMale isMarried records errorList conflictList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 06:43'!
getAliases



"Version 1.0 Adam Parker 9/14/2002"
	

"Returns the aliases collection"



^aliases! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:12'!
getBirthDate



"Version 1.1 Adam Parker 9/19/2002"
	

"Access and return the birthdate Date object"



^birthDate! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:13'!
getBirthLocation



"Version 1.0 Adam Parker 9/14/2002"
	

"Returns the string of the location of birth"



^birthPlace! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:35'!
getChild: anInt



"Version 1.0 Adam Parker 9/14/2002"
	

"Returns a specific child at index anInt from the children collection"



^children at: anInt! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:35'!
getChildren



"Version 1.0 Bruce Goodwin 9/16/2002"


	 "Returns the entire collection of children"





	^children! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'blg 11/3/2002 19:36'!
getConflictList



"Version 1.0 Bruce Goodwin 11/03/2002"


	 "Returns the collection of conflicts"

	^conflictList! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'blg 9/19/2002 08:05'!
getDeathDate


"Version 1.0 Adam Parker 9/14/2002"


"accessor"


^deathDate ! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'BLG 10/22/2002 01:37'!
getDeathLocation


"Version 1.0 Adam Parker 9/14/2002"


"accessor"


^deathPlace! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'fd 9/19/2002 14:39'!
getErrorList

"Version 1.0 Adam Parker 9/19/2002"
	"Return the siblings collection"

	^errorList! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:36'!
getFather



"Version 1.0 Adam Parker 9/14/2002"
	

"Returns the father Person object for this person"



^father! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 03:16'!
getGender

"Version 1.0 Adam Parker 9/17/2002"
	"If the variable isMale is true then return 'male'"
	"If the variable isMale is false then return 'female'"
	"If the variable isMale is nil then return 'nil'"

(isMale = nil) ifTrue: [^'nil'] ifFalse: 
[ 
   (isMale) ifTrue: [^'male'] ifFalse: [^'female']
].! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:36'!
getGivenName



"Version 1.0 Adam Parker 9/14/2002"
	

"Returns this person's givenName"



^givenName! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:39'!
getMarriages



"Version 1.0 Bruce Goodwin 9/15/2002"


	"Return the Collection of marriages for this person"





	^marriageDates! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:40'!
getMother



"Version 1.0 Adam Parker 9/14/2002"
	

"Returns the mother Person object for this person"



^mother! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 10/27/2002 21:31'!
getName



"Version 1.0 Adam Parker 9/14/2002"
	

"Return the full name of the person"



	| returnString |

	returnString := givenName.
	(givenName isNil | givenName = '') 
		ifTrue: [returnString := surName]
		ifFalse: [returnString := returnString.' '.surName].

	^returnString! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 03:03'!
getNumOfChildren



"Version 1.0 Adam Parker 9/14/2002"
	

"Return the number of children this person has."

^ (children size)! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'ssc 9/14/2002 00:01'!
getNumOfSiblings



"Version 1.0 Adam Parker 9/14/2002"



"get number of siblings"



"Count through collection"! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'blg 9/19/2002 06:46'!
getRecords


"Version 1.0 Adam Parker 9/14/2002"


"accessor"


^records! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'fd 9/19/2002 14:39'!
getSiblings

"Version 1.0 Adam Parker 9/19/2002"
	"Return the siblings collection"

	^siblings! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 06:07'!
getSpouse


"Version 1.0 Adam Parker 9/14/2002"


"accessor for spouse"


^spouse! !

!ProtoPerson methodsFor: 'Accessors' stamp: 'ssc 9/14/2002 00:01'!
getSurname



"Version 1.0 Adam Parker 9/14/2002"



"accessor"



^surName! !


ProtoPerson subclass: #Person
	instanceVariableNames: ''
	classVariableNames: 'Lineage Queue '
	poolDictionaries: ''
	category: 'Geneology'!

!Person methodsFor: 'Modifiers' stamp: 'fd 9/16/2002 21:59'!
addAlias: aString


"Version 1.1 Adam Parker 9/16/2002"
	"Places a person's alias into the aliasArr iff the new alias does"
     "not create a duplicate entry in the Array"

 (aliases includes: aString) ifTrue: [Transcript show: 'dupe'

] ifFalse: [aliases add: aString].! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 10/29/2002 21:44'!
addChild: aPerson


"Version 1.0 Adam Parker 10/29/2002"
	"Places a person's alias into the child list iff the new child does"
     "not create a duplicate entry in the Collection"

 (children includes: aPerson) ifTrue: [Transcript show: 'dupe'

] ifFalse: [children add: aPerson].! !

!Person methodsFor: 'Modifiers' stamp: 'fd 9/17/2002 11:14'!
addMarriage: aMarriage


"Version 1.0 Adam Parker 9/14/2002"
	"Adds a marriage object to the marriageDates collection"



marriageDates add: aMarriage.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/4/2002 12:41'!
addSibling: aPerson


"Version 1.0 Adam Parker 9/19/2002"
	
"Places aPerson into this person's siblings collection"

	(aPerson getFather isNil)
	ifTrue: [aPerson hasFather: self getFather.].
	(aPerson getMother isNil)
	ifTrue: [aPerson hasMother: self getMother.].

	(self getFather isNil)
	ifTrue: [self hasFather: aPerson getFather.].
	(self getMother isNil)
	ifTrue: [self hasMother: aPerson getMother.].

	siblings add: aPerson.
	aPerson hasSiblingMirror: self.

! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/3/2002 20:54'!
born: aDate


"Version 1.0 Adam Parker 11/3/2002"
	"Takes in the person's birth date and sets it"


birthDate := aDate.! !

!Person methodsFor: 'Modifiers' stamp: 'fd 9/17/2002 11:14'!
born: aDate location: aString


"Version 1.0 Adam Parker 9/14/2002"
	"Takes in the person's birth date and their birth location and sets"
	"the corrosponding instance variables to the input values"



birthDate := aDate.


birthPlace := aString.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/3/2002 20:12'!
bornLocation: inputLocation

"Version 1.0 by Adam Parker on 11/3/2002"
	"Set just the birth location of an individual"

birthPlace := inputLocation.! !

!Person methodsFor: 'Modifiers' stamp: 'blg 11/3/2002 19:15'!
check
	"comment stating purpose of message"
ErrorReport new.
Traversal traverseFrom: self do: (ErrorReport sendBlock).
ErrorReport printMyself.
Transcript show: '-';cr;show: '-=-=-=-';cr;show: 'Beginning of Conflict report';cr.
Conflict new.
Traversal traverseFrom: self do: (Conflict sendBlock).
Conflict printMyself.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/3/2002 19:35'!
deleteAlias: index

"Version 1.0 by Adam Parker on 11/3/2002"
	"Deletes a specific alias from the collection"

	aliases remove: (aliases at: index).! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/4/2002 12:55'!
deleteAllAffiliationsOf: aPerson

"Version 1.0 by Adam Parker written on 10/31/2002"
	" removes all references to aPerson from this person"

"Check Father"
	| tmpCollection |
	(father = aPerson)
	ifTrue: [father := nil. ^true.].

"Check Mother"
	(mother = aPerson)	
	ifTrue: [mother := nil. ^true.].

"Check Siblings"
	(siblings includes: aPerson)
	ifTrue: [siblings remove: aPerson.].

"Check Spouse"
	(spouse = aPerson)
	ifTrue: [spouse := nil. isMarried := false.].
	

"Check Mariages"
	tmpCollection := OrderedCollection new.
	(marriageDates isNil)
	ifFalse:
	[
		marriageDates do: [:each | (each getSpouse = aPerson)ifFalse: [tmpCollection add: each]].
	].

"Check Children"
	(children includes: aPerson)
	ifTrue: [children := children copyWithout: aPerson.].! !

!Person methodsFor: 'Modifiers' stamp: 'fd 9/16/2002 22:11'!
died: aDate


"Version 1.0 Adam Parker 9/14/2002"
	"Sets the date of death for a person"
	"Expects a date object"



deathDate := aDate.! !

!Person methodsFor: 'Modifiers' stamp: 'fd 9/17/2002 11:15'!
givenName: aString


"Version 1.0 Adam Parker 9/14/2002"
	"Sets a person's given name to the value of aString"



givenName := aString! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/4/2002 21:43'!
hasChild: aPerson with: otherParent


"Version 1.3 Adam Parker 10/29/2002"
	"Creates a new entry into the children collection variable"
	"The new entry is a "

"Parents must be of different genders"
"ONLY REGECT SAME GENDERS"
((self getGender) = (otherParent getGender) & ((self getGender) = 'nil') not) ifTrue: [^0].

"Bullet Proofing: assign self and otherParent to aPerson's parents"
"WE DON'T KNOW GENDERS"
(isMale = true) 
	ifTrue: [aPerson hasFather: self. aPerson hasMother: otherParent.] 
	ifFalse: [aPerson hasMother: self. aPerson hasFather: otherParent.].


"Bullet Proofing: make sure that otherParent has the Child as well"
otherParent addChild: aPerson.

"Bullet Proofing: make all siblings have the same parents as the one just added (per the definition of siblin)"
(aPerson getSiblings) do: [:each | each hasFather: (aPerson getFather); hasMother: (aPerson getMother).].

"Add this child to self only if it's not a dupe"
(children includes: aPerson) ifTrue: [] ifFalse: [children add: aPerson].

^1.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/4/2002 21:02'!
hasFather: aPerson



"Version 1.1 Scott Camp 9/17/2002"
	"Set aPerson as this person's father"
	"MIRROR: The code also sets this person as aPerson's child."

"check to see if there's already a father. if so then we're CHANGING the mother, not adding one. so we'll remove ourselves from the old mother's children list."

father notNil ifTrue:
[
	father getChildren remove: self ifAbsent: [].
].

(aPerson isNil)
ifFalse:
[
	
father := aPerson.
	aPerson hasChildMirror: self with: self getMother.
].! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/4/2002 21:02'!
hasMother: aPerson

 "Version 1.2 Bruce Goodwin 11/03/2002"

	"Set aPerson as this person's mother"

	"MIRROR: The code also sets this person as aPerson's child." 

"check to see if there's already a mother. if so then we're CHANGING the mother, not adding one. so we'll remove ourselves from the old mother's children list."

mother notNil ifTrue:
[
	mother getChildren remove: self ifAbsent: [].
].


(aPerson isNil)
ifFalse:
[
 mother := aPerson.
aPerson hasChildMirror: self with: self getFather.
].! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/4/2002 21:03'!
hasSibling: aPerson

"Version 1.3 Adam Parker 9/19/2002"
	
"Places aPerson into this person's siblings collection"
	"This Method has a great deal of preemptive mirror handling"
	"merging of sibling collection allows every sibling to know about"
	"every other sibling"

		" This program assumes that Person A is a sibling of Person B iff their parents are "
		" the same. If there is one parent match and another unkown, then assume they"
		" are siblings and parents are the same."

	(aPerson getFather isNil)
	ifTrue: [ (self getFather isNil)ifFalse:[aPerson hasFather: self getFather.]].
	(aPerson getMother isNil)
	ifTrue: [ (self getMother isNil)ifFalse:[aPerson hasMother: self getMother.]].

	(self getFather isNil)
	ifTrue: [(aPerson getFather isNil)ifFalse:[self hasFather: aPerson getFather.]].
	(self getMother isNil)
	ifTrue: [(aPerson getMother isNil)ifFalse:[self hasMother: aPerson getMother.]].

	

		" merge the two interested to get differences"
	self mergeSiblings: aPerson.

		" Add each person to the other's sibling list"
	siblings add: aPerson.
	aPerson hasSiblingMirror: self.

		" Propigate union of siblings list among children."
	siblings do: [:each | each mergeSiblings: self].
	(aPerson getSiblings) do: [:each | 
							(self getFather isNil) ifFalse:[each hasFather: (self getFather)]. 
							(self getMother isNil) ifFalse:[each hasMother:(self getMother)].
							each mergeSiblings: aPerson].
! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:11'!
isFemale


"Version 1.0 Adam Parker 9/14/2002"
	
"Assigns this person's isMale gender flag to be false"
	"Thereby indicating this person is female."


isMale := false.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:12'!
isMale


"Version 1.0 Adam Parker 9/14/2002"
	
"Assigns this person's isMale gender flag to be true"
	"Thereby indicating this person is male."


isMale := true.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:13'!
isMarried


"Version 1.0 Adam Parker 9/14/2002"
	
"Sets the isMarried flag to true"


isMarried := true.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:15'!
isNotMarried


"Version 1.0 Adam Parker 9/14/2002"
	"Sets the isMarried flag to false"


isMarried := false.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 11/3/2002 22:20'!
married: aPerson on: aDate

"Version 1.1 Scott Camp 9/17/2002"
	
"sets this persons spouse object to aPerson"
     "creates a Marriage object between this person and aPerson"
	"adds the new marriage object to the collection of marriages"
	"MIRROR: sets up the marriage relationship between this person and aPerson"



| aMarriage |
Transcript show: (aPerson getName),' ',(self getName).
(self getGender = aPerson getGender)
ifFalse:
[
	
spouse := aPerson.
	
aMarriage := Marriage new: aDate with: aPerson.
	
self addMarriage: aMarriage.
	self isMarried.
	aPerson marriedMirror: self on: aDate.
	^1.
]
ifTrue:
[
	^0.
]! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:47'!
married: aPerson on: aDate divorced: aSecondDate


"Version 1.1 Scott Camp 9/17/2002"
     "creates a Marriage object between this person and aPerson"
	"adds the new marriage object to the collection of marriages"


| aMarriage |


aMarriage := Marriage new: aDate with: aPerson divorced: aSecondDate.

self addMarriage: aMarriage.

aPerson marriedMirror: self on: aDate divorced: aSecondDate.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 04:20'!
mergeSiblings: aPerson

"Version 1.0 Adam Parker 9/19/2002"
	
"Makes sure that self's siblings list and aPerson's list match data"

((aPerson getSiblings) reject: [:each | each == self]) 
do: [:newSibling | (siblings includes: newSibling) ifFalse: [self addSibling: newSibling]]! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:51'!
record: key as: value


"Version 1.2 Bruce Goodwin 9/18/2002"
	"Takes in a key and value pair, stores them as an association in the dictionary record"
	"the variable record is a Dictionary - which is a collection of key,value pairs"

records add: (Association key: key value: value).! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:53'!
setBirthDate: aDate


"Version 1.0 Adam Parker 9/14/2002"
	
"sets the BirthDate variable to aDate"


birthDate := aDate.! !

!Person methodsFor: 'Modifiers' stamp: 'AWP 9/19/2002 00:53'!
surName: aString


"Version 1.0 Adam Parker 9/14/2002"
	
"set person's surName"


surName := aString! !


!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:35'!
displayFather: position at: level side: side

"Version 1.0 Adam Parker 9/19/2002"

	"Displays the father object (which is always drawn on the left)"
	"Displays siblings"
	"Displays Parents"

	

	| offset |



	(father = nil) ifFalse: [

		

		offset := -25@-10.



			"Draw the stick figure representation of the person"

		father drawPerson: position+offset.



			"Display Father's siblings"

		

			"Display Father's parents."

	((father getMother = nil) & (father getFather = nil)) ifFalse: 

	[ father displayParentsLeft: position+offset at: level-1 side: side.].

	].

! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:35'!
displayMother: position at: level side: side

"Version 1.0 Adam Parker 9/19/2002"

	"Displays the mother object (which is always drawn on the right)"
	"Displays siblings"
	"Displays Parents"



	| offset |



	(mother = nil) ifFalse: [

	offset := 24@-10.



		"Draw the stick figure representation of the person"

	mother drawPerson: position+offset.

	

		"Display mother's siblings"

	

		"Display Mother's parents."

	((mother getMother = nil) & (mother getFather = nil)) ifFalse: 

	[ mother displayParentsRight: position+offset at: level-1 side: side.].

	]

! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:05'!
displayName: position for: person

"Version 1.0 Adam Parker 9/17/2002"

	"Displays the (first) name for the person being displayed"

	

	| displayName offset nameSize |



	"Display the person's Name"

		(person getGivenName isNil) ifTrue: [displayName _ 'Unnamed' asDisplayText. nameSize := 7.]

		ifFalse: 
		[displayName _ person getGivenName asDisplayText. nameSize := person getGivenName size.].

		displayName foregroundColor: (Color red) backgroundColor: (Color white).



	"Calculate the offset that will display the person's name below thier figure"

		(nameSize odd) ifTrue: [nameSize := nameSize - 1].

		offset :=  (nameSize/2*-8)@23.



		displayName displayAt: position+offset.

! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:10'!
displayParents: position at: level

"Version 1.0 Adam Parker 9/18/2002"

	"Used to display the first set of parents for the key person"



	| pen offset |



	offset := 0@-60.



	"Create the connecting lines from parent to sibling"

		pen _ Pen new.



		pen up.



		pen goto: position.

		pen go: 0@15.

		pen color: (Color black).

	

		pen down.

	

		pen go: 40; turn: 90; go: 12; turn: 180; go: 24.



	"Display Father"

		self displayFather: (position+offset) at: level-1 side: 0.

	"Display Mother"

		self displayMother: (position+offset) at: level-1 side: 1.









! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:21'!
displayParentsLeft: position at: level side: side

"Version 1.0 Adam Parker 9/19/2002"

	"Create a left branch for the set of parents"



	| pen offset |



	"Create the connecting lines from parent to sibling"

		pen _ Pen new.



		pen up.



		pen goto: position.

		pen go: 0@15.

		pen color: (Color black).

	

		pen down.

		(side = 0) ifTrue: [offset := (level*12-20)@-45.] ifFalse: [offset := (-1*level)@-45.].

		pen goto: position+offset.

		pen turn: 90; go: 12; turn: 180; go: 24.



	"Display Father"

		self displayFather: (position+offset) at: level-1 side: side.



	"Display Mother"

		self displayMother: (position+offset) at: level-1 side: side.





! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:21'!
displayParentsRight: position at: level side: side

"Version 1.0 Adam Parker 9/19/2002"

	"Create a right branch for the set of parents"	



	| pen offset |



	"Create the connecting lines from parent to sibling"

		pen _ Pen new.



		pen up.



		pen goto: position.

		pen go: 0@15.

		pen color: (Color black).

	

		pen down.



		(side = 1) ifTrue: [offset := (level*-12+20)@-45.] ifFalse: [offset := level@-45.].

		pen goto: position+offset.

		pen turn: 90; go: 12; turn: 180; go: 24.



	"Display Father"

		self displayFather: (position+offset) at: level-1 side: side.

	"Display Mother"

		self displayMother: (position+offset) at: level-1 side: side.! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:29'!
displaySpouse: person at: position 


"Version 1.0 Adam Parker 9/19/2002"
	"METHOD NOT COMPLETE"


	Transcript show: person givenName.

		"Draw the stick figure representation of the person"

	person drawPerson: position.

! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:24'!
drawPerson: position


"Version 1.0 Adam Parker 9/19/2002"
	"Method that calls methods to draw the stick figure and display his/her name"


		"Draw the stick figure representation of the person"

			self drawStickFigure: position.



		"Display the person's name below the stick figure"		

			self displayName: position for: self.



! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:23'!
drawStickFigure: position

"Version 1.0 Adam Parker 9/19/2002"

	"Draw the Stick figure that represents aperson person."

	

	| head pen |



	"Create a circle for the head of the stick figure representation"

		head := Circle new.

		head radius: 4.

		head center: position.

		"head fillColor: (Color Black)."

		head displayOn: Display.



	"Create the Body using an instance of Pen"

		pen _ Pen new.



		pen up.



		pen goto: position.

	

		pen go: 0@-3.

		pen turn: 180.

		pen color: (Color black).

	

		pen down.

	

		pen go: 4; turn: 90; go: 5; turn: 180; go: 10; turn: 180; go: 5; turn: -90; go: 6.

		pen turn: 35; go: 8; turn: 180; go: 8; turn: 120; go: 8.! !

!Person methodsFor: 'Visualization' stamp: 'AWP 10/27/2002 21:33'!
getName


"Version 1.0 Adam Parker 9/14/2002"
	
"Return the full name of the person"


	| returnString |

	returnString := givenName.
	(givenName isNil & givenName = '') 
		ifTrue: [returnString := surName]
		ifFalse: [returnString := returnString,' ',surName].

	(returnString isNil | returnString = '') ifTrue: [returnString := '-'].

	^returnString! !

!Person methodsFor: 'Visualization' stamp: 'AWP 9/19/2002 01:06'!
visualize

"Version 1.0 Adam Parker 9/18/2002"

	"General method that begins the build display process for a given person's family tree."



	| position pallet |	



	"Create a form area for the display"

		pallet := Form extent: 800@600.

		

(pallet) fillWhite display.	



	"Determine where to place the initial person base on marital status."

		(isMarried) ifTrue: [position := 390@300] ifFalse: [position := 400@300].

	"self displaySpouse: position."



	"Draw the image of the first person"

		self drawPerson: position.



	"Draw the two parents for this person."

		self displayParents: position at: -1.

! !


!Person methodsFor: 'Accessors' stamp: 'AWP 11/3/2002 19:33'!
getAliasIndex: anAlias

"Version 1.0 by Adam Parker on 11/3/2002"
	"returns the index of an alias"

	^aliases indexOf: anAlias.! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:12'!
getBirthDate


"Version 1.1 Adam Parker 9/19/2002"
	
"Access and return the birthdate Date object"


^birthDate! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:12'!
getBirthLocation


"Version 1.0 Adam Parker 9/14/2002"
	
"Returns the string of the location of birth"


^birthPlace! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:32'!
getChild: anInt


"Version 1.0 Adam Parker 9/14/2002"
	
"Returns a specific child at index anInt from the children collection"


^children at: anInt! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:33'!
getChildren


"Version 1.0 Bruce Goodwin 9/16/2002"

	 "Returns the entire collection of children"



	^children! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:33'!
getDeathDate


"Version 1.0 Adam Parker 9/14/2002"
	
"Returns the deathDate Date object"


^deathDate! !

!Person methodsFor: 'Accessors' stamp: 'ssc 9/19/2002 04:11'!
getErrorList
	"accessor"
	^ errorList! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:34'!
getFather


"Version 1.0 Adam Parker 9/14/2002"
	
"Returns the father Person object for this person"


^father! !

!Person methodsFor: 'Accessors' stamp: 'ssc 9/19/2002 04:25'!
getGender
"Version 1.2 Scott Camp 9/17/2002"
"accessor"
^(isMale)! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:35'!
getGivenName


"Version 1.0 Adam Parker 9/14/2002"
	
"Returns this person's givenName"


^givenName! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:39'!
getMarriages


"Version 1.0 Bruce Goodwin 9/15/2002"

	"Return the Collection of marriages for this person"



	^marriageDates! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:40'!
getMother


"Version 1.0 Adam Parker 9/14/2002"
	
"Returns the mother Person object for this person"


^mother! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 02:59'!
getNumOfChildren


"Version 1.0 Adam Parker 9/14/2002"
	
"Return the number of children this person has."

^ (children size)! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 03:04'!
getNumOfSiblings


"Version 1.0 Adam Parker 9/14/2002"
	
"get number of siblings"

^(siblings size)
! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 06:19'!
getSiblings

"Version 1.0 Bruce Goodwin 9/19/2002"

	"comment stating purpose of message"



	^siblings! !

!Person methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 00:28'!
getSurName

"Version 1.0 Scott Camp 9/17/2002"

"accessor"

^(surName)! !

!Person methodsFor: 'Accessors' stamp: 'ssc 9/14/2002 00:01'!
getSurname

"Version 1.0 Adam Parker 9/14/2002"

"accessor"

^surName! !


!Person methodsFor: 'Testing' stamp: 'ssc 9/14/2002 00:01'!
printOff


"Version 1.0 Adam Parker 9/14/2002"


"tester"


(givenName isNil) ifFalse: [^givenName]


ifTrue: [^'no given name'].! !


!Person methodsFor: 'mirrorlink functions' stamp: 'AWP 10/31/2002 11:03'!
hasChildMirror: aPerson with: otherParent

"Version 1.0 Scott Camp 9/17/2002"
	
"adds a sibling to the list of siblings this person has"

"Add this child to self only if it's not a dupe"
	(children includes: aPerson) ifTrue: [Transcript show: 'dupe'
	] ifFalse: [children add: aPerson].! !

!Person methodsFor: 'mirrorlink functions' stamp: 'fd 9/17/2002 23:50'!
hasFatherMirror: aPerson

"Version 1.0 Scott Camp 9/17/2002"
	
"set a person's father"



father := aPerson.! !

!Person methodsFor: 'mirrorlink functions' stamp: 'fd 9/17/2002 23:50'!
hasMotherMirror: aPerson	

"Version 1.0 Scott Camp 9/17/2002"
	
"set a person's mother"



mother := aPerson.! !

!Person methodsFor: 'mirrorlink functions' stamp: 'fd 9/17/2002 23:50'!
hasSiblingMirror: aPerson

"Version 1.0 Scott Camp 9/17/2002"
	
"adds a sibling to the list of siblings this person has"


siblings add: aPerson.! !

!Person methodsFor: 'mirrorlink functions' stamp: 'AWP 11/3/2002 22:03'!
marriedMirror: aPerson on: aDate

"Version 1.0 Scott Camp 9/17/2002"
"set a person's spouse and time of marriage"

| aMarriage |
spouse := aPerson.
aMarriage := Marriage new: aDate with: aPerson.
self addMarriage: aMarriage.
self isMarried.! !

!Person methodsFor: 'mirrorlink functions' stamp: 'fd 9/17/2002 23:51'!
marriedMirror: aPerson on: aDate divorced: aSecondDate

"Version 1.0 Scott Camp 9/17/2002"
	
"set a person's spouse and time of marriage"


| aMarriage |

aMarriage := Marriage new: aDate with: aPerson divorced: aSecondDate.

self addMarriage: aMarriage.! !


!Person methodsFor: 'Searching' stamp: 'blg 9/19/2002 10:28'!
searchFor: aQuery
	"pass this method a Query object initialized to any attributes that you want positive results to contain. i return a Collection of people."

	| results caseBlock |
	results _ OrderedCollection new.
	caseBlock _
{['born']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getBirthDate isNil) ifFalse:
		[((thisPerson getBirthDate) = (aQuery getBirthDate)) ifTrue:[results add: thisPerson]
		]
	]].
['bornIn']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getBirthLocation isNil) ifFalse:
		[((thisPerson getBirthLocation) = (aQuery getBirthLocation)) ifTrue:[results add: thisPerson]
		]
	]].
['died']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getDeathDate isNil) ifFalse:
		[((thisPerson getDeathDate) = (aQuery getDeathDate)) ifTrue:[results add: thisPerson]
		]
	]].
['generalSearch']->[Traversal traverseFrom: self do:[:thisPerson|
	((thisPerson getSurname isNil)not  and: [(' ' findSubstring: (aQuery getGeneralString) in: (thisPerson getSurname) startingAt: 1 matchTable: ((0 to: 255) as: ByteArray)) > 0]) 
	ifTrue: [results add: thisPerson].
	((results includes: thisPerson)not and: [(thisPerson getGivenName isNil)not] and: [(' ' findSubstring: (aQuery getGeneralString) in: (thisPerson getGivenName) startingAt: 1 matchTable: ((0 to: 255) as: ByteArray)) > 0]) 
	ifTrue: [results add: thisPerson].
	((results includes: thisPerson)not and: [(thisPerson getBirthLocation isNil)not] and: [(' ' findSubstring: (aQuery getGeneralString) in: (thisPerson getBirthLocation) startingAt: 1 matchTable: ((0 to: 255) as: ByteArray)) > 0]) 
	ifTrue: [results add: thisPerson].
	(thisPerson getAliases isEmptyOrNil) ifFalse:
		[thisPerson getAliases do:
			[:thisAlias|  
			((results includes: thisPerson)not and: [(' ' findSubstring: (aQuery getGeneralString) in: (thisAlias) startingAt: 1 matchTable: ((0 to: 255) as: ByteArray)) > 0]) ifTrue: [results add: thisPerson]]
		].

	(thisPerson getRecords isEmptyOrNil) ifFalse:
		[thisPerson getRecords do:
			[:thisValue|
			((results includes: thisPerson)not and: [(' ' findSubstring: (aQuery getGeneralString) in: (thisValue) startingAt: 1 matchTable: ((0 to: 255) as: ByteArray)) > 0])  ifTrue: [results add: thisPerson]]
		]


	]].
['givenName']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getGivenName isNil) ifFalse:
		[((thisPerson getGivenName) = (aQuery getGivenName)) ifTrue:[results add: thisPerson]
		]
	]].
['hasAlias']->[Traversal traverseFrom: self do: [:thisPerson|
	(thisPerson getAliases isEmptyOrNil) ifFalse:
		[thisPerson getAliases do:
			[:thisAlias| (thisAlias = aQuery getAlias) ifTrue: [results add: thisPerson]]
		]
	]].
['anyAlias']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getAliases isEmpty) ifFalse:
		[results add: thisPerson]
	]].
['hasChild']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getChildren isEmptyOrNil) ifFalse:
		[thisPerson getChildren do:
			[:thisChild| (thisChild = aQuery getChild) ifTrue: [results add: thisPerson]]
		]
	]].
['hasInfo']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getRecords isEmptyOrNil) ifFalse:
		[thisPerson getRecords associationsDo:
			[:thisAssoc| (thisAssoc = aQuery getRecord) ifTrue: [results add: thisPerson]]
		]
	]].
['hasParent']->[results _ (aQuery getParent) getChildren].
['hasSibling']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getSiblings isEmptyOrNil) ifFalse:
		[thisPerson getSiblings do:
			[:thisSibling| (thisSibling = (aQuery getSibling)) ifTrue: [results add: thisPerson]]
		]
	]].
['isFemale']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getGender isNil) ifFalse:
		[((thisPerson getGender) = 'female') ifTrue:[results add: thisPerson]
		]
	]].
['isMale']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getGender isNil) ifFalse:
		[((thisPerson getGender) = 'male') ifTrue:[results add: thisPerson]
		]
	]].
['livedOn']->[Traversal traverseFrom: self do:[:thisPerson|
	((((thisPerson getBirthDate) isNil)not) and: [(thisPerson getDeathDate) isNil]) ifTrue:
		[(thisPerson getBirthDate = aQuery getLivedOnDate) ifTrue: [results add: thisPerson]
		].
	(((thisPerson getBirthDate) isNil) and: [((thisPerson getDeathDate) isNil)not]) ifTrue:
		[(thisPerson getDeathDate = aQuery getLivedOnDate) ifTrue: [results add: thisPerson]
		].
	((((thisPerson getBirthDate) isNil)not) and: [((thisPerson getDeathDate) isNil)not]) ifTrue:
		[((thisPerson getDeathDate >= aQuery getLivedOnDate) and: [thisPerson getBirthDate <= aQuery getLivedOnDate]) ifTrue: [results add: thisPerson]
		].
]].
['livedIn']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getBirthLocation isNil) ifFalse:
		[((thisPerson getBirthLocation) = (aQuery getLivedInString)) ifTrue:[results add: 			thisPerson]
		].
		
	(thisPerson getRecords isEmptyOrNil) ifFalse:
		[thisPerson getRecords do:
			[:thisVal| (thisVal = aQuery getLivedInString) ifTrue: [results add: thisPerson]
			]
		]
	]].
['married']->[Traversal traverseFrom: self do:[:thisPerson|
	((thisPerson getMarriages size) = 0) ifFalse:
		[
		(thisPerson getMarriages) do:
			[:marriage|
			(marriage getSpouse = aQuery getSpouse) ifTrue:
				[
					results add: thisPerson.
				].
			].
		].
	]].
['surName']->[Traversal traverseFrom: self do:[:thisPerson|
	(thisPerson getSurname isNil) ifFalse:
		[((thisPerson getSurname) = (aQuery getSurname)) ifTrue:[results add: thisPerson]
		]
	]]}.

	(aQuery type) caseOf: caseBlock.
	^results.! !


!Person methodsFor: 'Initialization' stamp: 'blg 11/3/2002 22:27'!
printConflictList
	"print out the contents of a Persons errorList to transcript"

Transcript show: 'Conflict Report for person: first name - '.
(self getGivenName isNil) ifTrue: [Transcript show: ' undefined '] ifFalse: [Transcript show:' ' ,  self getGivenName , ' '].
Transcript show: ' last name - '.
(self getSurName isNil) ifTrue: [Transcript show: ' undefined '; cr] ifFalse: [Transcript show:' ' , self getSurName , ' '; cr].
"
(index > 0) ifTrue: [1 to: index do: [:i | Transcript show: (errorList at: i); cr]].
"
conflictList do: [:err| Transcript show: err; cr].! !

!Person methodsFor: 'Initialization' stamp: 'blg 11/3/2002 19:08'!
printErrorList
	"print out the contents of a Persons errorList to transcript"
"| index |
index _ errorList size."
Transcript show: 'Error Report for person: first name - '.
(self getGivenName isNil) ifTrue: [Transcript show: ' undefined '] ifFalse: [Transcript show:' ' ,  self getGivenName , ' '].
Transcript show: ' last name - '.
(self getSurName isNil) ifTrue: [Transcript show: ' undefined '; cr] ifFalse: [Transcript show:' ' , self getSurName , ' '; cr].
"
(index > 0) ifTrue: [1 to: index do: [:i | Transcript show: (errorList at: i); cr]].
"
errorList do: [:err| Transcript show: err; cr].! !

!Person methodsFor: 'Initialization' stamp: 'fd 9/19/2002 14:44'!
setAliases: aCollection


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the aliases collection to the passed in collection"

	
aliases := aCollection.! !

!Person methodsFor: 'Initialization' stamp: 'fd 9/19/2002 14:43'!
setChildren: aCollection


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the children collection to the passed in collection"

	
children := aCollection.! !

!Person methodsFor: 'Initialization' stamp: 'blg 11/3/2002 19:37'!
setConflictList: aCollection


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the conflictList collection to the passed in collection"

	
conflictList := aCollection.


! !

!Person methodsFor: 'Initialization' stamp: 'fd 9/19/2002 14:41'!
setErrorList: aCollection


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the errorList collection to the passed in collection"

	
errorList := aCollection.


! !

!Person methodsFor: 'Initialization' stamp: 'fd 9/19/2002 14:41'!
setMarriageDates: aCollection


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the marriageDates collection to the passed in collection"

	
marriageDates := aCollection.! !

!Person methodsFor: 'Initialization' stamp: 'fd 9/19/2002 14:43'!
setRecordsArray: aDictionary


"Version 1.1 Adam Parker 9/19/2002"
	
"set the records to the value of the passed in dictionary"

	
records := aDictionary! !

!Person methodsFor: 'Initialization' stamp: 'fd 9/19/2002 14:42'!
setSiblings: aCollection


"Version 1.0 Adam Parker 9/14/2002"
	
"Set the siblings collection to the passed in collection"

	
siblings := aCollection.


! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Person class
	instanceVariableNames: ''!

!Person class methodsFor: 'as yet unclassified' stamp: 'AWP 10/31/2002 10:52'!
new


"Version 1.1 Adam Parker 9/17/2002"
	
"the new method that creates a new instance of class Person"


| tempPerson |


	tempPerson := super new.

	tempPerson setRecordsArray: (Dictionary new).

	tempPerson setAliases: (OrderedCollection new: 1).

	tempPerson setSiblings: (OrderedCollection new: 1).

	tempPerson setChildren: (OrderedCollection new: 1).

	tempPerson setMarriageDates: (OrderedCollection new: 1).
	tempPerson setErrorList: (OrderedCollection new).

	tempPerson isNotMarried. 
	tempPerson givenName:''.
	tempPerson surName: ''.
	tempPerson born: nil location: ''.
	tempPerson died: nil.
	tempPerson isMale.

	^tempPerson.	! !


!Person class methodsFor: 'Visualize' stamp: 'BLG 10/21/2002 21:06'!
visualize: aPerson

"Version 1.0 Adam Parker 9/20/2002"
	"Method to visualize a person's tree using morphic"

	| world |

	world := GeneologyMap new.! !


ProtoPerson subclass: #Query
	instanceVariableNames: 'sibling parent child alias livedIn livedOn genString queryType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:40'!
setAlias: aString
	"modifier for the class methods"

	alias _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:48'!
setBDate: aDate
	"modifier for the class methods"

	birthDate _ aDate.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:52'!
setBPlace: aString
	"modifier for the class methods"

	birthPlace _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:44'!
setChild: aPerson
	"modifier for the class methods"

	child _ aPerson.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:48'!
setDDate: aDate
	"modifier for the class methods"

	deathDate _ aDate.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 17:42'!
setGName: aString
	"modifier for the class methods"

	givenName _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 20:49'!
setGenString: aString
	"modifier for the class methods"

	genString _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 20:49'!
setLivedInPlace: aString
	"modifier for the class methods"

	livedIn _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 20:48'!
setLivedOnDate: aDate
	"modifier for the class methods"

	livedOn _ aDate.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:44'!
setParent: aPerson
	"modifier for the class methods"

	parent _ aPerson.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/19/2002 00:07'!
setQType: aString
	"modifier for the class methods"

	queryType _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/19/2002 06:47'!
setRecord: keyObject as: valueObject
	"modifier for the class methods"

	record _ (Association key: keyObject value: valueObject).! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 17:42'!
setSName: aString
	"modifier for the class methods"

	surName _ aString.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:43'!
setSibling: aPerson
	"modifier for the class methods"

	sibling _ aPerson.! !

!Query methodsFor: 'private modifiers' stamp: 'blg 9/18/2002 18:47'!
setSpouse: aPerson
	"modifier for the class methods"

	spouse _ aPerson.! !


!Query methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 06:46'!
getAlias


"Version 1.0 Bruce Goodwin 9/19/2002"
	
"Returns the Query Alias"

^alias! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/18/2002 20:47'!
getChild
	"get the child this query might be looking for"

	^child! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/18/2002 20:54'!
getGeneralString
	"get the general information this query might be looking for"

	^genString! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/18/2002 20:52'!
getLivedInString
	"get the name of a place a person lived that this query might be looking for"

	^livedIn! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/18/2002 20:52'!
getLivedOnDate
	"get the date a person may have been alive on that this query might be looking for"

	^livedOn! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/18/2002 20:47'!
getParent
	"get the parent this query might be looking for"

	^parent! !

!Query methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 06:47'!
getRecord


"Version 1.0 Bruce Goodwin 9/19/2002"
	
"Returns the Query Record"


^records! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/18/2002 20:46'!
getSibling
	"get the sibling this query might be looking for"

	^sibling! !

!Query methodsFor: 'Accessors' stamp: 'AWP 9/19/2002 06:46'!
getSpouse


"Version 1.0 Bruce Goodwin 9/19/2002"
	
"Returns the Query Alias"

^spouse! !

!Query methodsFor: 'Accessors' stamp: 'blg 9/19/2002 03:05'!
type
	"get the general information this query might be looking for"

	^queryType! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Query class
	instanceVariableNames: ''!

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:56'!
born: aDate
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setBDate: aDate.
	tQuery setQType: 'born'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:56'!
bornIn: aString
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setBPlace: aString.
	tQuery setQType: 'bornIn'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:56'!
died: aDate
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setDDate: aDate.
	tQuery setQType: 'died'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:55'!
generalSearch: aString
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setGenString: aString.
	tQuery setQType: 'generalSearch'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:55'!
givenName: aString
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setGName: aString.
	tQuery setQType: 'givenName'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:58'!
hasAlias
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setQType: 'anyAlias'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:32'!
hasAlias: aString
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setAlias: aString.
	tQuery setQType: 'hasAlias'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:32'!
hasChild: aPerson
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setChild: aPerson.
	tQuery setQType: 'hasChild'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:33'!
hasInfo: keyObject as:  valueObject
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setRecord: keyObject as: valueObject.
	tQuery setQType: 'hasInfo'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:33'!
hasParent: aPerson
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setParent: aPerson.
	tQuery setQType: 'hasParent'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:33'!
hasSibling: aPerson
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setSibling: aPerson.
	tQuery setQType: 'hasSibling'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:34'!
isFemale
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setQType: 'isFemale'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:34'!
isMale
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setQType: 'isMale'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:33'!
livedIn: aString
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setLivedInPlace: aString.
	tQuery setQType: 'livedIn'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 02:33'!
livedOn: aDate
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setLivedOnDate: aDate.
	tQuery setQType: 'livedOn'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:34'!
married: aPerson
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setSpouse: aPerson.
	tQuery setQType: 'married'.
	^tQuery! !

!Query class methodsFor: 'instance creation' stamp: 'blg 9/19/2002 00:34'!
surName: aString
	"create a Query object to be passed to Person searchFor: that has the person's given name as its search criterion"

	| tQuery |
	tQuery _ super new.
	tQuery setSName: aString.
	tQuery setQType: 'surName'.
	^tQuery! !


Object subclass: #RelationLine
	instanceVariableNames: 'end1 end2 line type '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!RelationLine methodsFor: 'initialization' stamp: 'AWP 10/30/2002 23:17'!
initializeFrom: fromStickFigure to: toStickFigure
"Version 1.0 Bruce Goodwin 10/27/2002"
	"initialize this line."

	
	end1 _ fromStickFigure.
	end1 addRelation: self.
	end2 _ toStickFigure.

		line _ LineMorph newSticky makeForwardArrow.
		line borderWidth: 2; borderColor: (Color green).
		line setVertices: {(end1 center) rounded. end1 referencePosition + (end1 width@0)}.

	(toStickFigure isNil) ifTrue:
	[
		line setCenteredBalloonText: 'Drag me, fool';
			on: #mouseDown send: #doDown:with: to: self;
			on: #mouseMove send: #trackDirectionArrow:with: to: self;
			on: #mouseUp send: #doUp:with: to: self.
			fromStickFigure owner addMorphFront: line.
	]
	ifFalse:
	[
		line setVertices: {(end1 center) rounded. (end2 center) rounded}.
		line makeNoArrows.
		end2 addRelation: self.
		fromStickFigure owner addMorphBack: line.
	].! !

!RelationLine methodsFor: 'initialization' stamp: 'AWP 10/31/2002 11:34'!
setType: aType

"Version 1.0 written by Adam Parker on 10/31/2002"
	"sets this relationLine's type"

type := aType.! !


!RelationLine methodsFor: 'rubberBandyNess' stamp: 'blg 10/28/2002 16:43'!
doDown: anEvent with: shaft
"Version 1.0 Bruce Goodwin 10/27/2002"
	"i don't really do anything at all, i'm only here to make the rubberbandyness work. i don't even know why i need to do this."

"	Transcript show: 'mouse down!!'."
! !

!RelationLine methodsFor: 'rubberBandyNess' stamp: 'AWP 11/4/2002 21:33'!
doUp: anEvent with: theLine
"Version 1.0 Bruce Goodwin 10/28/2002"
	"when the user lets go, i check to see if the user let go over a person. if so, i become a relation line sitting between 2 people, otherwise i stay a rubber band-y thing"

	|personOwner morphsUnder|
	personOwner _ end1 owner owner owner.
	
	morphsUnder _ (personOwner getFamilyStick) select: [:each | ((anEvent cursorPoint) >= each bounds topLeft) & ((anEvent cursorPoint) <= each bounds bottomRight)].
	(end2 _ morphsUnder detect: [:element| element isMemberOf: StickFigure] ifNone: [nil]).
	(end1 = end2) ifTrue: [end2 _ nil].
	end2 ifNotNil:
	[
		personOwner handleConnection: end2.
		(personOwner getRelations includes: self) ifFalse: [personOwner addRelation: self.].
		end2 addRelation: self.
		theLine setVertices: {(end1 center) rounded. (end2 center) rounded}.
		theLine makeNoArrows.
		(theLine owner isNil)
		ifFalse:
		[
			theLine goBehind.
		].
		theLine	on: #mouseDown send: nil to: nil;
				on: #mouseMove send: nil to: nil;
				on: #mouseUp send: nil to: nil.
	].! !

!RelationLine methodsFor: 'rubberBandyNess' stamp: 'blg 10/28/2002 20:17'!
endMoved
"Version 1.0 Bruce Goodwin 10/28/2002"
	"when a stickfigure moves, it tells the GeneologyMap who tells me (for now. hopefully, it'll just call me directly while its moving soon.). i then move whichever end belongs to the stickfigure that moved"

	(end2 = nil) ifTrue:
	[
		line position: end1 center - ((line vertices first) - (line position)).
	]
	ifFalse:
	[
		line setVertices: {(end1 center) rounded. (end2 center) rounded}.
	].! !

!RelationLine methodsFor: 'rubberBandyNess' stamp: 'AWP 10/29/2002 21:15'!
trackDirectionArrow: anEvent with: theLine
	"anEvent hand obtainHalo: self."
	| geneologyMap morphsUnder nonHighlightMorphs |
	theLine setVertices: {(end1 center) rounded. anEvent cursorPoint}.
	geneologyMap := end1 owner owner owner.

	"Get all the non selected StickFigures and de-highlight them"
	nonHighlightMorphs := (geneologyMap getFamilyStickNotSelected).
	nonHighlightMorphs do: [:each | each deselect].

	"Get all the morphs under the mouse and make them highlighted"
	morphsUnder _ (geneologyMap getFamilyStick) select: [:each | ((anEvent cursorPoint) >= each bounds topLeft) & ((anEvent cursorPoint) <= each bounds bottomRight)].
	morphsUnder := morphsUnder select: [:each | ((each findA: RectangleMorph) isNil)].
	morphsUnder do: [:each | each select: (geneologyMap getMakingRelation)].
	

	theLine layoutChanged.! !


!RelationLine methodsFor: 'access' stamp: 'AWP 10/30/2002 23:55'!
abandon

"Version 1.0 by Adam Parker on 10/30/2002"
	"Abandons the line object so that it is no longer displayed"

line abandon.! !

!RelationLine methodsFor: 'access' stamp: 'blg 10/29/2002 22:59'!
containsAsEnd: aStickFigure
"Version 1.0 Bruce Goodwin 10/28/2002"
	"return true if aStickFigure is an end of this RelationLine"

	^(end1 = aStickFigure) or: [end2 = aStickFigure].! !

!RelationLine methodsFor: 'access' stamp: 'blg 10/29/2002 23:01'!
containsAsEnds: stick1 and: stick2
"Version 1.0 Bruce Goodwin 10/29/2002"
	"return true if this  is a RelationLine between stick1 and stick2"

	^(self containsAsEnd: stick1) and: [self containsAsEnd: stick2].! !

!RelationLine methodsFor: 'access' stamp: 'AWP 10/31/2002 11:58'!
getEndNot: aStickFigure

"Version 1.0 written by Adam Parker on 10/31/2002"
	" returns the stickFigure that is not aStickFigure in the relationship "

	(end1 = aStickFigure)
	ifTrue: [^end2]
	ifFalse: [^end1].! !

!RelationLine methodsFor: 'access' stamp: 'AWP 10/31/2002 11:33'!
getType

"Version 1.0 by Adam Parker on 10/31/2002"
	" returns this relation line's type "

^ type.! !

!RelationLine methodsFor: 'access' stamp: 'AWP 10/31/2002 00:42'!
setColor: aColor

"Version 1.0 by Adam Parker 10/30/2002"
	"Changes the color of a line"

	line borderColor: aColor.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RelationLine class
	instanceVariableNames: ''!

!RelationLine class methodsFor: 'as yet unclassified' stamp: 'AWP 10/27/2002 22:08'!
newFrom: aStickFigure
	"comment stating purpose of message"

	| relLine |
	relLine _ super new.
	relLine initializeFrom: aStickFigure to: nil.


	^relLine! !

!RelationLine class methodsFor: 'as yet unclassified' stamp: 'AWP 10/30/2002 17:41'!
newFrom: aStickFigure to: otherStickFigure
	"comment stating purpose of message"

	| relLine |
	relLine _ super new.
	relLine initializeFrom: aStickFigure to: otherStickFigure.


	^relLine! !

!RelationLine class methodsFor: 'as yet unclassified' stamp: 'AWP 10/31/2002 11:52'!
newFrom: aStickFigure to: otherStickFigure type: aTypeInt

"Versoin 1.0 written by Adam Parker on 12/31/2002"
	"Makes a complete relation and takes in the relation type"
	"1 - sibling"
	"2 - parent"
	"3 - child"
	"4 - marriage"

	| relLine |
	relLine _ super new.
	relLine setType: aTypeInt.
	relLine initializeFrom: aStickFigure to: otherStickFigure.


	^relLine! !

!RelationLine class methodsFor: 'as yet unclassified' stamp: 'AWP 10/31/2002 11:35'!
newFrom: aStickFigure type: aTypeInt

"Version 1.0 by Adam Parker written on 10/31/2002"
	"Makes a new connection line with a type association"
	"1 - sibling"
	"2 - parent"
	"3 - child"
	"4 - marriage"

	| relLine |
	relLine _ super new.
	relLine setType: aTypeInt.
	relLine initializeFrom: aStickFigure to: nil.

	^relLine! !


SketchMorph subclass: #StickFigure
	instanceVariableNames: 'location displayFor gender geneologyMap clickOffset infoMenu label currPopup selected relationLines '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 18:28'!
addAlias

"Version 1.0 Adam Parker 10/26/2002"
	"modifier adds the alias from the popup "

	displayFor addAlias: ((currPopup submorphNamed:'Alias') asText).
	
	self clearCurrPopup.
	
	! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 19:44'!
addAlias: index

"Version 1.0 Adam Parker 10/26/2002"
	"modifier adds the alias from the popup "

	displayFor addAlias: ((currPopup submorphNamed:'Alias') asText).
	self deleteAlias: index.	
	self clearCurrPopup.
	
	! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 18:42'!
addAliasPopup

"Version 1.0 Adam Parker 11/3/2002"
	"modifier to popup a window to add an alias "

	| window saveBtn cancelBtn editLabel givenText newAlias |
	
	(currPopup isNil)
	ifTrue:
	[
		window := FillInTheBlankMorph new.
		newAlias := TextMorph new.

		window position: location+(60@0).
		window height: 78.

		newAlias position: location+(105@25).
		newAlias borderWidth: 1.
		newAlias height: 30.
		newAlias width: 145.
		newAlias contents: '' wrappedTo: 145.
		newAlias backgroundColor: (Color gray: 0.8).
		newAlias name: 'Alias'.
		window addMorph: newAlias.

		saveBtn := SimpleButtonMorph newWithLabel: 'save'.
		window addMorph: saveBtn.
		saveBtn target: self.
		saveBtn actionSelector: #addAlias.
		saveBtn position: location+(112@53).
	
		cancelBtn := SimpleButtonMorph newWithLabel: 'cancel'.
		window addMorph: cancelBtn.
		cancelBtn position: location+(180@53).
		cancelBtn target: self.
		cancelBtn actionSelector: #clearCurrPopup.

		editLabel := StringMorph contents: 'Add New Alias'.
		window addMorph: editLabel.
		editLabel position: location+ (125@6).

		givenText := StringMorph contents: 'Alias:'.
		window addMorph: givenText.
		givenText position: location+ (70@27).

		self addMorph: window.
		self setCurrPopup: window.
	     window hasFocus.
	]! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 19:40'!
addAliasPopup: anAlias

"Version 1.0 Adam Parker 11/3/2002"
	"modifier to popup a window to add an alias "

	| window saveBtn cancelBtn editLabel givenText newAlias removeBtn index |
	
	(currPopup isNil)
	ifTrue:
	[
		window := FillInTheBlankMorph new.
		newAlias := TextMorph new.

		index := Array with:(displayFor getAliasIndex: anAlias).

		window position: location+(60@0).
		window height: 78.

		newAlias position: location+(105@25).
		newAlias borderWidth: 1.
		newAlias height: 30.
		newAlias width: 145.
		newAlias contents: anAlias wrappedTo: 145.
		newAlias backgroundColor: (Color gray: 0.8).
		newAlias name: 'Alias'.
		window addMorph: newAlias.

		saveBtn := SimpleButtonMorph newWithLabel: 'save'.
		window addMorph: saveBtn.
		saveBtn target: self.
		saveBtn actionSelector: #addAlias:.
		saveBtn arguments: index.
		saveBtn position: location+(92@53).
	
		cancelBtn := SimpleButtonMorph newWithLabel: 'cancel'.
		window addMorph: cancelBtn.
		cancelBtn position: location+(130@53).
		cancelBtn target: self.
		cancelBtn actionSelector: #clearCurrPopup.

		removeBtn := SimpleButtonMorph newWithLabel: 'remove'.
		window addMorph: removeBtn.
		removeBtn position: location+(180@53).
		removeBtn target: self.
		removeBtn actionSelector: #deleteAlias:.
		removeBtn arguments: index.

		editLabel := StringMorph contents: 'Add/Edit Alias'.
		window addMorph: editLabel.
		editLabel position: location+ (125@6).

		givenText := StringMorph contents: 'Alias:'.
		window addMorph: givenText.
		givenText position: location+ (70@27).

		self addMorph: window.
		self setCurrPopup: window.
	     window hasFocus.
	]! !

!StickFigure methodsFor: 'modifiers' stamp: 'blg 10/28/2002 20:32'!
addRelation: aRelationLine
	"add a RelationLine to move with this StickFigure"

	relationLines add: aRelationLine.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 20:26'!
birthDatePopup
	
	| tmpMorph |

			tmpMorph := CustomMonth newWithModel:self.
			self addMorph: tmpMorph.
			tmpMorph name: 'birthDate'.
			self setCurrPopup: tmpMorph.
			tmpMorph position: location+(60@0).
			tmpMorph hasFocus.
			((displayFor getBirthDate) isNil)
			ifTrue:[ tmpMorph chooseYear: 'Select year of BIRTH.'. ]
			ifFalse:[ tmpMorph month: (displayFor getBirthDate month).tmpMorph highlightDate: (displayFor getBirthDate).].
! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 20:11'!
birthLocation

"Version 1.0 Adam Parker 10/26/2002"
	"modifier adds the alias from the popup "

	displayFor bornLocation: ((currPopup submorphNamed:'birthLocation') asText).
	
	self clearCurrPopup.
	
	! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 20:11'!
birthLocationPopup

"Version 1.0 Adam Parker 11/3/2002"
	"modifier to popup a window to add an alias "

	| window saveBtn cancelBtn editLabel givenText newAlias |
	
	(currPopup isNil)
	ifTrue:
	[
		window := FillInTheBlankMorph new.
		newAlias := TextMorph new.

		window position: location+(60@0).
		window height: 78.

		newAlias position: location+(125@25).
		newAlias borderWidth: 1.
		newAlias height: 30.
		newAlias width: 125.
		newAlias contents: '' wrappedTo: 125.
		newAlias backgroundColor: (Color gray: 0.8).
		newAlias name: 'birthLocation'.
		window addMorph: newAlias.

		saveBtn := SimpleButtonMorph newWithLabel: 'save'.
		window addMorph: saveBtn.
		saveBtn target: self.
		saveBtn actionSelector: #birthLocation.
		saveBtn position: location+(112@53).
	
		cancelBtn := SimpleButtonMorph newWithLabel: 'cancel'.
		window addMorph: cancelBtn.
		cancelBtn position: location+(180@53).
		cancelBtn target: self.
		cancelBtn actionSelector: #clearCurrPopup.

		editLabel := StringMorph contents: 'Set Birth Location'.
		window addMorph: editLabel.
		editLabel position: location+ (115@6).

		givenText := StringMorph contents: 'Location:'.
		window addMorph: givenText.
		givenText position: location+ (70@27).

		self addMorph: window.
		self setCurrPopup: window.
	     window hasFocus.
	]! !

!StickFigure methodsFor: 'modifiers' stamp: 'fd 10/28/2002 17:55'!
clearCurrPopup

	(currPopup isNil)
        ifFalse: [currPopup abandon. currPopup := nil.].
	currPopup := nil.
! !

!StickFigure methodsFor: 'modifiers' stamp: 'fd 10/25/2002 15:48'!
clearMenu
	
	infoMenu := nil.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 20:27'!
deathDatePopup
	
	| tmpMorph |

			tmpMorph := CustomMonth newWithModel:self.
			self addMorph: tmpMorph.
			tmpMorph name: 'deathDate'.
			self setCurrPopup: tmpMorph.
			tmpMorph position: location+(60@0).
			tmpMorph hasFocus.
			((displayFor getDeathDate) isNil)
			ifTrue:[ tmpMorph chooseYear: 'Select year of DEATH.'. ]
			ifFalse:[ tmpMorph month: (displayFor getDeathDate month).tmpMorph highlightDate: (displayFor getDeathDate).].
! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/31/2002 10:48'!
delete

"Version 1.2 by Adam Parker on 10/30/2002"
	"handles the deletion of a stick figure"

	(geneologyMap isNil)
	ifFalse:
	[
		(geneologyMap getFamilyStick) remove: self.

	" Delete all references to this person from all other people 'out of site is out of mind(literally)'"
		(geneologyMap getFamily) do: [:each | each deleteAllAffiliationsOf: displayFor].

	"Delete all lines from the display"
		((geneologyMap getRelations) select: [:each | each containsAsEnd: self]) do: [:each | each abandon.].

	"Delete all relations from the relations collection"
		geneologyMap setRelations: ((geneologyMap getRelations) reject: [:each | each containsAsEnd: self.]).

		
	].
	super delete.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 19:44'!
deleteAlias: index

"Version 1.0 Adam Parker 10/26/2002"
	"removes a person's alias "

	displayFor deleteAlias: index.	
	self clearCurrPopup.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 19:42'!
deleteAlias: index close: doClose

"Version 1.0 Adam Parker 10/26/2002"
	"removes a person's alias "

	displayFor deleteAlias: index.	

	(doClose = 1)
	ifTrue: 
	[
		self clearCurrPopup.
	]	! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 18:36'!
deleteAliasAndClose

"Version 1.0 Adam Parker 10/26/2002"
	"removes a person's alias "

	displayFor deleteAlias: ((currPopup submorphNamed:'Alias') asText).

	self clearCurrPopup.
	
	! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/4/2002 21:29'!
deleteLineWith: aStickFigure

"Version 1.0 by Adam Parker on 11/3/2002"
	"delete the relation lines between one person and another"

	"Delete all lines from the display"
		((geneologyMap getRelations) select: [:each | each containsAsEnds: self and: aStickFigure]) do: [:each | each abandon.].

	"Delete all relations from the relations collection"
		geneologyMap setRelations: ((geneologyMap getRelations) reject: [:each | each containsAsEnds: self and: aStickFigure.]).

"************************************ FOR SELF *********************************"

	"Delete all lines from the display"
		(relationLines select: [:each | each containsAsEnds: self and: aStickFigure]) do: [:each | each abandon.].
	"Delete all relations from the relations collection OF SELF"
		relationLines := relationLines reject: [:each | each containsAsEnds: self and: aStickFigure.].

		
! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/4/2002 11:54'!
drawMenu

"Version 1.0 Adam Parker 10/20/2002"
	"called when a yellow click is made"

	| menu submenu remainingList tmpCollection tmpRemainCollection |

	(infoMenu isNil)
	ifFalse:
	[ infoMenu abandon. infoMenu := nil.].

		menu := Info new.
		menu defaultTarget: self.

		menu title: displayFor getName.

		submenu := Info new.
		submenu defaultTarget: self.
		submenu add: 'male' target: self selector: #editGender: argument: 'male'.
		submenu add: 'female' target: self selector: #editGender: argument: 'female'.
		menu add: 'Gender: ',((displayFor getGender | displayFor getGender isNil) ifTrue: ['Male  '] ifFalse: ['Female  ']) subMenu: submenu.
		
	
		menu addLine.


		submenu := MenuMorph new.
		submenu defaultTarget: self.
		submenu add: 'change' target: self selector: #makeConnection: argument: 2.

		menu add: 'Father: ',((displayFor getFather isNil) ifTrue:['-'] ifFalse:[ (displayFor getFather) getName]) subMenu: submenu.	

		menu add: 'Mother: ',((displayFor getMother isNil) ifTrue:['-'] ifFalse:[ (displayFor getMother) getName]) subMenu: submenu.



		menu addLine.


		menu add: 'Born:' action: nil.
		menu add: ' ',((displayFor getBirthDate isNil) ifTrue: ['-'] ifFalse:[(displayFor getBirthDate) printString]) action: #birthDatePopup.
		menu add: ' ',((displayFor getBirthLocation isNil) ifTrue: ['-'] ifFalse: [displayFor getBirthLocation]) action: #birthLocationPopup.
		menu addLine.


		menu add: 'Died:' action: #deathDatePopup.
		menu add: ' ',((displayFor getDeathDate isNil) ifTrue: ['-'] ifFalse:[(displayFor getDeathDate) printString]) action: #deathDatePopup.
		menu addLine.



		"Make a submenu from the ordered collection of siblings"
			submenu := Info new.
			tmpCollection := displayFor getSiblings.
			tmpCollection do: [:each | submenu add: (each getName) action: nil.].
				remainingList := Info new.
				tmpRemainCollection := ((((geneologyMap getFamily) reject: [:each | tmpCollection includes: each]) reject: [:each | (displayFor = each) | (displayFor getMother = each) | (displayFor getFather = each)]) reject: [:each | (displayFor getChildren) includes: each]) reject: [:each | ((displayFor getMarriages) select: [:amarriage| (amarriage getSpouse) = each]) includes: each].
	
				submenu add: '<ADD>' target:self selector:#makeConnection: argument: 1.

				tmpRemainCollection do: [:each | remainingList add: (each getName) target:displayFor selector: #hasSibling: argument:each.].
		((remainingList items size) > 0)
			ifTrue: [submenu add: 'add...' subMenu: remainingList.]
			ifFalse: [remainingList add: '-none-' action:nil.submenu add: 'add..' subMenu: remainingList.].


		menu add: 'Siblings' subMenu: submenu.
		menu addLine.
	


		"Make a submenu from the ordered collection of mariages"
			submenu := Info new.
			tmpCollection := displayFor getMarriages.
			tmpCollection do: [:each | submenu add: (each getSpouse getName) action: nil.].
			submenu add: '<ADD>' target:self selector:#makeConnection: argument: 4.

		menu add: 'Mariages' subMenu: submenu.
		menu addLine.



		"Make a submenu from the ordered collection of children"
			submenu := MenuMorph new.
			tmpCollection := displayFor getChildren.
			tmpCollection do: [:each | submenu add: (each getName) action: nil].
"remainingList := MenuMorph new.
remainingList defaultTarget: self.
tmpRemainCollection := ((((geneologyMap getFamily) reject: [:each | tmpCollection includes: each]) reject: [:each | (displayFor = each) | (displayFor getMother = each) | (displayFor getFather = each)]) reject: [:each | (displayFor getChildren) includes: each]) reject: [:each | ((displayFor getMarriages) select: [:amarriage| (amarriage getSpouse) = each]) includes: each].
tmpRemainCollection do: [:each | remainingList add: (each getName) selector: #givenName argument: 'eeee'].
submenu add: 'add...' subMenu: remainingList."

			submenu add: '<ADD>' target:self selector:#makeConnection: argument: 3.

		menu add: 'Children' subMenu: submenu.
		menu addLine.



		"Make a submenu from the ordered collection of aliases a person uses"
			submenu := MenuMorph new.
			submenu defaultTarget: self.
			tmpCollection := displayFor getAliases.
			tmpCollection do: [:each | submenu add: (each) target: self selector: #addAliasPopup: argument: each.].
			submenu add: 'add...' action: #addAliasPopup.

		menu add: 'Aliases'  subMenu: submenu.

		menu addLine.
		submenu := MenuMorph new.
		submenu defaultTarget: self.
		(displayFor getName = '-') 
			ifTrue: [submenu add: 'set name' action: #setNamePopup]
			ifFalse: [submenu add: 'edit Name' action: #setNamePopup].
		submenu add: 'delete' action: #deleteMe.
		menu add: 'options...' subMenu: submenu.

		menu addStayUpIcons.
		menu position: location+(40@0).
		menu addParent: self.
		self addMorph: menu.
		menu hasFocus.

		infoMenu := menu.


! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/22/2002 04:17'!
edit

"Version 1.0 Adam Parker 10/21/2002"
	"modifier to popup a window to edit the gender"

	| window textarea |

	window := FillInTheBlankMorph new.
	textarea := PluggableTextMorphWithModel new.
	window position: location+(60@0).
	textarea position: location+(66@5).
	textarea height: 30.
	textarea width: 185.
	window openInWorld.
"	window title: 'Edit Name'."
	window addMorph: textarea.
! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/4/2002 23:38'!
editGender: input

"Version 1.0 Adam Parker 10/21/2002"
	"modifier function to change the gender and refresh the menu "
	

		"Set the person's gender"
		(input = 'male') 
		ifTrue: [displayFor isMale]
		ifFalse: [(input = 'female') ifTrue: [displayFor isFemale]].

		"Delete the current gender"
		"Load in the image of the Gender"
		(displayFor getGender)
		ifTrue:
		[
			(gender isNil)
			ifFalse:[	gender abandon.].
			gender := SketchMorph fromFile: 'Male.gif'.
		]
		ifFalse:
		[
			(gender isNil)
			ifFalse:[	gender abandon.].
			gender := SketchMorph fromFile: 'Female.gif'.
		].
			self addMorph: gender.
			gender position: (self center - (4@9)).

		"Refresh the menu to show changes."
		self refreshMenu.
	! !

!StickFigure methodsFor: 'modifiers' stamp: 'blg 10/28/2002 20:31'!
initRelations
	"initialize the relations collection"

	relationLines _ OrderedCollection new.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 15:33'!
makeConnection: type

	"1 - sibling"
	"2 - parent"
	"3 - child"
	"4 - marriage"

	geneologyMap select: self.
	RelationLine newFrom: self type: type.
	self select: 'r'.
	(type = 1)	ifTrue: [geneologyMap connectSibling.^true.].
	(type = 2)	ifTrue: [geneologyMap connectParent.^true.].
	(type = 3)	ifTrue: [geneologyMap connectChild.^true.].
	(type = 4)	ifTrue: [geneologyMap connectMarriage.^true.].! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/22/2002 05:49'!
makeFemale

"Version 1.0 Adam Parker 10/22/2002"
	"Set the user to female"

	displayFor isFemale.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/22/2002 05:49'!
makeMale

"Version 1.0 Adam Parker 10/22/2002"
	"Set the user to male"

	displayFor isMale.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 15:44'!
marriageDatePopup: aPerson
	
	| tmpMorph |

			tmpMorph := CustomMonth newWithModel:self.
			self addMorph: tmpMorph.
			tmpMorph name: 'marriageDate'.
			self setCurrPopup: tmpMorph.
			tmpMorph position: location+(60@0).
			tmpMorph hasFocus.
			tmpMorph highlightDate: (displayFor getDeathDate).
			tmpMorph setHolder: aPerson.
			((displayFor getDeathDate) isNil)
			ifTrue:[ tmpMorph chooseYear: 'Choose Marriage Year.'. ].
! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/27/2002 21:24'!
refreshLabel

	label contents: (displayFor getName).

	(displayFor getName size <= 5)
		ifTrue: [label position: location+((displayFor getName size * 0.5)@70).]
		ifFalse: [label position: location+((displayFor getName size * -2)@70).].! !

!StickFigure methodsFor: 'modifiers' stamp: 'fd 10/28/2002 17:43'!
setBirthDatePopup

	! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/2/2002 16:21'!
setCurrPopup: aPopup

	(currPopup isNil)
	ifTrue: [currPopup := aPopup.]
	ifFalse: [ currPopup abandon. currPopup := aPopup.].! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/3/2002 22:49'!
setDate: aDate fromButton: aButton down:sure

"Version 1.1 by Adam Parker on 11/3/2002"
	"Handles the date click of the calendar popup"

	(aDate isNil)
	ifFalse: 
	[
		(currPopup externalName = 'deathDate')
		ifTrue: [displayFor died: aDate. currPopup abandon. currPopup := nil. ]
		ifFalse: 
		[ 
			(currPopup externalName = 'birthDate')
			ifTrue: [displayFor born: aDate location: (displayFor getBirthLocation). currPopup abandon. currPopup := nil.]
			ifFalse: 
			[
				(currPopup externalName = 'marriageDate')
				ifTrue: 
				[

					geneologyMap displayActionAlert: (displayFor getName),' was married to ',(currPopup getHolder getName),' on ',(aDate printString).
					((displayFor getMarriages) last) setDate: aDate.
					currPopup abandon.

				]
			]
		]
	]! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/21/2002 22:18'!
setDisplayFor: person


	displayFor := person.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 11/4/2002 23:51'!
setGenderMorph: aMorph

"Version 1.0 by Adam Parker on 11/4/2002"
	"Sets a gender morph"

gender := aMorph.
self addMorph: gender.
gender position: (self center-(4@9)).! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/22/2002 05:18'!
setGeneologyMap: map

	geneologyMap := map.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/27/2002 21:15'!
setLabel: aLabel

	label:= aLabel.! !

!StickFigure methodsFor: 'modifiers' stamp: 'fd 10/23/2002 23:16'!
setLocation: newLocation

"Version 1.0 Adam Parker 10/21/2002"
	"modifier to set the location variable of the visualiztion"

	location := newLocation.! !

!StickFigure methodsFor: 'modifiers' stamp: 'AWP 10/27/2002 21:07'!
setName

"Version 1.0 Adam Parker 10/26/2002"
	"modifier to popup a window to edit the user's name "

	displayFor givenName: ((currPopup allMorphs at: 9) asText).
	displayFor surName: ((currPopup allMorphs at: 8) asText).
	
	self refreshLabel.

	self clearCurrPopup.
	
	! !

!StickFigure methodsFor: 'modifiers' stamp: 'fd 10/28/2002 18:07'!
setNamePopup

"Version 1.0 Adam Parker 10/26/2002"
	"modifier to popup a window to edit the user's name "

	| window givenName saveBtn cancelBtn editLabel surName givenText surText |
	
	(currPopup isNil)
	ifTrue:
	[
		window := FillInTheBlankMorph new.
		givenName := TextMorph new.
		surName := TextMorph new.

		window position: location+(60@0).
		window height: 100.

		givenName position: location+(106@18).
		givenName borderWidth: 1.
		givenName height: 30.
		givenName width: 145.
		givenName contents: displayFor getGivenName wrappedTo: 145.
		givenName backgroundColor: (Color gray: 0.8).
		window addMorph: givenName.


		surName position: location+(106@43).
		surName borderWidth: 1.
		surName height: 30.
		surName width: 145.
		surName contents: displayFor getSurName wrappedTo: 145.
		surName backgroundColor: (Color gray: 0.8).
		window addMorph: surName.

		saveBtn := SimpleButtonMorph newWithLabel: 'save'.
		window addMorph: saveBtn.
		saveBtn target: self.
		saveBtn actionSelector: #setName.
		saveBtn position: location+(112@73).
	
		cancelBtn := SimpleButtonMorph newWithLabel: 'cancel'.
		window addMorph: cancelBtn.
		cancelBtn position: location+(180@73).
		cancelBtn target: self.
		cancelBtn actionSelector: #clearCurrPopup.

		editLabel := StringMorph contents: 'Edit Name'.
		window addMorph: editLabel.
		editLabel position: location+ (135@6).

		givenText := StringMorph contents: 'First:'.
		window addMorph: givenText.
		givenText position: location+ (70@20).

		surText := StringMorph contents: 'Last:'.
		window addMorph: surText.
		surText position: location+ (70@45).
		
		self addMorph: window.
		self setCurrPopup: window.
	     window hasFocus.
	]! !


!StickFigure methodsFor: 'accessors' stamp: 'AWP 10/22/2002 03:13'!
getDisplayFor

"Version 1.0 Adam Parker 10/21/2002"
	"Accessor that returns the person this StickFigure is displayed for"

	^displayFor.! !

!StickFigure methodsFor: 'accessors' stamp: 'AWP 10/21/2002 22:37'!
getLocation

"Version 1.0 Adam Parker 10/21/2002"
	"accessor to get the location variable of the visualiztion"

	^location.! !


!StickFigure methodsFor: 'support' stamp: 'fd 10/25/2002 16:06'!
connectorLine

	| x |
	x := LineMorph new.
	x openInWorld.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/28/2002 23:59'!
deleteMe

	self abandon.! !

!StickFigure methodsFor: 'support' stamp: 'fd 10/28/2002 20:37'!
deselect

	| tmpMorph |
	selected := false.
	tmpMorph := self findA: RectangleMorph.
	(tmpMorph isNil)
	ifFalse:
	[
		tmpMorph delete.
	].! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/22/2002 07:19'!
givenName: test
	Transcript show: test.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/28/2002 23:30'!
handleMouseUp: anEvent

	(anEvent position <= self bounds bottomRight)
	ifTrue:
	[
		anEvent wasHandled ifTrue:[^self]. "not interested"
		anEvent hand releaseMouseFocus: self.
		anEvent wasHandled: true.
		anEvent blueButtonChanged
			ifTrue:[self blueButtonUp: anEvent]
			ifFalse:[self mouseUp: anEvent].
		(anEvent redButtonChanged)
			ifTrue:
			[
				(clickOffset = (-1@-1))
				ifFalse:
				[
					self position: (anEvent position)-clickOffset.
					self setLocation: (anEvent position)-clickOffset.
					geneologyMap handleMove: self.
					clickOffset := (-1@-1).

				]
			]
	].	


! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 10:14'!
handlesMouseDown: event

	(event position <= self bounds bottomRight)
	ifTrue:
	[
		(event yellowButtonChanged)
			ifTrue: [self drawMenu.	clickOffset := (-1@-1).]
			ifFalse: [geneologyMap select: self.self select:'r'. event redButtonChanged 			ifTrue:[clickOffset := (event position) - location.]].
	].
	^true.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 10:32'!
handlesMouseOver: event.

	^true.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/30/2002 23:49'!
handlesMouseOverDragging: event.

	^true.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 14:01'!
handlesMouseStillDown: anEvent

(clickOffset = (-1@-1))
 ifFalse:
 [
   self position: (anEvent position)-clickOffset. 
   self setLocation: (anEvent position)-clickOffset.
 
 "this line added by me to make the relationlines follow this stickfigure"
   relationLines do: [:thisLine| thisLine endMoved].
 ].

	^true.


! !

!StickFigure methodsFor: 'support' stamp: 'fd 10/23/2002 16:52'!
killMenu

	! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 10:32'!
mouseEnter: event

	(event position <= self bounds bottomRight)
	ifTrue:
	[
		(geneologyMap isMakingRelation isNil)
		ifFalse:
		[
			(selected = false)
			ifTrue: [self select:(geneologyMap isMakingRelation).].
		].
	].
		
	^true.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 20:50'!
mouseEnterDragging: event

	(event position <= self bounds bottomRight)
	ifTrue:
	[
		(geneologyMap isMakingRelation isNil)
		ifFalse:
		[
			(selected = false)
			ifTrue: [self select:(geneologyMap isMakingRelation).].
		].
	].
		
	^true.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 10:32'!
mouseLeave: evt

		(geneologyMap isMakingRelation isNil)
		ifFalse:
		[
			(selected = false)
			ifTrue: [self deselect.].
		].
		
	^true.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/29/2002 20:50'!
mouseLeaveDragging: event

	(event position <= self bounds bottomRight)
	ifTrue:
	[
		(geneologyMap isMakingRelation isNil)
		ifFalse:
		[
			(selected = false)
			ifTrue: [self select:(geneologyMap isMakingRelation).].
		].
	].
		
	^true.! !

!StickFigure methodsFor: 'support' stamp: 'fd 10/25/2002 16:01'!
refreshMenu

		self drawMenu.! !

!StickFigure methodsFor: 'support' stamp: 'AWP 10/30/2002 17:33'!
select: aColorType

"expects 'r' 'g' or 'b' as the imput"



	| rect |

	(selected = false)

	ifTrue:

	[
		selected := true.
		(aColorType = 'r')
		ifTrue:
		[
			(geneologyMap getFamilyStick) do: [:each | each deselect ].
		].


		rect := RectangleMorph new.

		rect position: location-(8@3).
		(aColorType = 'r')
		ifTrue:[	rect color: (TranslucentColor r: 1.0 g: 0.452 b: 0.645 alpha: 0.447).]
		ifFalse:
		[
			(aColorType = 'g')
			ifTrue: [rect color: (TranslucentColor r: 0.226 g: 1.0 b: 0.29 alpha: 0.447).]
			ifFalse: 
			[
				(aColorType = 'b')
				ifTrue: [rect color: (TranslucentColor r: 0.484 g: 0484 b: 1.0 alpha: 0.447).]
				ifFalse: [rect color: (TranslucentColor r: 1.0 g: 0.452 b: 0.645 alpha: 0.447).]
			].
		].

		rect useRoundedCorners.

		rect width: (self width + 16).

		rect height: (self height + 6).

		rect borderWidth: 1.

		self addMorph: rect.
		(aColorType = 'r')
		ifTrue: 
		[
			selected := true.
		].

	].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StickFigure class
	instanceVariableNames: ''!

!StickFigure class methodsFor: 'as yet unclassified' stamp: 'fd 10/20/2002 09:19'!
create

	^StickFigure fromFile: 'Stick.gif'.! !

!StickFigure class methodsFor: 'as yet unclassified' stamp: 'AWP 11/4/2002 23:51'!
createFor: person at: aLocation
	
	| tmpStickFigure label |

	tmpStickFigure := StickFigure fromFile: 'Stick.gif'.

	tmpStickFigure setDisplayFor: person.
	tmpStickFigure setLocation: aLocation.

	label := StringMorph contents: person getName.

	(person getName size <= 5)
		ifTrue: [label position: (person getName size * 0.5)@70.]
		ifFalse: [label position: (person getName size * -2)@70.].

	tmpStickFigure addMorph: label.
	tmpStickFigure setLabel: label.

	tmpStickFigure position: aLocation.
	tmpStickFigure openInWorld.
	
	tmpStickFigure deselect.

	tmpStickFigure initRelations.

	(person getGender)
	ifTrue:[	tmpStickFigure setGenderMorph: (SketchMorph fromFile: 'Male.gif').]
	ifFalse:[tmpStickFigure setGenderMorph: (SketchMorph fromFile: 'Female.gif').].

	^tmpStickFigure.! !


Object subclass: #Testing
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Testing class
	instanceVariableNames: ''!

!Testing class methodsFor: 'Query' stamp: 'fd 9/19/2002 14:54'!
testQuery


| adam kathy william jerry dorothy jessie bill karla kim kristi francine queryResult|
Transcript clear.
adam := Person new.adam givenName: 'Adam'. adam addAlias: 'aparker' ;addAlias: 'taz'; isMale.
kathy := Person new.kathy givenName: 'Kathy'. kathy born:(Date newDay: 3 month: 4 year: 66) location: 'cairo'. kathy addAlias: 'walkslikeanegyptian'; isFemale; died:(Date newDay: 23 month: 8 year: 99).
william := Person new.william givenName: 'William'. william died:(Date newDay: 14 month: 8 year: 55); isMale.
jerry := Person new.jerry givenName: 'Jerry'; isMale.
dorothy := Person new.dorothy givenName: 'Dorothy'. dorothy born:(Date newDay: 3 month: 4 year: 66) location:'phoenix'; isFemale;  died:(Date newDay: 22 month: 7 year: 99).
jessie := Person new.jessie givenName: 'Jessie'. jessie born:(Date newDay: 14 month: 4 year: 55) location: 'the mall';  died:(Date newDay: 14 month: 8 year: 55).
jessie record: 'buttmunch' as: 'wtf'; isMale.
bill := Person new.bill givenName: 'Bill'. bill born:(Date newDay: 3 month: 4 year: 69) location:'cairo'; isMale;died:(Date newDay: 14 month: 8 year: 55).
francine _ Person new. francine givenName: 'francine'; record: 'blubber' as: 'lean'; isFemale; died:(Date newDay: 14 month: 8 year: 55).
karla := Person new. karla givenName: 'Karla'. karla  died:(Date newDay: 14 month: 3 year: 55); isFemale.
kim := Person new. kim givenName: 'Kim'.kim died:(Date newDay: 14 month: 8 year: 55); isFemale; record: 'lived at' as: 'the mall'; record: 'cairo' as: 'cairo'.
kristi := Person new. kristi givenName: 'Kristi'; record: 'blubber' as: 'fat'; isFemale.


"CODE FOR ADDING kim, karla, and kristi as siblings *doesn't work*"
dorothy hasSibling: kim.
dorothy hasSibling: kristi.
dorothy hasSibling: karla.

"CODE FOR ADDING kim, karla, and kristi as children *works*"
dorothy hasChild: kim with: jerry.
dorothy hasChild: kristi with: jerry.
dorothy hasChild: karla with: jerry.
dorothy hasChild: kathy with: jerry.

"testing traverse of JUSt a spouse no children to otherwise get to the spouse"
william married: francine on: (Date newDay: 3 month: 3 year: 1999).

kathy hasChild: adam with: william.
adam hasMother: kathy.
adam hasFather: william.
kathy hasMother: dorothy.
kathy hasFather: jerry.
william hasFather: bill; addAlias: 'taz'; addAlias: 'bubbagump'; addAlias: 'reginald'.
william hasMother: jessie.

Traversal traverseFrom: adam do: 
[:thisPerson|
	thisPerson surName: 'Parker'.
].

Transcript show:'born:';cr.
queryResult _ adam searchFor: (Query born:(Date newDay: 3 month: 4 year: 66)).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname, ' - ', (thisPerson getBirthDate) printString ;cr.
].

Transcript show:'bornIn:';cr.
queryResult _ adam searchFor: (Query bornIn:'cairo').
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname, ' - ', thisPerson getBirthLocation;cr.
].

 
Transcript show:'died:';cr.
queryResult _ adam searchFor: (Query died:(Date newDay: 14 month: 08 year: 55)).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname, ' - ', thisPerson getDeathDate printString;cr.
].

Transcript show:'anyAlias:';cr.
queryResult _ adam searchFor: (Query hasAlias).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname, ' - '.
	thisPerson getAliases do:[:thisAlias| Transcript show: thisAlias,' '.].
	Transcript cr.
].

Transcript show:'hasAlias:';cr.
queryResult _ adam searchFor: (Query hasAlias: 'taz').
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname, ' - '.
	thisPerson getAliases do:[:thisAlias| Transcript show: thisAlias,' '.].
	Transcript cr.
].

Transcript show:'givenName:';cr.
queryResult _ adam searchFor: (Query givenName:'Dorothy').
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'hasChild:';cr.
queryResult _ adam searchFor: (Query hasChild: adam).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'hasInfo:';cr.
queryResult _ adam searchFor: (Query hasInfo: 'blubber' as: 'fat').
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'hasParent:';cr.
queryResult _ adam searchFor: (Query hasParent: dorothy).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'hasSibling:';cr.
queryResult _ adam searchFor: (Query hasSibling: dorothy).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].


Transcript show:'isMale:';cr.
queryResult _ adam searchFor: (Query isMale).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'isFemale:';cr.
queryResult _ adam searchFor: (Query isFemale).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'livedOn:';cr.
queryResult _ adam searchFor: (Query livedOn:( Date newDay: 13 month: 8 year: 55) ).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'livedIn:';cr.
queryResult _ adam searchFor: (Query livedIn: 'the mall' ).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'married:';cr.
queryResult _ adam searchFor: (Query married: william ).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

Transcript show:'surname:';cr.
queryResult _ adam searchFor: (Query surName: 'Parker' ).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].


Transcript show:'generalSearch:';cr.
queryResult _ adam searchFor: (Query generalSearch: 'the mall' ).
queryResult do: [:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].


adam visualize.! !


!Testing class methodsFor: 'Visualization' stamp: 'AWP 11/1/2002 18:20'!
testVisualization


| adam kathy william jerry dorothy jessie bill karla kim kristi francine queryResult|
Transcript clear.
adam := Person new.adam givenName: 'Adam'. adam addAlias: 'aparker' ;addAlias: 'taz'; isMale.
kathy := Person new.kathy givenName: 'Kathy'. kathy born:(Date newDay: 3 month: 4 year: 66) location: 'cairo'. kathy addAlias: 'walkslikeanegyptian'; isFemale; died:(Date newDay: 23 month: 8 year: 99).
william := Person new.william givenName: 'William'. william died:(Date newDay: 14 month: 8 year: 55); isMale.
jerry := Person new.jerry givenName: 'Jerry'; isMale.
dorothy := Person new.dorothy givenName: 'Dorothy'. dorothy born:(Date newDay: 3 month: 4 year: 66) location:'phoenix'; isFemale;  died:(Date newDay: 22 month: 7 year: 99).
jessie := Person new.jessie givenName: 'Jessie'. jessie born:(Date newDay: 14 month: 4 year: 55) location: 'the mall';  died:(Date newDay: 14 month: 8 year: 55).
jessie record: 'buttmunch' as: 'wtf'; isMale.
bill := Person new.bill givenName: 'Bill'. bill born:(Date newDay: 3 month: 4 year: 69) location:'cairo'; isMale;died:(Date newDay: 14 month: 8 year: 55).
francine _ Person new. francine givenName: 'francine'; record: 'blubber' as: 'lean'; isFemale; died:(Date newDay: 14 month: 8 year: 55).
karla := Person new. karla givenName: 'Karla'. karla  died:(Date newDay: 14 month: 3 year: 55); isFemale.
kim := Person new. kim givenName: 'Kim'.kim died:(Date newDay: 14 month: 8 year: 55); isFemale; record: 'lived at' as: 'the mall'; record: 'cairo' as: 'cairo'.
kristi := Person new. kristi givenName: 'Kristi'; record: 'blubber' as: 'fat'; isFemale.


"CODE FOR ADDING kim, karla, and kristi as siblings *doesn't work*"
dorothy hasSibling: kim.
dorothy hasSibling: kristi.
dorothy hasSibling: karla.

"CODE FOR ADDING kim, karla, and kristi as children *works*"
dorothy hasChild: kim with: jerry.
dorothy hasChild: kristi with: jerry.
dorothy hasChild: karla with: jerry.
dorothy hasChild: kathy with: jerry.

"testing traverse of JUSt a spouse no children to otherwise get to the spouse"
william married: francine on: (Date newDay: 3 month: 3 year: 1999).

kathy hasChild: adam with: william.
adam hasMother: kathy.
adam hasFather: william.
kathy hasMother: dorothy.
kathy hasFather: jerry.
william hasFather: bill; addAlias: 'taz'; addAlias: 'bubbagump'; addAlias: 'reginald'.
william hasMother: jessie.


adam visualize.! !


!Testing class methodsFor: 'Traversal' stamp: 'fd 10/2/2002 23:31'!
testTraversal

| adam kathy william jerry dorothy jessie bill karla kim kristi francine |
Transcript clear.
adam := Person new.adam givenName: 'Adam'.
kathy := Person new.kathy givenName: 'Kathy'.
william := Person new.william givenName: 'William'.
jerry := Person new.jerry givenName: 'Jerry'.
dorothy := Person new.dorothy givenName: 'Dorothy'.
jessie := Person new.jessie givenName: 'Jessie'.
bill := Person new.bill givenName: 'Bill'.
francine _ Person new. francine givenName: 'francine'.

karla := Person new. karla givenName: 'Karla'.
kim := Person new. kim givenName: 'Kim'.
kristi := Person new. kristi givenName: 'Kristi'.


"CODE FOR ADDING kim, karla, and kristi as siblings *doesn't work*"
dorothy hasSibling: kim.
dorothy hasSibling: kristi.
dorothy hasSibling: karla.

"CODE FOR ADDING kim, karla, and kristi as children *works*"
"dorothy hasChild: kim with: jerry.
dorothy hasChild: kristi with: jerry.
dorothy hasChild: karla with: jerry.
dorothy hasChild: kathy with: jerry."

"testing traverse of JUSt a spouse no children to otherwise get to the spouse"
william married: francine on: (Date newDay: 3 month: 3 year: 1999).

kathy hasChild: adam with: william.
adam hasMother: kathy.
adam hasFather: william.
kathy hasMother: dorothy.
kathy hasFather: jerry.
william hasFather: bill.
william hasMother: jessie.

Traversal traverseFrom: adam do: 
[:thisPerson|
	thisPerson surName: 'Parker'.
].

Traversal traverseFrom: adam do:
[:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

! !


!Testing class methodsFor: 'Geneology' stamp: 'AWP 11/1/2002 18:27'!
testGeneologyMap


| adam kathy william jerry dorothy jessie bill karla kim kristi francine tmpCollection |
Transcript clear.
adam := Person new.adam givenName: 'Adam'. adam addAlias: 'aparker' ;addAlias: 'taz'; isMale.
kathy := Person new.kathy givenName: 'Kathy'. kathy born:(Date newDay: 3 month: 4 year: 66) location: 'cairo'. kathy addAlias: 'walkslikeanegyptian'; isFemale; died:(Date newDay: 23 month: 8 year: 99).
william := Person new.william givenName: 'William'. william died:(Date newDay: 14 month: 8 year: 55); isMale.
jerry := Person new.jerry givenName: 'Jerry'; isMale.
dorothy := Person new.dorothy givenName: 'Dorothy'. dorothy born:(Date newDay: 3 month: 4 year: 66) location:'phoenix'; isFemale;  died:(Date newDay: 22 month: 7 year: 99).
jessie := Person new.jessie givenName: 'Jessie'. jessie born:(Date newDay: 14 month: 4 year: 55) location: 'the mall';  died:(Date newDay: 14 month: 8 year: 55).
jessie record: 'buttmunch' as: 'wtf'; isMale.
bill := Person new.bill givenName: 'Bill'. bill born:(Date newDay: 3 month: 4 year: 69) location:'cairo'; isMale;died:(Date newDay: 14 month: 8 year: 55).
francine _ Person new. francine givenName: 'francine'; record: 'blubber' as: 'lean'; isFemale; died:(Date newDay: 14 month: 8 year: 55).
karla := Person new. karla givenName: 'Karla'. karla  died:(Date newDay: 14 month: 3 year: 55); isFemale.
kim := Person new. kim givenName: 'Kim'.kim died:(Date newDay: 14 month: 8 year: 55); isFemale; record: 'lived at' as: 'the mall'; record: 'cairo' as: 'cairo'.
kristi := Person new. kristi givenName: 'Kristi'; record: 'blubber' as: 'fat'; isFemale.


"CODE FOR ADDING kim, karla, and kristi as siblings *doesn't work*"
dorothy hasSibling: kim.
dorothy hasSibling: kristi.
dorothy hasSibling: karla.

"CODE FOR ADDING kim, karla, and kristi as children *works*"
dorothy hasChild: kim with: jerry.
dorothy hasChild: kristi with: jerry.
dorothy hasChild: karla with: jerry.
dorothy hasChild: kathy with: jerry.

"testing traverse of JUSt a spouse no children to otherwise get to the spouse"
william married: francine on: (Date newDay: 3 month: 3 year: 1999).

kathy hasChild: adam with: william.
adam hasMother: kathy.
adam hasFather: william.
kathy hasMother: dorothy.
kathy hasFather: jerry.
william hasFather: bill; addAlias: 'taz'; addAlias: 'bubbagump'; addAlias: 'reginald'.
william hasMother: jessie.


tmpCollection := SortedCollection new.
tmpCollection addAll: #(adam kathy william jerry dorothy bill karla kim kristi francine).


(GeneologyMap with: (tmpCollection asArray)) open.! !


Object subclass: #Traversal
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Geneology'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Traversal class
	instanceVariableNames: ''!

!Traversal class methodsFor: 'traversals' stamp: 'blg 9/14/2002 23:58'!
traverseFrom: aPerson do: aBlock


	"here is how i work. i put all the family members in an IdentitySet and then run do: on the set with the block thats passed to me. NOTE: the block will not be run on the people in any particular order!!!!!!"





	| familySet |


	familySet _ IdentitySet new.


	


	self putFamilyOf: aPerson inSet: familySet.


	familySet do: aBlock.! !


!Traversal class methodsFor: 'private' stamp: 'blg 9/16/2002 16:47'!
putFamilyOf: aPerson inSet: aSet

	" I check all the immediate relations of this person to see if they have been added to the set yet. if so i ignore them, if not, i add them and recurse, starting from them."



(aSet includes: aPerson) ifFalse:

[

	aSet add: aPerson.

].



(aPerson getFather isNil) ifFalse:

[

	(aSet includes: (aPerson getFather)) ifFalse:

	[

		aSet add: (aPerson getFather).

		self putFamilyOf: (aPerson getFather) inSet: aSet.

	].

].



(aPerson getMother isNil) ifFalse:

[

	(aSet includes: (aPerson getMother)) ifFalse:

	[

		aSet add: (aPerson getMother).

		self putFamilyOf: (aPerson getMother) inSet: aSet.

	].

].



((aPerson getChildren size) = 0) ifFalse:

[

	(aPerson getChildren) do:

	[:child|

		(aSet includes: child) ifFalse:

		[

		aSet add: (child).

		self putFamilyOf: child inSet: aSet.

		].

	].

].


((aPerson getSiblings size) = 0) ifFalse:
[
	(aPerson getSiblings) do:
	[:sibling|
		(aSet includes: sibling) ifFalse:
		[
		aSet add: (sibling).
		self putFamilyOf: sibling inSet: aSet.
		].
	].
].

((aPerson getMarriages size) = 0) ifFalse:
[
	(aPerson getMarriages) do:
	[:marriage|
		(aSet includes: (marriage getSpouse)) ifFalse:
		[
		aSet add: (marriage getSpouse).
		self putFamilyOf: (marriage getSpouse) inSet: aSet.
		].
	].
].! !


!Traversal class methodsFor: 'testing' stamp: 'blg 9/15/2002 01:06'!
test

	"make a few people, link them and try to build a tree. just for fun, donchaknow"





|a b i j k m p q|

a _ Person new.

b _ Person new.

i _ Person new.

j _ Person new.

k _ Person new.

m _ Person new.

p _ Person new.

q _ Person new.

a surName: 'a'; hasChild: i with: b; hasChild: j with: b; hasChild: k with: b; isMale.

b surName: 'b'; hasChild: i with: a; hasChild: j with: a; hasChild: k with: a; isFemale.

i surName: 'i'; hasFather: a; hasMother: b; isFemale.

j surName: 'j'; hasFather: a; hasMother: b; isMale.

m surName: 'm'; hasChild: p with: k; hasChild: q with: k; isFemale.

k surName: 'k'; hasFather: a; hasMother: b; hasChild: p with: m; hasChild: q with: m; isMale.

p surName: 'p'; hasMother: m; hasFather: k; isFemale.

q surName: 'q'; hasMother: m; hasFather: k; isMale.

m married: k on: (Date newDay: 23 month: 10 year: 1978).

k married: m on: (Date newDay: 23 month: 10 year: 1978).



Traversal traverseFrom: m do: 

[:thisPerson|

	thisPerson givenName: 'added by traverse!!!!'.

].



Traversal traverseFrom: k do:

[:thisPerson|

	Transcript show: thisPerson getSurname, ' ', thisPerson getGivenName;cr.

].! !

!Traversal class methodsFor: 'testing' stamp: 'AWP 9/19/2002 01:20'!
testMore

| adam kathy william jerry dorothy jessie bill karla kim kristi francine |
Transcript clear.
adam := Person new.adam givenName: 'Adam'.
kathy := Person new.kathy givenName: 'Kathy'.
william := Person new.william givenName: 'William'.
jerry := Person new.jerry givenName: 'Jerry'.
dorothy := Person new.dorothy givenName: 'Dorothy'.
jessie := Person new.jessie givenName: 'Jessie'.
bill := Person new.bill givenName: 'Bill'.
francine _ Person new. francine givenName: 'francine'.

karla := Person new. karla givenName: 'Karla'.
kim := Person new. kim givenName: 'Kim'.
kristi := Person new. kristi givenName: 'Kristi'.


"CODE FOR ADDING kim, karla, and kristi as siblings *doesn't work*"
dorothy hasSibling: kim.
dorothy hasSibling: kristi.
dorothy hasSibling: karla.

"CODE FOR ADDING kim, karla, and kristi as children *works"
"dorothy hasChild: kim with: jerry.
dorothy hasChild: kristi with: jerry.
dorothy hasChild: karla with: jerry.
dorothy hasChild: kathy with: jerry."

"testing traverse of JUSt a spouse no children to otherwise get to the spouse"
william married: francine on: (Date newDay: 3 month: 3 year: 1999).

kathy hasChild: adam with: william.
adam hasMother: kathy.
adam hasFather: william.
kathy hasMother: dorothy.
kathy hasFather: jerry.
william hasFather: bill.
william hasMother: jessie.

Traversal traverseFrom: adam do: 
[:thisPerson|
	thisPerson surName: 'Parker'.
].

Traversal traverseFrom: adam do:
[:thisPerson|
	Transcript show: thisPerson getGivenName,' ', thisPerson getSurname;cr.
].

adam visualize.! !



Link to this Page