* Family Ordering: algorithm and logic help please.

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: 878
Joined: 15 Nov 2016 15:40
Family Historian: V6.2

Family Ordering: algorithm and logic help please.

Post by Ron Melby » 02 Sep 2022 14:07

what I intend is to order and classify families\
PTG:
2 = fathers family SEQ starts at 0
3 = mothers family SEQ starts at 0
4 = descendants shared by mother and father SEQ starts at 0
5 = unlinked families and records. sequence SEQ starts at 0 (this is unfinished, and not of concern at this time, it needs work but fundamentals are there. class 5s are processed correctly)

I process father then mother seeds

what you will see is, once I have gotten to mother and fathers family record the descendants become mothers family. If I trigger the class 4, those unprocessed mothers family become 4s as well. So at present there are no class 4 records.

the program layout is:

32 que:enQ(ent)
37 que:deQ()
44 que:isNotEmpty()
48 que:isEmpty()
52 que.create()
63 que:reset() **not yet implemented**

87 local sltROOT()
94 local mat_spc_root()
130 local mat_file_root()
** materialize a program root and family, *NB: may be existing file root and family**e

164 local trim(str)
171 local trime(str)
178 local matNAM(iptr)
180 local rtvElemCount(varptr)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
**ignore all functions above this line, they all work correctly**

224 local rtv_FAM_pool(fptr)
** works, but not fully implemented, used only for class 5s**
234 local rtv_FAM_marr(fptr)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
**ignore above functions they all work correctly**

284 local rgz_anc_seeds()
**sifts out the oldest mother's and father's treetop only in the ancestors chain**
320 local rtv_anc_seeds(rcd, tag)
**main wrapper call to initialize recursion**
324 local rtv_anc_chain(rcd, tag)
**recursive get ancestors**
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
**these 'work' crrectly, but are not being used as intended**
**process root seed, to build 1 father and 1 mother treetop**

385 local enQtbl(ftbl)
**enqueue table of only FAMC, only FAMS, or both FAMC and FAMS records for processing**
395 local rtv_FAM_tbl(rcd, tag)
**build table of only FAMC, only FAMS, or both FAMC and FAMS records depending on tag**
425 local prc_Q()
**dequeue records produced by enQtbl or queued by the procedure itself as records are revealed**

521 local list_FAM()
** build and process root seed, to build mother and father treetops**
564 Order_FAM()
**when this becomes a working module within a program, this will be called to build the ordered family table.

---------------------------------------
What is dissatifying?
1. any descendant algorithm I can find does not include wife. I can see why, it is no longer a trivial exercise.
2. because I include otwife, and enqueue root wifes FAMC and FAM, the second seed is not read until after all the wifes records are processed, which are ignored because the records have all been hashed, but resulting in the root wifes tree being upside down.
3. FAMC and FAMS records need different processing. generation is -1 for FAMC and +1 for FAMS, additionally CHIL records generation must be +1
4. in order to actually order records I think I need a 'lining up function':
let's by convention give priority to Father records over Mother records (although realistically we can only be nearly absolutely sure of mother, only a couple cases where we cannot)

given a FAMC or FAMS of mother and father (father will be on left side)
let us consider a FAMS


[1] = 22 [1] = 14
[2] = 33 [2] = 75
[3] = 56 [3] = 89
[4] = 75
[5] = 89

the resulting FAMS order should be (I think)
[1] = 22 H
[2] = 33 H
[3] = 56 H
[4] = 14 W
[5] = 75 B
[6] = 89 B

Yes, this shows them married twice (I got em in my file)

5. for class 4 records one possible way is:

seed could be:
Fathers Treetop
Mothers Treetop
ROOT FAM

when the ROOT FAM is reached for Father, end
when the ROOT FAM is reached for Mother, end
process ROOT FAM and descndants.
finish and process class 5s.

this is undoable in my current code because if I signal root fam for husb or root fam for wife, that 'leg' would stop all proceesing.

I am not slick when it comes to algorithms, and I am sure current code can be simplified,

6. I intend to order the families in a 'register-generational' like order. but a method should be included in the records so that i can sort in order of
all fathers records, generationally then all mothers records generationally, then all shared records genrationally.

