* file root (eventually)

For users to report plugin bugs and request plugin enhancements; and for authors to test new/new versions of plugins, and to discuss plugin development (in the Programming Technicalities sub-forum). If you want advice on choosing or using a plugin, please ask in General Usage or an appropriate sub-forum.
Post Reply
User avatar
Ron Melby
Megastar
Posts: 917
Joined: 15 Nov 2016 15:40
Family Historian: V6.2

file root (eventually)

Post by Ron Melby »

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?
FH V.6.2.7 Win 10 64 bit
User avatar
Ron Melby
Megastar
Posts: 917
Joined: 15 Nov 2016 15:40
Family Historian: V6.2

Re: file root (eventually)

Post by Ron Melby »

here is code you can copy in your program to order your FAM records by generation:

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
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.
FH V.6.2.7 Win 10 64 bit
Post Reply