I have a plugin in which I order families for printing out a report.
the order is like ahentafel or a register.
In the case of my file, I am the file root, however with anyone below me anywhere in the chain as file root the system still works.
I first grab file root (which can be chosen)
I then read back all ancestor families from FAMCs, in the record I include Fathers side/Mothers side, generation in negative, FAMS record, and INDI record.
when I find a record without FAMC I put it in the treetop file.
I sort it generation ascending (gen is negative so largest gen like -12 is entry 1) fathers side(=2) before mothers side(=3) and remove duplicate family numbers and indi numbers.
I then take the top Fathers record and top mothers record and run descendants by reading each famc and fams record and putting them (uniquely) in order of their occurance in an array.
I create a reverse array from my file called unq:
for k, v in(unq) do
uhash[v] = k
end
I then read FAM records and insert at the end of the file, those fams not in the array uhash (they must be in a different pool).
Is there anyone who uses a file root that is not similar; (that is: someone that is in one direct line but not another?
* file root (eventually)
file root (eventually)
FH V.6.2.7 Win 10 64 bit
Re: file root (eventually)
here is code you can copy in your program to order your FAM records by generation:
instructions are in the code. As always if there is a quicker better way to do this, let me know. I thought about encapsulating it in an array, but in this case not sure how to do it, I do not want to alias Order_FAM to make it work.
Code: Select all
local ipairs = ipairs
local pairs = pairs
local fhGetRecordId = fhGetRecordId
local fhGetItemPtr = fhGetItemPtr
local fhGetValueAsLink = fhGetValueAsLink
local fhNewItemPtr = fhNewItemPtr
local fhGetTag = fhGetTag
local fhPromptUserForRecordSel = fhPromptUserForRecordSel
local fhMessageBox = fhMessageBox
local fhGetItemText = fhGetItemText
local fhCallBuiltInFunction = fhCallBuiltInFunction
local _ptyp -- pointer type
local _ptag -- pointer tag for linking
local xptr = fhNewItemPtr() -- convert rcdid to pointer
-- str sltROOT variables
local _ptrROOT
local _ptrFATHER
local _ptrMOTHER
local WS_CANCEL = false
local WS_Cancel = 'Cancel'
local WS_ENTER = true
local WS_OK = 'OK'
local _slt = {}
-- end sltROOT variables
local hash = {} -- hash table to produce unique families
local tmp = {} -- temporary table holder
local inz = {} -- unique tree tops ancestors table
local utp = {} -- unique tree tops ancestors table
local uhash = {} -- unique hash for family order
local unq = {} -- unique reorganization of family order based on root chosen
-- (next two lines used for compiling, it will be immediately discarded)
que = {}
que.__index = que
function que:enQ(ent)
self.q[self.tail] = ent
self.tail = self.tail + 1
end
function que:deQ()
if self.tail == self.head then return end
local ent = self.q[self.head]
self.head = self.head + 1
return ent
end
function que:isNotEmpty()
return self.tail ~= self.head
end
function que:isEmpty()
return self.tail == self.head
end
function que.create()
local _q = {}
setmetatable(_q, que)
_q.__index = _q
_q.head = 0
_q.tail = 0
_q.q = {nil}
_q.len = 0
return _q
end
local QFAM = que.create()
setmetatable(que, nil)
-- compiling done, discard
que = nil
-- materialize INDI RCD ID
local function matiID(iptr)
_ptyp = type(iptr)
if _ptyp == 'number' then
xptr = fhGetItemPtr()
xptr:MoveToRecordById('INDI', iptr)
iptr = xptr:Clone()
end
return
{
iID = fhGetRecordId(iptr),
iPTR = iptr:Clone(),
}
end -- fn matiID
-- materialize FAM RCD ID
local function matfID(fptr)
_ptyp = type(fptr)
if _ptyp == 'userdata' then
_ptag = fhGetTag(fptr)
if _ptag == 'FAMC'
or _ptag == 'FAMS' then
fptr = fhGetValueAsLink(fptr)
end
elseif _ptyp == 'number' then
xptr:MoveToRecordById('FAM', fptr)
fptr = xptr:Clone()
end
return
{
fID = fhGetRecordId(fptr),
fPTR = fptr:Clone(),
}
end -- fn matfID
-- materialize SEX
local function matSEX(iptr)
_ptyp = type(iptr)
if _ptyp == 'number' then
xptr:MoveToRecordById('INDI', iptr)
iptr = xptr:Clone()
end
local SEX = string.sub(fhGetItemText(iptr,'~.SEX'), 1, 1)
if SEX == '' then SEX = '?' end
return
{
SEX = SEX,
}
end -- fn matSEX
-- enqueues unique fams and famc from rtv_FAM_tbl
local function enQtbl(ftbl)
for _, fID in ipairs(ftbl) do
if not uhash[fID] then
QFAM:enQ(fID)
uhash[fID] = true
end
end
end
-- retrieves a table containing INDI FAMS and FAMC records
local function rtv_FAM_tbl(iptr, tag)
local itbl = {}
local _ptyp = type(iptr)
if _ptyp == 'number' then
xptr:MoveToRecordById('INDI', iptr)
iptr = xptr:Clone()
end
if not tag
or tag == 'FAMC' then
local ptrFAMC = fhGetItemPtr(iptr, '~.FAMC')
while ptrFAMC:IsNotNull() do
local _fs = matfID(ptrFAMC)
if not uhash[_fs.fID] then unq[#unq + 1] = _fs.fID itbl[#itbl + 1] = _fs.fID end
ptrFAMC:MoveNext('SAME_TAG')
end
end
if not tag
or tag == 'FAMS' then
local ptrFAMS = fhGetItemPtr(iptr, '~.FAMS')
while ptrFAMS:IsNotNull() do
local _fs = matfID(ptrFAMS)
if not uhash[_fs.fID] then unq[#unq + 1] = _fs.fID itbl[#itbl + 1] = _fs.fID end
ptrFAMS:MoveNext('SAME_TAG')
end
end
return itbl
end -- fn rtv__FAM_tbl
-- reads the queue entries in order of descendants
local function prc_Q()
while QFAM:isNotEmpty() do
local ptrFAM = QFAM:deQ()
xptr:MoveToRecordById('FAM', ptrFAM)
ptrFAM = xptr:Clone()
-- same sex male
local lnkHUSB = fhNewItemPtr()
local ptrHUSB = fhNewItemPtr()
lnkHUSB = fhGetItemPtr(ptrFAM, '~.HUSB[1]>')
ptrHUSB = fhGetItemPtr(ptrFAM, '~.HUSB[2]>')
-- same sex female
local lnkWIFE = fhNewItemPtr()
local ptrWIFE = fhNewItemPtr()
lnkWIFE = fhGetItemPtr(ptrFAM, '~.WIFE[1]>')
ptrWIFE = fhGetItemPtr(ptrFAM, '~.WIFE[2]>')
if lnkHUSB:IsNotNull() and ptrHUSB:IsNotNull() then lnkWIFE = ptrHUSB end
if lnkWIFE:IsNotNull() and ptrWIFE:IsNotNull() then lnkHUSB = lnkWIFE lnkWIFE = ptrWIFE end
if lnkHUSB:IsNotNull() then enQtbl(rtv_FAM_tbl(lnkHUSB)) end
if lnkWIFE:IsNotNull() then enQtbl(rtv_FAM_tbl(lnkWIFE)) end
local lnkCHIL = fhNewItemPtr()
local ptrCHIL = fhNewItemPtr()
lnkCHIL = fhGetItemPtr(ptrFAM, '~.CHIL')
while lnkCHIL:IsNotNull() do
ptrCHIL = fhGetValueAsLink(lnkCHIL)
enQtbl(rtv_FAM_tbl(ptrCHIL))
lnkCHIL:MoveNext('SAME_TAG')
end
end
return
end
-- retrieve the tops of the FAM chain (no FAMC)
local function rtv_treetops(fptr)
-- reorganize utp (treetops table)
local function rgz_tbl()
-- remove duplicate individuals and get FAMS table
-- sort generation
-- 1. GEN: generation negative descending
-- root FAMC is 1 and subtract a generation each recursion
-- 2. fathers line(2) before mothers line(3) if all else equal
table.sort(utp,
function(a, b)
if a.GEN == b.GEN then
return a.PTG < b.PTG
end
return a.GEN < b.GEN
end
)
-- utp is a table of all ancestors of selected root
-- there are cases where the INDI ID can be multiple hash insures unique INDI ID
-- get the FAMS table for the unique INDI ID
hash = {}
tmp = utp
utp = {}
for _, v in ipairs(tmp) do
if not hash[v.iID] then
utp[#utp + 1] = v
utp[#utp].fams = rtv_FAM_tbl(v.iID, 'FAMS')
hash[v.iID] = true
end
end
-- remove duplicate FAM ID (typically HUSB and WIFE. Since it is sorted male side first, the duplicate female side would not be written)
hash = {}
tmp = utp
utp = {}
local ix = 1
for k, _ in ipairs(tmp) do
local g = tmp[k]
for j, _ in ipairs(g.fams) do
local fid = g.fams[j]
if not hash[fid] then
utp[ix] = {fID = fid, GEN = g.GEN, PTG = g.PTG}
hash[fid] = true
ix = ix + 1
end
end
end -- utp stand alone
-- get one each treetop father and treetop mother (ptg = 2 = HUSB, ptg = 3 = WIFE)
hash = {}
tmp = utp
utp = {}
ix = 1
for k, v in pairs(tmp) do
local g = tmp[k]
if not hash[g.PTG] then
utp[ix] = v
ix = ix + 1
hash[g.PTG] = true
end
end
tmp = nil
hash = nil
end
-- retrieve ancestor chain
local function rtv_anc_chain(fptr, GEN, PTG)
local _ptyp = type(fptr)
if _ptyp == 'number' then
xptr:MoveToRecordById('FAM', fptr)
fptr = xptr:Clone()
elseif _ptyp == 'userdata' then
_ptag = fhGetTag(fptr)
if _ptag == 'FAMC'
or _ptag == 'FAMS' then
fptr = fhGetValueAsLink(fptr)
end
end
-- start exception handling
-- same sex male
local lnkHUSB = fhNewItemPtr()
local ptrHUSB = fhNewItemPtr()
lnkHUSB = fhGetItemPtr(fptr, '~.HUSB[1]>')
ptrHUSB = fhGetItemPtr(fptr, '~.HUSB[2]>')
-- same sex female
local lnkWIFE = fhNewItemPtr()
local ptrWIFE = fhNewItemPtr()
lnkWIFE = fhGetItemPtr(fptr, '~.WIFE[1]>')
ptrWIFE = fhGetItemPtr(fptr, '~.WIFE[2]>')
if lnkHUSB:IsNotNull() and ptrHUSB:IsNotNull() then lnkWIFE = ptrHUSB end
if lnkWIFE:IsNotNull() and ptrWIFE:IsNotNull() then lnkHUSB = lnkWIFE lnkWIFE = ptrWIFE end
-- end exception handling
if lnkHUSB:IsNotNull() then
if lnkHUSB:IsSame(_ptrFATHER) then PTG = 2 GEN = 1 end
local _is = matiID(lnkHUSB)
local _fs = matfID(fptr)
local _ss = matSEX(lnkHUSB)
utp[#utp + 1] = {iID = _is.iID, fID = _fs.fID, GEN = GEN, PTG = PTG, SEX = _ss.SEX,}
rtv_anc_chain(fhGetItemPtr(lnkHUSB, '~.FAMC'), (GEN - 1), PTG)
end
if lnkWIFE:IsNotNull() then
if lnkWIFE:IsSame(_ptrMOTHER) then PTG = 3 GEN = 1 end
local _is = matiID(lnkWIFE)
local _fs = matfID(fptr)
local _ss = matSEX(lnkWIFE)
utp[#utp + 1] = {iID = _is.iID, fID = _fs.fID, GEN = GEN, PTG = PTG, SEX = _ss.SEX,}
rtv_anc_chain(fhGetItemPtr(lnkWIFE, '~.FAMC'), (GEN - 1), PTG)
end
return
end
local _ptyp = type(fptr)
if _ptyp == 'number' then
xptr:MoveToRecordById('FAM', fptr)
fptr = xptr:Clone()
elseif _ptyp == 'userdata' then
_ptag = fhGetTag(fptr)
if _ptag == 'FAMC'
or _ptag == 'FAMS' then
fptr = fhGetValueAsLink(fptr)
end
end
-- *ENTRY
-- from a family pointer get HUSB and WIFE recursively
-- no need to get CHIL records since either they will be either a HUSB, WIFE, or dead end.
local _fs = matfID(fptr)
local fID = _fs.fID
local lnkHUSB = fhNewItemPtr() -- link to father indi
local ptrHUSB = fhNewItemPtr() -- temp father pointer
local lnkWIFE = fhNewItemPtr() -- link to mother indi
local ptrWIFE = fhNewItemPtr() -- temp mother pointer
-- start exception handling
lnkHUSB = fhGetItemPtr(fptr, '~.HUSB[1]>')
ptrHUSB = fhGetItemPtr(fptr, '~.HUSB[2]>')
lnkWIFE = fhGetItemPtr(fptr, '~.WIFE[1]>')
ptrWIFE = fhGetItemPtr(fptr, '~.WIFE[2]>')
-- same sex male
if lnkHUSB:IsNotNull() and ptrHUSB:IsNotNull() then lnkWIFE = ptrHUSB end
-- same sex female
if lnkWIFE:IsNotNull() and ptrWIFE:IsNotNull() then lnkHUSB = lnkWIFE lnkWIFE = ptrWIFE end
-- end exception handling
-- this is the starter: from the root all FAMC
rtv_anc_chain(fID, 1, '')
-- sort and sift the table resulting in the root's: father's treetop and mother's treetop
rgz_tbl()
end --fn rtv_treetops
-- select root
local function sltROOT()
local _roots = {}
_ptrROOT = fhNewItemPtr()
_ptrFATHER = fhNewItemPtr()
_ptrMOTHER = fhNewItemPtr()
_slt['_root'] = {fn_key = '', _roots = _roots, _ptrROOT = _ptrROOT, _ptrFATHER = _ptrFATHER, _ptrMOTHER = _ptrMOTHER}
local WS_RC
-- choose root. if cancel key is pressed and there is a file root, ask to use it.
local function mat_global_roots()
_roots[1] = _ptrROOT:Clone()
_roots[2] = fhNewItemPtr()
_roots[3] = fhNewItemPtr()
local ptrFAMC = fhNewItemPtr()
ptrFAMC = fhGetItemPtr(_ptrROOT, '~.FAMC')
local ptrFAM = fhNewItemPtr()
ptrFAM = fhGetValueAsLink(ptrFAMC)
if ptrFAM:IsNotNull() then
local lnkHUSB = fhNewItemPtr()
local ptrHUSB = fhNewItemPtr()
lnkHUSB = fhGetItemPtr(ptrFAM, '~.HUSB[1]>')
ptrHUSB = fhGetItemPtr(ptrFAM, '~.HUSB[2]>')
local lnkWIFE = fhNewItemPtr()
local ptrWIFE = fhNewItemPtr()
lnkWIFE = fhGetItemPtr(ptrFAM, '~.WIFE[1]>')
ptrWIFE = fhGetItemPtr(ptrFAM, '~.WIFE[2]>')
-- same sex male
if lnkHUSB:IsNotNull() and ptrHUSB:IsNotNull() then lnkWIFE = ptrHUSB end
-- same sex female
if lnkWIFE:IsNotNull() and ptrWIFE:IsNotNull() then lnkHUSB = lnkWIFE lnkWIFE = ptrWIFE end
_ptrFATHER = lnkHUSB
_ptrMOTHER = lnkWIFE
_roots[2] = _ptrFATHER:Clone()
_roots[3] = _ptrMOTHER:Clone()
_slt['_root']._roots = _roots
_slt['_root']._ptrROOT = _ptrROOT
_slt['_root']._ptrFATHER = _ptrFATHER
_slt['_root']._ptrMOTHER = _ptrMOTHER
end
end -- fn mat_global_roots
local function chc_root()
local txt
_ptrROOT = fhCallBuiltInFunction('FileRoot')
if _ptrROOT:IsNull()then
txt = 'File Root not set: Requires Root'
else
local fileroot = fhGetItemText(_ptrROOT, '~.NAME')
txt = ('Use File Root: %s'):format(fileroot)
end
WS_RC = fhMessageBox(txt, 'MB_OKCANCEL')
if WS_RC == WS_Cancel then
_slt['_root'].fn_key = WS_CANCEL
return _slt['_root']
end
if WS_RC == WS_OK then
if _ptrROOT:IsNull()then
WS_RC = sltROOT()
if WS_RC == WS_Cancel then
_slt['_root'].fn_key = WS_CANCEL
return _slt['_root']
end
else
mat_global_roots()
_slt['_root'].fn_key = WS_ENTER
return _slt['_root']
end
end
end -- fn chc_root
-- *ENTRY()
_roots = fhPromptUserForRecordSel('INDI', 1)
if #_roots == 0 then
local _ws = chc_root()
if _ws.fn_key == WS_CANCEL then
_slt['_root'].fn_key = WS_CANCEL
return _slt['_root']
end
else
_ptrROOT = _roots[1]
mat_global_roots()
_slt['_root'].fn_key = WS_ENTER
return _slt['_root'] --** RMV RTN ??
end
--** shouldnt need this??
_slt['_root'].fn_key = WS_ENTER --** RMV??
return _slt['_root']
end --fn sltROOT
-- enQ the treetops as starter seeds for the entire FAM line
local function list_FAM()
inz = rtv_FAM_tbl(_ptrROOT, 'FAMC')
for k, _ in pairs(inz) do
rtv_treetops(inz[k])
end
unq = {}
inz = nil
-- at this point you have treetops 2 and 3
-- retrieve each treetops descendants by family, thus:
-- get their FAMC and FAMS if the FAMx is not in the index then:
-- add that FAMx to the unique index (unq).
for _, v in pairs(utp) do
QFAM:enQ(v.fID)
prc_Q()
end
utp = nil
QFAM = nil
uhash = {}
-- from the unique index reverse it so FAM is k and index is v.
for k, v in ipairs(unq) do
uhash[v] = k
end
-- read all FAM records and missing FAM(s) (they are not in uhash) will be stuck at the end of the unique index ordering. In my tests, missing FAM records are those not in pool 1
local fptr = fhNewItemPtr()
fptr:MoveToFirstRecord('FAM')
while fptr:IsNotNull() do
local ptrfam = fhGetRecordId(fptr)
if not uhash[ptrfam] then
unq[#unq + 1] = ptrfam
end
fptr:MoveNext('SAME_TAG')
end
uhash = nil
return unq
end -- fn get_fam
-- MAIN()
--[[
copy the entire source into your program
then do something like:
famorder = Order_FAM()
for k, v in ipairs(famorder) do
miracle occurs here
end
]]
-- *ENTRY()
function Order_FAM()
local _ro = sltROOT()
if _ro.fn_key == WS_CANCEL then return end
list_FAM()
return unq
end
FH V.6.2.7 Win 10 64 bit