*NB: in the output, where there is no partnership for an individual, they are not displayed, but the entry is in the famOBJ record.

I hope this has made sense, and/or has sparked some brilliant ideas.

Code: Select all

-- _prf = require('_prf')
-- _prf.start('call')
-- require('_STD_HDR')
-- require('_STD_SYS')

local ipairs = ipairs
-- local pairs = pairs
local fhNewItemPtr = fhNewItemPtr
local fhGetItemPtr = fhGetItemPtr
local fhGetItemText = fhGetItemText
local fhGetValueAsLink = fhGetValueAsLink
local fhGetRecordId = fhGetRecordId
local fhNewDate = fhNewDate
local fhGetValueAsDate = fhGetValueAsDate
local fhGetTag = fhGetTag
local fhCallBuiltInFunction = fhCallBuiltInFunction
local fhMessageBox = fhMessageBox
local fhPromptUserForRecordSel = fhPromptUserForRecordSel

local famOBJ = {}
local SEQ = 0
local seed = {} -- selected root table
local uhash = {} -- setll unique hash for fam order
local rootfam = {}
local _ptyp  -- pointer type
local _ptag  -- pointer tag for linking

-- (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

function que:reset()
  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()
-- compiling done, discard
setmetatable(que, nil)
que = nil

-- str sltROOT variables
local WS_CANCEL = false
local WS_Cancel = 'Cancel'
local WS_ENTER  = true
local WS_OK     = 'OK'
local _slt = {}
-- end sltROOT variables

local function sltROOT()

  _slt['_root'] =
  {fn_key = '', _YROOT = '',  _YFATHER = '', _YMOTHER = '', _YFAM = '', _CROOT = '',  _CFATHER = '', _CMOTHER = '', _CFAM = ''}

  local WS_RC

  local function mat_spc_root()

    local ptrFAM = fhGetItemPtr(_YROOT, '~.FAMC')
    local lnkFAM = fhGetValueAsLink(ptrFAM)
    if ptrFAM:IsNotNull() then
      local lnkHUSB = fhGetItemPtr(lnkFAM, '~.HUSB[1]>')
      local ptrHUSB = fhGetItemPtr(lnkFAM, '~.HUSB[2]>')
      local lnkWIFE = fhGetItemPtr(lnkFAM, '~.WIFE[1]>')
      local ptrWIFE = fhGetItemPtr(lnkFAM, '~.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

      _CROOT = fhGetRecordId(_YROOT)
      _YFATHER = lnkHUSB
      _CFATHER = fhGetRecordId(lnkHUSB)
      _YMOTHER = lnkWIFE
      _CMOTHER = fhGetRecordId(lnkWIFE)
      _YFAM = lnkFAM
      _CFAM = fhGetRecordId(lnkFAM)

      _slt['_root'].fn_key = WS_ENTER
      _slt['_root']._YROOT = _YROOT
      _slt['_root']._YFATHER = lnkHUSB
      _slt['_root']._YMOTHER = lnkWIFE
      _slt['_root']._YFAM = lnkFAM
      _slt['_root']._CROOT = _CROOT
      _slt['_root']._CFATHER = _CFATHER
      _slt['_root']._CMOTHER = _CMOTHER
      _slt['_root']._CFAM = _CFAM
    end
  end -- fn mat_spc_root

  -- if cancel key is pressed and there is a file root, ask to use it.
  local function mat_file_root()
    local txt
    _YROOT = fhCallBuiltInFunction('FileRoot')
    if _YROOT:IsNull()then
      txt = 'File Root not set: plug-in requires a Root'
    else
      local fileroot = fhGetItemText(_YROOT, '~.NAME')
      txt = ('Use File Root: %s'):format(fileroot)
    end

    WS_RC = fhMessageBox(txt, 'MB_OKCANCEL')
    if WS_RC == WS_OK then
      if _YROOT:IsNotNull()then
        mat_spc_root()
      else
        sltROOT()
      end
    elseif WS_RC == WS_Cancel then
      _slt['_root'].fn_key = WS_CANCEL
    end
  end -- fn mat_file_root

  -- *ENTRY()
  local _ = fhPromptUserForRecordSel('INDI', 1)
  if #_ == 0 then
    mat_file_root()
  elseif #_ == 1 then
    _YROOT = _[1]
    mat_spc_root()
  end
  return _slt['_root']
end -- fn sltROOT

-- trim string internal and ends
local function trim(str)
  str = tostring(str) or ''
  if str == '' then return str end
  return (str:gsub('^%s+', ''):gsub('%s+', ' '):gsub('%s+$', ''))
end -- fn trim

-- trim string ends
local function trime(str)
  str = tostring(str) or ''
  if str == '' then return str end
  return (str:gsub('^%s+', ''):gsub(' *$', ''))
end -- fn trime

-- materialize combined name
local function matNAM(iptr)

  local function rtvElemCount(varptr)
    -- Count instances of varptr TAG
    local eptr = varptr:Clone()

    local elem = 0
    while eptr:IsNotNull() do
      elem = elem + 1
      eptr:MoveNext('SAME_TAG')
    end
    return elem
  end -- fn rtvElemCount

  -- ENTRYPOINT matNAM()
  _ptyp  = type(iptr)
  if _ptyp  == 'userdata' then
    _ptag = fhGetTag(iptr)
    if _ptag ~= 'INDI' then
      error(('_STD_MAT.matNAM: INDI ptr unresolved: %s TAG: %s'):format(tostring(iptr) or '*null', _ptag or '?'))
    end
  elseif _ptyp == 'number' then
    local xptr = fhNewItemPtr()
    xptr:MoveToRecordById('INDI', iptr)
    iptr = xptr:Clone()
  else
    error(('_STD_MAT.matNAM: INDI ptr unresolved: %s TYPE: %s'):format(iptr or '*null', _ptyp or '?'))
  end

  local bNAM   = ''
  local nSFX = trim(fhGetItemText(iptr, '~.NAME.NSFX'))
  local sNAM = trim(fhGetItemText(iptr, '~.NAME:SURNAME'))
  local gNAM = fhGetItemText(iptr, '~.NAME:GIVEN_ALL')

  local ptrWRK = fhNewItemPtr()
  ptrWRK = fhGetItemPtr(iptr, '~.NAME')
  local nc = rtvElemCount(ptrWRK)
  if nc > 1 then
    sNAM = fhGetItemText(iptr, ('~.NAME[%i]:SURNAME'):format(nc))
    bNAM = (' (%s)'):format(trim(fhGetItemText(iptr, '~.NAME:SURNAME')))
  end
  if nSFX:match('Sr') then nSFX = ('  %s'):format(nSFX) end

  return trime(('%s%s, %s %s'):format(sNAM, bNAM, gNAM, nSFX))
end --fn matNAM

local function rtv_FAM_pool(fptr)
  rtvptr = fhGetItemPtr(fptr, '~.HUSB>')
  if rtvptr:IsNotNull() then return fhCallBuiltInFunction('RelationPool', rtvptr) end
  rtvptr = fhGetItemPtr(fptr, '~.WIFE>')
  if rtvptr:IsNotNull() then return fhCallBuiltInFunction('RelationPool', rtvptr) end
  rtvptr = fhGetItemPtr(fptr, '.CHIL>')
  if rtvptr:IsNotNull() then return fhCallBuiltInFunction('RelationPool', rtvptr) end
  return
end

local function rtv_FAM_marr(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
    local xptr = fhNewItemPtr()
    xptr:MoveToRecordById('FAM', fptr)
    fptr = xptr:Clone()
  end

  -- marriage date
  local MDAT = ''
  local mdat = ''
  local mdptr = fhNewItemPtr()
  mdptr = fhGetItemPtr(fptr, '~.MARR.DATE:COMPACT')
  local fmdat = fhNewDate()
  if mdptr:IsNotNull() then
    -- formatted marriage date
    fmdat = fhGetValueAsDate(mdptr)
    MDAT = ((fmdat:GetDisplayText('COMPACT')) or '')
    mdat = ((fmdat:GetValueAsText()) or '')
  end

  -- divorce date
  local DDAT = ''
  local ddat = ''
  local ddptr = fhNewItemPtr()
  ddptr = fhGetItemPtr(fptr, '~.DIV.DATE:COMPACT')
  local dmdat = fhNewDate()
  if ddptr:IsNotNull() then
    -- formatted divorce date
    dmdat = fhGetValueAsDate(ddptr)
    DDAT = ((dmdat:GetDisplayText('COMPACT')) or '')
    ddat = ((dmdat:GetValueAsText()) or '')
  end

  return
  {
    fID   = fhGetRecordId(fptr),
    MDAT  = (MDAT or ''),
    DDAT  = (DDAT or ''),
  }
end -- fn rtv_FAM_marr

-- reorganize _tbl (treetops table)
local function rgz_anc_seeds()
  -- sort
  -- 1. GEN: generation oldest first
  -- 2. PTG: fathers line(2) before mothers line(3) if all else equal
  -- 2. SEQ: males(2) before females(3)

  table.sort(seed,
    function(a, b)
      if a.PTG == b.PTG then
        if a.GEN == b.GEN then
          return a.SEQ < b.SEQ
        end
        return a.GEN < b.GEN
      end
      return a.PTG < b.PTG
    end
  )

  -- get one each greatest treetop father and greatest treetop mother (HUSB: PTG = 2, WIFE: PTG = 3)
  local hash = {} -- hash table to produce unique families
  local _tbl = seed  -- temporary table holder
  seed = {}
  for _, rcd in pairs(_tbl) do
    if not hash[rcd.PTG] then
      seed[#seed + 1] = rcd
      hash[rcd.PTG] = true
    end
  end

  _tbl = {}
  uhash = {}
  hash = nil
  return
end -- fn rgz_anc_seeds

-- _tbl: retrieve the tops of the FAM chain (no FAMC)
local function rtv_anc_seeds(rcd, tag)

  local _tbl = {}   -- unique treetops processing ancestors table
  -- retrieve ancestor chain
  local function rtv_anc_chain(rcd, tag)

    -- ENTRYPOINT fn rtv_anc_chain()
    local fptr = fhNewItemPtr()
    local xptr = fhNewItemPtr()
    xptr:MoveToRecordById('FAM', rcd.fID)
    fptr = xptr:Clone()
    local fID = fhGetRecordId(fptr)

    -- start exception handling
    -- same sex male
    local lnkHUSB = fhNewItemPtr()
    lnkHUSB = fhGetItemPtr(fptr, '~.HUSB[1]>')
    local ptrHUSB = fhNewItemPtr()
    ptrHUSB = fhGetItemPtr(fptr, '~.HUSB[2]>')
    -- same sex female
    local lnkWIFE = fhNewItemPtr()
    lnkWIFE = fhGetItemPtr(fptr, '~.WIFE[1]>')
    local ptrWIFE = fhNewItemPtr()
    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

    -- _tbl is the table of all ancestors of selected root
    -- there are cases where the INDI ID and/or FAM ID  can be multiples
    if lnkHUSB:IsNotNull() then
      if lnkHUSB:IsSame(_YFATHER) then rcd.PTG = 2 end
      _tbl[#_tbl + 1] = {iID = fhGetRecordId(lnkHUSB), fID = fID, GEN = rcd.GEN, PTG = rcd.PTG, SEQ = '2'}
      local que = _tbl[#_tbl]
      que.fID = fhGetRecordId(fhGetValueAsLink(fhGetItemPtr(lnkHUSB, tag)))
      que.GEN = que.GEN - 1
      rtv_anc_chain(que, tag)
    end

    if lnkWIFE:IsNotNull() then
      if lnkWIFE:IsSame(_YMOTHER) then rcd.PTG = 3 end
      _tbl[#_tbl + 1] = {iID = fhGetRecordId(lnkWIFE), fID = fID, GEN = rcd.GEN, PTG = rcd.PTG,  SEQ = '3'}
      local que = _tbl[#_tbl]
      que.fID = fhGetRecordId(fhGetValueAsLink(fhGetItemPtr(lnkWIFE, tag)))
      que.GEN = que.GEN - 1
      rtv_anc_chain(que, tag)
    end
  end -- fn rtv_anc_chain

  -- function ENTRYPOINT rtv_anc_seeds
  -- from a family pointer get HUSB and WIFE recursively
  -- no need to get CHIL records since CHIL will be a: HUSB, WIFE, or dead end.
  -- start chain: from this FAM tree all FAMC
  rtv_anc_chain(rcd, tag)

  -- sort and sift the table resulting in the root's: father's treetop and mother's treetop
  seed = _tbl
  _tbl = {}
  rgz_anc_seeds()

end -- fn rtv_anc_seeds


-- enqueues unique FAMS and FAMC from rtv_FAM_tbl
local function enQtbl(ftbl)
  for _, rcd in ipairs(ftbl) do
    if not uhash[rcd.fID] then
      QFAM:enQ(rcd)
      uhash[rcd.fID] = true
    end
  end
end -- fn enQtbl

-- retrieves a table containing INDI FAMS and FAMC records
local function rtv_FAM_tbl(rcd, tag)

  local xptr = fhNewItemPtr()
  xptr:MoveToRecordById('INDI', rcd.iID)
  local iptr = xptr:Clone()

  local tagtbl = {}
  if tag then
    tagtbl = {[1] = tag,}
  else
    tagtbl = {[1] = '~.FAMC', [2] = '~.FAMS'}
  end

  local itbl = {}
  local lnkFAM = fhNewItemPtr()
  for k, _ in ipairs(tagtbl) do
    local ptrFAM = fhGetItemPtr(iptr, tagtbl[k])
    while ptrFAM:IsNotNull() do
      lnkFAM = fhGetValueAsLink(ptrFAM)
      local iID  = fhGetRecordId(iptr)
      local fID  = fhGetRecordId(lnkFAM)
      itbl[#itbl + 1] = {iID = iID, fID = fID, GEN = rcd.GEN, PTG = rcd.PTG}
      ptrFAM: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 rcd = QFAM:deQ()
    local xptr = fhNewItemPtr()
    xptr:MoveToRecordById('FAM', rcd.fID)
    local 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

    local HUSB = ''
    local WIFE = ''
    local HNAM = ''
    local WNAM = ''
    local cnn = ''
    local _cs

    -- and/or lnkHUSB:IsSame(_YFATHER) and lnkWIFE:IsSame(_YMOTHER)
    if rcd.fID == _CFAM then
      SEQ = 0
      rcd.PTG = 4
    end
    if lnkWIFE:IsSame(_YMOTHER) then
      SEQ = 0
      rcd.PTG = 3
    elseif lnkHUSB:IsSame(_YFATHER) then
      SEQ = 0
      rcd.PTG = 2
    end

    if lnkHUSB:IsNotNull() then
      HNAM  = matNAM(lnkHUSB)
      HUSB = fhGetRecordId(lnkHUSB)
      local que = {iID = HUSB, fID = rcd.fID, GEN = rcd.GEN, PTG = rcd.PTG}
      enQtbl(rtv_FAM_tbl(que)) --** (rcd, tag))
    end

    if lnkWIFE:IsNotNull() then
      WNAM  = matNAM(lnkWIFE)
      WIFE = fhGetRecordId(lnkWIFE)
      local que = {iID = WIFE, fID = rcd.fID, GEN = rcd.GEN, PTG = rcd.PTG}
      enQtbl(rtv_FAM_tbl(que)) --** (rcd, tag))
    end

    if (HNAM > '' and WNAM > '') then cnn = ' and ' end
    local FAM = trim(('%s%s%s'):format(HNAM, cnn, WNAM))
    _cs = rtv_FAM_marr(ptrFAM)

    famOBJ[#famOBJ + 1] =
    {
      fID = _cs.fID, -- FAM rcd nbr
      PTG = rcd.PTG, -- PTG
      GEN = rcd.GEN, -- generation (not correct)
      SEQ = SEQ, -- sequence
      FAM = FAM, -- text
      MDAT = _cs.MDAT, -- marriage date
      DDAT = _cs.DDAT, -- divorce date
      HUSB = HUSB, -- husband name
      WIFE = WIFE, -- wife name
      CHIL = {}, -- child array built immediately following
    }

    local lnkCHIL = fhNewItemPtr()
    local ptrCHIL = fhNewItemPtr()
    local cgen = famOBJ[#famOBJ].GEN + 1
    lnkCHIL = fhGetItemPtr(ptrFAM, '~.CHIL')
    while lnkCHIL:IsNotNull() do
      ptrCHIL = fhGetValueAsLink(lnkCHIL)
      local chil = fhGetRecordId(ptrCHIL)
      -- object = famOBJ[#famOBJ].CHIL
      -- local instance = #famOBJ[#famOBJ].CHIL
      -- object[instance + 1] = chil
      famOBJ[#famOBJ].CHIL[#famOBJ[#famOBJ].CHIL + 1] = chil
      --     if fhGetItemPtr(ptrCHIL, '~.FAMS'):IsNotNull() then
      rcd = {iID = chil, fID = 0, GEN = cgen, PTG = rcd.PTG}
      enQtbl(rtv_FAM_tbl(rcd)) --** (rcd, tag))
      --     end
      lnkCHIL:MoveNext('SAME_TAG')
    end
    SEQ = SEQ + 1
  end
  return
end

local function list_FAM()
  -- starter record for ancestors recursion
  rootfam = {iID = fhGetRecordId(_YROOT), fID = fhGetRecordId(_YFAM), GEN = 0, PTG = 4}
  local tag = '~.FAMC'
  seed = rtv_FAM_tbl(rootfam, tag)
  for _, rcd in ipairs(seed) do
    rtv_anc_seeds(rcd, tag)
  end

  -- seed has 1 treetop for father and 1 treetop for mother
  -- retrieve each treetops descendants by family, thus:
  -- get their FAMC and FAMS if the FAM(x) is not in the index then:
  -- add that FAM(x) to the unique index (uhash).
  for _, rcd in ipairs(seed) do
    enQtbl(rtv_FAM_tbl(rcd))
    prc_Q()
  end

  -- read all FAM records and find 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 this will be improved once the rest of the ordering is correct.
  seed = {}
  SEQ = 0
  local fptr = fhNewItemPtr()
  fptr:MoveToFirstRecord('FAM')
  while fptr:IsNotNull() do
    local fID = fhGetRecordId(fptr)
    if not uhash[fID] then
      seed[#seed + 1] = {fID = fID, GEN = 5, PTG = 5, SEQ = rtv_FAM_pool(fptr)}
--      SEQ = SEQ + 1
      uhash[fID] = true
    end
    fptr:MoveNext('SAME_TAG')
  end

  for _, rcd in ipairs(seed) do
    QFAM:enQ(rcd)
    prc_Q()
  end
  return
end -- fn get_fam

-- MAIN()
-- *ENTRY()
function Order_FAM()
  local _ro = sltROOT()
  if _ro.fn_key == WS_CANCEL then return end
  list_FAM()

  --[[
 table.sort(famOBJ,
    function(a, b)

      if a.PTG == b.PTG then
        if a.GEN == b.GEN then
          return a.SEQ < b.SEQ
        end
        return a.GEN < b.GEN
      end
      return a.PTG < b.PTG
    end
  )
  ]]

  return
end

Order_FAM()
-- return famOBJ
-- end of module

-- _prf.stop()
-- _prf.report()

local tblK = {}
local tblfID = {}
local tblPTG = {}
local tblGEN = {}
local tblSEQ = {}
local tblFAM = {}
for k, _ in ipairs(famOBJ) do
  local t = famOBJ[k]
  local fid = t.fID
  local ptg = t.PTG
  local gen = t.GEN
  local seq = t.SEQ
  local fam = t.FAM
  table.insert(tblK, k)
  table.insert(tblfID, fid)
  table.insert(tblPTG, ptg)
  table.insert(tblGEN, gen)
  table.insert(tblSEQ, seq)
  table.insert(tblFAM, fam)
end
fhOutputResultSetColumn('ord', 'integer', tblK, #tblK, 48, 'align_right')
fhOutputResultSetColumn('fID', 'integer', tblfID, #tblfID, 36, 'align_right')
fhOutputResultSetColumn('ptg', 'integer', tblPTG, #tblPTG, 36, 'align_right', 1)
fhOutputResultSetColumn('gen', 'integer', tblGEN, #tblGEN, 36, 'align_right', 2)
fhOutputResultSetColumn('seq', 'integer', tblSEQ, #tblSEQ, 36, 'align_right', 3)
fhOutputResultSetColumn('FAM', 'text', tblFAM, #tblFAM, 320)

return
FH V.6.2.7 Win 10 64 bit

Post Reply