Plugin Store

Change Specific Fact Tag.fh_lua

--[[
@Title:       Change Specific Fact Tag
@Type:        Standard
@Author:      Mark Draper
@Version:     1.0.2
@LastUpdated: 3 Aug 2022
@Licence:     This plugin is copyright (c) 2022 Mark Draper and is licensed under the MIT License which
 is hereby incorporated by reference (see https://pluginstore.family-historian.co.uk/fh-plugin-licence)
@Description: Converts an Individual or Family Record fact to a new fact type.  All facts in fact sets
are supported, including local local project facts.
]]

--[[
30 May 2022 - 1.0
	First store version, based on FHUG prototype 0.4
17 Ju1 2022 - 1.0.1
	Improved robustness for inconsistent Fact Set structures (various FH bugs)
		- List of facts can be anywhere in Fact definition file, not just at beginning
		- Does not process facts with no name or label (e.g. Alternative Name in RM Import)
		- Ignores missing Fact Sets
		- Sets can be in any priority order, not in sequence
3 Aug 2022 - 1.0.2
		- Ignores facts missing either index entry or definition to cope with flawed Military Fact Set
		- Rewritten Fact Set loading for fewer passes through file
]]

fhInitialise(7,0,0, 'save_recommended')		-- only works in FH7

require 'luacom'
require('iuplua')
iup.SetGlobal('CUSTOMQUITMESSAGE','YES')

function main()

	local pF = fhNewItemPtr()

	-- which record is in the Property Box?

	local p = fhGetCurrentPropertyBoxRecord()

	if p:IsNull() then
		fhMessageBox('Property Box not open!', 'MB_OK', 'MB_ICONSTOP')
		return
	end

	if fhGetTag(p) ~= 'INDI' then
		local Msg = 'Plugin requires an Individual Record visible in the Property Box!'
		fhMessageBox(Msg, 'MB_OK', 'MB_ICONSTOP')
		return
	end

	-- determine fact set priority and read in sets in decreasing priority order

	local tblFactSets = {}
	for _, scope in ipairs({'Project', 'System'}) do
		GetFactSets(scope, tblFactSets)
	end

	local tblFacts = {}

	for i = #tblFactSets, 1, -1 do
		GetFactSet(tblFactSets[i] .. '.fhf', tblFacts)
	end

	local tblFactGroups = PopulateFactTables(tblFacts)
	if not tblFactGroups then return end		-- end if duplicate fact labels found

	repeat
		local tblRecordFacts = GetRecordFacts(p)		-- Pointers to the Individual's Facts

		local OldFactText, NewFactLabel, OldFactType, NewFactType = DisplayIUP(fhGetDisplayText(p),
				tblFacts, tblRecordFacts, tblFactGroups)
		if not OldFactText then return end			-- Cancel button pressed

		-- get pointer to old fact

		local pOldFact = tblRecordFacts[OldFactText]

		-- get name and tag of new fact

		local NewFactName, NewFactTag
		for FactTag, FactDetail in pairs(tblFacts) do
			if FactDetail.Label == NewFactLabel then
				NewFactName = FactDetail.Name
				NewFactTag = FactTag:sub(1, -4)
				break
			end
		end

		-- check witness roles before confirming change and making substitution

		if WitnessCheck(tblFacts, tblRecordFacts[OldFactText], NewFactName) then
			local Msg = 'Change ' .. OldFactText .. ' to ' .. NewFactLabel .. '?'
			if OldFactType == 'E' and NewFactType == 'A' then
				Msg = Msg .. '\n\nCAUTION: You are converting an Event to an Attribute.'
			elseif OldFactType == 'A' and NewFactType == 'E' then
				Msg = Msg .. '\n\nCAUTION: You are converting an Attribute to an Event.' ..
					'\nAny Attribute value will be saved as a local note in the new Event fact.'
			end
	
			if fhMessageBox(Msg, 'MB_OKCANCEL', 'MB_ICONQUESTION') == 'OK' then
				ChangeFact(pOldFact, NewFactTag)
			end
		end	
	until false
end

-- ************************************************************************** --

function ChangeFact(pOldFact, NewFactTag)

	-- find fact parent record

	local pR = fhNewItemPtr()
	pR:MoveToParentItem(pOldFact)

	-- add new fact and clone details from old one

	local pNewFact = fhCreateItem(NewFactTag, pR)
	if pNewFact:IsNull() then
		fhMessageBox('Failed to create new fact!', 'MB_OK', 'MB_ICONSTOP')
		return
	end

	fhMoveItemBefore(pNewFact, pOldFact)
	fhSetValue_Copy(pNewFact, pOldFact)
	CopyChildren(pOldFact, pNewFact)	-- recursive copy as per FHUG snippet

	-- get any fact value and save as local note if lost

	local MsgUpdate = ''
	local OldFactValue = fhGetValueAsText(pOldFact) or ''
	local NewFactValue = fhGetValueAsText(pNewFact) or ''
	if OldFactValue ~= '' and NewFactValue == '' then
		if fhGetItemPtr(pOldFact, '~.NOTE2'):IsNotNull() then
			MsgUpdate = '\n\nTo view the saved Attribute value, ' ..
					'click on the All tab in the FH Property Box.'
		end
		local pN = fhCreateItem('NOTE2', pNewFact)
		fhSetValueAsText(pN, OldFactValue)
	end

	-- delete old fact

	fhDeleteItem(pOldFact)
	fhUpdateDisplay()

	fhMessageBox('Fact updated.' .. MsgUpdate, 'MB_OK', 'MB_ICONINFORMATION')
end

-- ************************************************************************** --

function CopyBranch(pSource,pTarget)

	local Tag = fhGetTag(pSource)
	if Tag == '_FMT' then return end		-- Skip rich text format code
	if Tag == '_FIELD' then				-- Substitute metafield shortcut
		Tag = fhGetMetafieldShortcut(pSource)
	end

	local pNew = fhCreateItem(Tag,pTarget,true)
	if pNew:IsNull() then return end		-- Escape if item not created
	fhSetValue_Copy(pNew,pSource)
	CopyChildren(pSource,pNew)
end

-- ************************************************************************** --

function CopyChildren(pSource,pTarget)

	local pFrom = fhNewItemPtr()
	pFrom = pSource:Clone()
	pFrom:MoveToFirstChildItem(pFrom)
	while pFrom:IsNotNull() do
		CopyBranch(pFrom,pTarget)
		pFrom:MoveNext()
	end
end

-- ************************************************************************** --

function DisplayIUP(strTitle, tblFacts, tblRecordFacts, tblFactGroups)

	local OldFactType, OldFactText, NewFactType, NewFactLabel
	local Parent, Label
	local OK = false

	local tblOldEvents, tblOldAttributes = GetOldFacts(tblFacts, tblRecordFacts)

	-- set default IUP font

	local Registry = 'HKEY_CURRENT_USER\\Software\\Calico Pie\\Family Historian\\2.0\\'
	local k = getRegKey(Registry .. 'Preferences\\PDX Font')
	local scaling = getRegKey(Registry .. 'Preferences\\Font Scaling Percent') or 100

	local tblK = ParseString(k)
	local font = tblK[14]
	local size = tblK[1] * scaling / 100

 	iup.SetGlobal('DEFAULTFONT',font .. ' ' .. size//20)

	local X = 5 * scaling // 100
	local Y = 3 * scaling // 100
	local ButtonPadding = (X|0) .. 'x' .. (Y|0)

	-- define menu elements

	local lstOE = iup.list{'(none selected)', dropdown='Yes', size=200, value=1, expand='Yes',
			VisibleItems=10, tip='Select existing event'}
	for k, v in ipairs(tblOldEvents) do lstOE[k+1] = v end
	local OldEvent = iup.hbox{iup.label{title='Event:',size=40}, lstOE}

	local lstOA = iup.list{'(none selected)', dropdown='Yes', size=200, value=1, expand='Yes',
			VisibleItems=10, tip='Select existing attribute'}
	for k, v in ipairs(tblOldAttributes) do lstOA[k+1] = v end
	local OldAttribute = iup.hbox{iup.label{title='Attribute:',size=40}, lstOA}

	local lstNE = iup.list{'(none selected)', dropdown='Yes', size=200, value=1, expand='Yes',
			VisibleItems=10, tip='Select new event', active='No'}
	local NewEvent = iup.hbox{iup.label{title='Event:',size=40}, lstNE}

	local lstNA = iup.list{'(none selected)', dropdown='Yes', size=200, value=1, expand='Yes',
			VisibleItems=10, tip='Select new attribute', active='No'}
	local NewAttribute = iup.hbox{iup.label{title='Attribute:',size=40}, lstNA}

	local OldFact = iup.vbox{OldEvent, OldAttribute; margin='15x5', gap=5}
	local NewFact = iup.vbox{NewEvent, NewAttribute; margin='15x5', gap=5}

	local btnOK = iup.button{title='OK', active='No', tip='Process change'}
	local btnClear = iup.button{title='Clear', tip='Clear form', padding=ButtonPadding}
	local btnClose = iup.button{title='Close', tip='Close plugin'}
	local btnHelp = iup.button{title='Help', tip='Show help'}

	local Buttons = iup.hbox{iup.fill{}, btnOK, btnClear, btnHelp, btnClose, iup.fill{};
		margin='10x10', normalizesize='Both', padding=10, gap=20}

	-- define button callbacks

	function btnOK:action()
		OK = true
		return iup.CLOSE
	end

	function btnClear:action()
		lstOE.value = 1
		lstOA.value = 1
		lstOE.active = 'Yes'
		lstOA.active = 'Yes'
		ClearNewFacts()
	end

	function btnClose:action()
		return iup.CLOSE
	end

	function btnHelp:action()
		local Cmd = 'https://pluginstore.family-historian.co.uk/page/help/' ..
				'change-specific-fact-tag'
		fhShellExecute(Cmd)
		fhSleep(1000)			-- slight pause to suspend immediate redraw
	end

	-- define list callbacks

	function lstOE:valuechanged_cb()
		if tonumber(lstOE.value) > 1 then
			OldFactText = lstOE[lstOE.value]
			Label, Parent = GetOldFactDetails(OldFactText, tblFacts, tblRecordFacts)
			PopulateNewFact(Parent, Label)
			lstOA.value = 1
			lstOA.active = 'No'
			OldFactType = 'E'
		else
			lstOA.active = 'Yes'
			if tonumber(lstOA.value) == 1 then		-- no old fact now selected
				ClearNewFacts()
			end
		end
	end

	function lstOA:valuechanged_cb()
		if tonumber(lstOA.value) > 1 then
			OldFactText = lstOA[lstOA.value]
			Label, Parent = GetOldFactDetails(OldFactText, tblFacts, tblRecordFacts)
			PopulateNewFact(Parent, Label)
			lstOE.value = 1
			lstOE.active = 'No'
			OldFactType = 'A'
		else
			lstOE.active = 'Yes'
			if tonumber(lstOE.value) == 1 then		-- no old fact now selected
				ClearNewFacts()
			end
		end
	end

	function lstNE:valuechanged_cb()
		if tonumber(lstNE.value) > 1 then
			NewFactLabel = lstNE[lstNE.value]
			NewFactType = 'E'
			lstNA.value = 1
			lstNA.active = 'No'
			btnOK.active = 'Yes'
		else
			lstNA.active = 'Yes'
			btnOK.active = 'No'
		end
	end

	function lstNA:valuechanged_cb()
		if tonumber(lstNA.value) > 1 then
			NewFactLabel = lstNA[lstNA.value]
			NewFactType = 'A'
			lstNE.value = 1
			lstNE.active = 'No'
			btnOK.active = 'Yes'
		else
			lstNE.active = 'Yes'
			btnOK.active = 'No'
		end
	end

	function PopulateNewFact(Parent, Label)
		lstNE.RemoveItem = 'All'
		lstNA.RemoveItem = 'All'
		lstNE.AppendItem = '(none selected)'
		lstNA.AppendItem = '(none selected)'
		if Parent == 'I' then
			for _, v in ipairs(tblFactGroups.IE) do
				if v ~= Label then lstNE.AppendItem = v end
			end
			for _, v in ipairs(tblFactGroups.IA) do
				if v ~= Label then lstNA.AppendItem = v end
			end
		else
			for _, v in ipairs(tblFactGroups.FE) do
				if v ~= Label then lstNE.AppendItem = v end
			end
			for _, v in ipairs(tblFactGroups.FA) do
				if v ~= Label then lstNA.AppendItem = v end
			end
		end

		lstNE.value = 1
		lstNE.active = 'Yes'
		lstNA.value = 1
		lstNA.active = 'Yes'
		btnOK.active = 'No'
	end

	function ClearNewFacts()
		lstNE.value = 1
		lstNE.active = 'No'
		lstNA.value = 1
		lstNA.active = 'No'
		btnOK.active = 'No'
	end

	-- assemble final menu

	local Container = iup.vbox{
		iup.frame{OldFact; title='Original Event or Attribute:'},
		iup.frame{NewFact; title='New Event or Attribute:'},
		Buttons; margin='20x20', gap=20}

	dlg = iup.dialog{Container, title='Change Fact for ' .. strTitle;
		resize='Yes', maxbox='No', minbox='No'}

	dlg:map()

	local DialogWidth = dlg.NaturalSize:match('^%d+')
	local DialogHeight = dlg.NaturalSize:match('%d+$')
	dlg.minsize = DialogWidth .. 'x' .. DialogHeight
	dlg.maxsize = 'x' .. DialogHeight

	dlg:showxy(iup.CENTER,iup.CENTER)
	iup.MainLoop()

	dlg:destroy()

	if OK then return OldFactText, NewFactLabel, OldFactType, NewFactType end
end

-- ************************************************************************** --

function GetFactSet(File, tblFacts)

	local tblFile = ReadUTF16File(File)
	if not tblFile then return end

	-- identify facts listed in index

	local tblIndexFacts = {}
	local index = false
	local tblFactDefs = {}
	local ActiveFact, WitnessFact

	for _, line in ipairs(tblFile) do
		if index then
			local FactTag = line:match('^Item%d+=(.+)$')
			if FactTag then tblIndexFacts[FactTag] = true end
			if line:sub(1,1) == '[' then				-- end of index section
				index = false
			end
		elseif line == '[.index]' then
			index = true
			ActiveFact = nil
		end

		if line:match('^%[FCT-') and line:match('-[IF][EA]]$') then		-- start of fact definition
			ActiveFact = line:sub(6, -2)
			tblFactDefs[ActiveFact] = {}
		end

		if ActiveFact then
			local term, value = line:match('^(%a+)=(.+)$')
			if term == 'Name' then tblFactDefs[ActiveFact].Name = value end
			if term == 'Label' then tblFactDefs[ActiveFact].Label = value end
			if term == 'Hidden' then tblFactDefs[ActiveFact].Hidden = value end
		end
	end

	-- second pass to identify witness roles (not always listed with main fact definition)

	local witnesses

	for _, line in ipairs(tblFile) do
		if line:match('^%[FCT-') and line:match('-ROLE]$') then		-- start of witness definition
			WitnessFact = line:sub(6, -7)
		end

		local _, Role = line:match('^Role(%d+)=(.+)$')
		if Role then
			if not tblFactDefs[WitnessFact].Witnesses then tblFactDefs[WitnessFact].Witnesses = {} end
			table.insert(tblFactDefs[WitnessFact].Witnesses, Role)
		end
	end		

	-- add valid facts to main table

	for Tag, Fact in pairs(tblFactDefs) do
		if not (Fact.Hidden and Fact.Hidden == 'Y') then
			if Fact.Name and Fact.Label and tblIndexFacts[Tag] then
				tblFacts[Tag] = {}
				tblFacts[Tag].Name = Fact.Name
				tblFacts[Tag].Label = Fact.Label
				if Fact.Witnesses then
					tblFacts[Tag].Witnesses = Fact.Witnesses
				end
			end
		end
	end
end

-- ************************************************************************** --

function GetFactSets(Context, tblFactSets)

	-- read in fact set priority list and store in ordered table

	local File, Folder
	local tblFS = {}
	local MaxValue = 0

	if Context == 'Project' then
		Folder = fhGetContextInfo('CI_PROJECT_DATA_FOLDER')
		File = Folder .. '\\Fact Types\\GroupIndex.fhdata'
	else
		Folder = fhGetContextInfo('CI_APP_DATA_FOLDER')
		File = Folder .. '\\Fact Types\\Standard\\GroupIndex.fhdata'
	end

	local tblFile = ReadUTF16File(File)
	for _, v in ipairs(tblFile) do
		local set, priority = v:match('^(.+)=(%d+)$')
		if set and priority then
			priority = tonumber(priority)|0
			if priority > MaxValue then MaxValue = priority end
			if Context == 'System' then
				if set == 'Standard' then
					tblFS[priority] = Folder .. '\\Fact Types\\Standard\\' .. set
				else
					tblFS[priority] = Folder .. '\\Fact Types\\Custom\\' .. set
				end
			else
				tblFS[priority] = Folder .. '\\Fact Types\\' .. set
			end
		end
	end

	-- copy to main table

	for i=1, MaxValue do
		if tblFS[i] then table.insert(tblFactSets, tblFS[i]) end
	end
end

-- ************************************************************************** --

function GetOldFactDetails(OldFactText, tblFacts, tblRecordFacts)

	-- return Parent (I or F) and Label of specified old fact

	local pF = tblRecordFacts[OldFactText]
	local pR = fhNewItemPtr()
	pR:MoveToParentItem(pF)

	local Parent = fhGetTag(pR):sub(1, 1)
	local Tag = fhGetTag(pF)

	if fhIsEvent(pF) then
		Tag = Tag .. '-' .. Parent .. 'E'
	else
		Tag = Tag .. '-' .. Parent .. 'A'
	end

	if tblFacts[Tag] then
		return tblFacts[Tag].Label, Parent
	else
		return '', Parent		-- custom fact does not have a Label
	end
end

-- ************************************************************************** --

function GetOldFacts(tblFacts, tblRecordFacts)

	-- get fact details

	local pF = fhNewItemPtr()
	local tblE = {}
	local tblA = {}

	for RecordText, pF in pairs(tblRecordFacts) do
		local FactLabel = GetOldFactDetails(RecordText, tblFacts, tblRecordFacts)
		if FactLabel == '' then FactLabel = fhGetDisplayText(pF):match('^%S+') end
		local DayNumber = fhCallBuiltInFunction('Daynumber', fhGetValueAsDate(fhGetItemPtr(pF, '~.DATE')):GetDatePt1()) or ''
		local SortTag = FactLabel .. DayNumber .. '<>'

		if fhIsEvent(pF) then table.insert(tblE, SortTag .. fhGetDisplayText(pF)) end
		if fhIsAttribute(pF) then table.insert(tblA, SortTag .. fhGetDisplayText(pF)) end
	end

	table.sort(tblE)			-- alphabetical/chronological
	table.sort(tblA)

	-- strip out sort tags prior to display

	for k, v in ipairs(tblE) do tblE[k] = v:sub(v:find('<>') + 2) end
	for k, v in ipairs(tblA) do tblA[k] = v:sub(v:find('<>') + 2) end

	return tblE, tblA
end

-- ************************************************************************** --

function GetRecordFacts(p)

	-- get Individual and Family Facts for subject individual

	local pF = fhNewItemPtr()
	local tblT = {}

	pF:MoveToFirstChildItem(p)
	while pF:IsNotNull() do
		if fhGetTag(pF) == 'FAMS' then
			local pL = fhGetValueAsLink(pF)
			local pFL = fhNewItemPtr()
			pFL:MoveToFirstChildItem(pL)
			while pFL:IsNotNull() do
				if fhIsFact(pFL) then tblT[fhGetDisplayText(pFL)] = pFL:Clone() end
				pFL:MoveNext()
			end
		elseif fhIsFact(pF) then
			tblT[fhGetDisplayText(pF)] = pF:Clone()
		end
		pF:MoveNext()
	end
	return tblT
end

-- ************************************************************************** --

function PopulateFactTables(tblFacts)

	-- check for duplicate fact labels

	local tblFactLabels = {}
	for _, FactDetails in pairs(tblFacts) do
		if tblFactLabels[FactDetails.Label] then
			local Msg = 'There is more than one Fact labelled "' .. FactDetails.Label ..
					'".  Please check your Fact definitions'
			fhMessageBox(Msg, 'MB_OK', 'MB_ICONSTOP')
			return
		end
		tblFactLabels[FactDetails.Label] = true
	end

	-- populate tables used in interface dialogue

	local tblIE = {}
	local tblIA = {}
	local tblFE = {}
	local tblFA = {}
	local tblFactGroups = {}

	for Tag, FactDetails in pairs(tblFacts) do
		if Tag:match('IE$') then table.insert(tblIE, FactDetails.Label) end
		if Tag:match('IA$') then table.insert(tblIA, FactDetails.Label) end
		if Tag:match('FE$') then table.insert(tblFE, FactDetails.Label) end
		if Tag:match('FA$') then table.insert(tblFA, FactDetails.Label) end
	end

	table.sort(tblIE)
	table.sort(tblIA)
	table.sort(tblFE)
	table.sort(tblFA)

	tblFactGroups.IE = tblIE
	tblFactGroups.IA = tblIA
	tblFactGroups.FE = tblFE
	tblFactGroups.FA = tblFA

	return tblFactGroups
end

-- ************************************************************************** --

function ReadUTF16File(File)

	local FileContents = fhLoadTextFile(File, 'UTF-16LE')
	if not FileContents then return end
	local tblFile = {}
	for line in FileContents:gmatch('[^\r\n]+') do
		table.insert(tblFile, line)
	end
	return tblFile
end

-- ************************************************************************** --

function WitnessCheck(tblFacts, pF, NewFactName)

	local pS = fhNewItemPtr()
	local tblMissing = {}
	local AllFound = true

	-- identify witnesses and check if role exists in new fact definition

	pS:MoveToFirstChildItem(pF)
	while pS:IsNotNull() do
		if fhGetTag(pS) == '_SHAR' or fhGetTag(pS) == '_SHAN' then
			local OldFactRole = fhGetValueAsText(fhGetItemPtr(pS, '~.ROLE'))
			local Found = false

			for k,v in pairs(tblFacts) do
				if k == NewFactName then
					if v.Witnesses then
						for _, NewFactRole in ipairs(v.Witnesses) do
							if NewFactRole == OldFactRole then Found = true end
						end
					end
				end
			end

			if not Found then
				tblMissing[OldFactRole] = true
				AllFound = false
			end
		end
		pS:MoveNext()
	end

	if AllFound then return true end		-- no missing witness roles

	local Msg = 'The following Witness Roles are present in the old Fact Record but ' ..
		'missing from the definition of the new Fact Record.  Please update the new ' ..
		'Fact definition before changing this fact name. \n\n'

	for Role, _ in pairs(tblMissing) do Msg = Msg .. Role .. '\n' end
	fhMessageBox(Msg,'MB_OK', 'MB_ICONSTOP')
end

-- ************************************************************************** --

function getRegKey(key)
    local sh = luacom.CreateObject 'WScript.Shell'
    local ans
    if pcall(function () ans = sh:RegRead(key) end) then
      return ans
    else
      return nil,true
    end
end

-- *********************************************************************

function ParseString(S)

	-- splits a delimited string into a table without using stringx library

	local tblT = {}

	while true do
		local i = S:find(',')
		if not i then							--	no more delimiters
			table.insert(tblT, S)
			break
		end
		table.insert(tblT, S:sub(1,i-1))
		S = S:sub(i+1)
	end
	return tblT
end

-- *********************************************************************

main()

Source:Change-Specific-Fact-Tag-3.fh_lua