# hier.icn: Taxonomic hierarchy object for Txny object (q.v.)
#--

$define  HIER_REVISION      "$Revision: 1.9 $"
$define  HIER_DATE          "$Date: 1996/10/31 06:42:47 $"

#================================================================
# Class Hier: Each instance describes an ordered set of taxonomic
# rankings used to classify organisms.  For example, all birds
# might be classified using the set { class, order, family,
# genus, species}.  A Hier object describes which ranks are of
# interest and their order from largest to smallest category.
#----------------------------------------------------------------
# EXPORTED METHODS
#----------------------------------------------------------------
# Hier_New ( ranksFileName, txny )
#   [ if txny is a Txny object ->
#       if ranksFileName names a valid ranks file ->
#         return a new Hier object representing that file and
#         whose .txny attribute is (txny)
#       else ->
#         txny.log  ||:=  scan error(s) from ranksFileName
#         fail
#   ]
#--
# Hier_Txny ( self )
#   [ returns the Txny object associated with self
#   ]
#--
# Hier_Rank_Code_Lookup ( self, rankCode )
#   [ if rankCode is a string ->
#       if rankCode matches that of one of self's contained Rank objects ->
#         return that Rank object
#       else -> fail
#   ]
#--
# Hier_Gen_Ranks ( self )
#   [ generates the contained Rank objects in self in ascending
#     order by depth
#   ]
#--
# Hier_N_Ranks ( self )
#   [ returns the number of contained Rank objects as an integer
#   ]
#--
# Hier_Nth_Rank ( self, n )
#   [ if self has a Rank object of depth n ->
#       return that Rank object
#   | else -> fail
#   ]
#--
# Hier_Genus_Rank ( self )
#   [ if self includes a genus rank ->
#       return the corresponding Rank object
#   | else -> fail
#   ]
#--
# Hier_Subgenus_Rank ( self )
#   [ if self includes a subgenus rank ->
#       return the corresponding Rank object
#   | else -> fail
#   ]
#--
# Hier_Species_Rank ( self )
#   [ if self includes a species rank ->
#       return the corresponding Rank object
#   | else -> fail
#   ]
#--
# Hier_Form_Rank ( self )
#   [ if self includes a form (sub-specific) rank ->
#       return the corresponding Rank object
#   | else -> fail
#   ]
#--
# Hier_Tx_Key_Len ( self )
#   [ returns the length of the taxonomic keys that will be used
#     for this set of ranks
#   ]
#--
# Hier_Rank_Code_Len ( )
#   [ returns the length of a rank code
#   ]
#--
# Hier_Can_Parent_Have_Child ( self, parent, child )
#   [ if parent and child are Rank objects in self ->
#       if (parent's depth) < (child's depth) and the ranks
#       between those depths (if any) are all optional ->
#         return &null
#       else ->
#         fail
#   ]
#--


# - - -   State   - - -

  record hierTag (
    txny,               # Back pointer to containing Txny object
    rankCodeMap,        # Table: maps rankCode |-> Rank object
    ranks,              # List of Rank objects, ascending depth
    txKeyLen,           # Sum of key lengths from contained Ranks
    scan,               # Local field, used only in Hier_New()
    log )               # Log object from self.txny


# - - -   Invariants   - - -

#--
# .txny == a Txny object
#--
# .rankCodeMap ==
#       a table, with a &null default value, such that
#       for every contained rank R,
#       self.rankCodeMap[Rank_Code(R)] === R
#--
# .ranks ==
#       a list of the contained Rank objects such that
#       for every contained rank R,
#       self.ranks[Rank_Depth(R)] === R
#--
# .txKeyLen ==
#       the sum, for every contained rank R, of all Rank_Key_Len(R)
#--
# .log == self.txny's log
#--


# - - -   Defines   - - -

#--
# Certain rank codes are hardwired here according to the
# external specification.
#--

$define  RANK_CODE_LEN          2
$define  GENUS_RANK_CODE        "g "
$define  SUBGENUS_RANK_CODE     "-g"
$define  SPECIES_RANK_CODE      "s "
$define  FORM_RANK_CODE         "x "


# - - -   H i e r _ T x n y   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Txny ( self )
  return self.txny;
end


# - - -   H i e r _ R a n k _ C o d e _ L o o k u p   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Rank_Code_Lookup ( self, rankCode )
  return  \ self.rankCodeMap[rankCode];
end


# - - -   H i e r _ G e n _ R a n k s   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Gen_Ranks ( self )
  every suspend ( ! self.ranks );
end


# - - -   H i e r _ N _ R a n k s   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_N_Ranks ( self )
  return  * self.ranks;
end

# - - -   H i e r _ N t h _ R a n k   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Nth_Rank ( self, n )
  return  self.ranks[n];    # NB: fails if n is out of range
end


# - - -   H i e r _ G e n u s _ R a n k   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Genus_Rank ( self )
  return  Hier_Rank_Code_Lookup ( self, GENUS_RANK_CODE );
end


# - - -   H i e r _ S u b g e n u s _ R a n k   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Subgenus_Rank ( self )
  return  Hier_Rank_Code_Lookup ( self, SUBGENUS_RANK_CODE );
end


# - - -   H i e r _ S p e c i e s _ R a n k   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Species_Rank ( self )
  return  Hier_Rank_Code_Lookup ( self, SPECIES_RANK_CODE );
end


# - - -   H i e r _ F o r m _ R a n k   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Form_Rank ( self )
  return  Hier_Rank_Code_Lookup ( self, FORM_RANK_CODE );
end


# - - -   H i e r _ T x _ K e y _ L e n   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Tx_Key_Len ( self )
  return self.txKeyLen;
end


# - - -   H i e r _ R a n k _ C o d e _ L e n   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_Rank_Code_Len ( )
  return RANK_CODE_LEN;
end


# - - -   H i e r _ C a n _ P a r e n t _ H a v e _ C h i l d   - - -

#-- 1996-07-16: verified, A. Stavely

procedure Hier_Can_Parent_Have_Child ( self, parent, child )
  local deepx       # Walks the depths from parent to child (poetic, huh?)

  #-- 1 --
  #-[ if (parent's depth) < (child's depth) -> I
  # | else -> fail
  #-]
  if  Rank_Depth ( parent ) >= Rank_Depth ( child )  then
    fail;

  #-- 2 --
  #-[ if there are any non-optional ranks between parent and child ->
  #     fail
  # | else -> I
  #-]
  every  deepx := ( Rank_Depth ( parent ) + 1 ) to
                  ( Rank_Depth ( child  ) - 1 )  do
  { #-- 2 loop --
    #-[ if rank (deepx) is optional -> I
    # | else -> fail
    #-]
    if  not Rank_Is_Optional ( Hier_Nth_Rank ( self, deepx ) )  then
      fail;
  } #-- 2 loop --

  #-- 3 --
  return &null;
end # --- Hier_Can_Parent_Have_Child ---


# - - -   H i e r _ N e w   - - -

#-- 1996-07-12: verified, A. Stavely

procedure Hier_New ( ranksFileName, txny )
  local self

  #-- 1 --
  #-[ if txny is a Txny object ->
  #     self  :=  a new Hier object with its fields set from the
  #               corresponding arguments, plus:
  #                 .rankCodeMap  :=  <anything>
  #                 .ranks        :=  <anything>
  #                 .txKeyLen     :=  <anything>
  #                 .scan         :=  <anything>
  #                 .log          :=  txny's log
  #-]
  self                :=  hierTag ( );
  self.txny           :=  txny;
  self.log            :=  Txny_Log ( txny );

  #-- 2 --
  #-[ if ranksFileName names a valid ranks file ->
  #     self  :=  self with .ranksCodeMap, .ranks, and .txKeyLen
  #               set from that file
  # | else ->
  #     self.log  ||:=  scan error(s) from that file
  #     fail
  #-]
  if  not Hier_Read ( self, ranksFileName )  then
    fail;

  #-- 3 --
  return self;
end # --- Hier_New ---


# - - -   H i e r _ R e a d   - - -

#-- 1996-07-16: verified, A. Stavely

#   [ if ranksFileName names a valid ranks file ->
#       self  :=  self with .rankCodeMap, .ranks, and .txKeyLen
#                 set from that file
#       return &null
#   | else ->
#       self.rankCodeMap  :=   <anything>
#       self.ranks        :=   <anything>
#       self.txKeyLen     :=   <anything>
#       self.log         ||:=  scan error(s) from that file
#       fail
#   ]

procedure Hier_Read ( self, ranksFileName )
  local errCount

  #-- 1 --
  #-[ errCount  :=  error count from self.log
  #-]
  errCount  :=  Log_Error_Count ( self.log );

  #-- 2 --
  #-[ if ranksFileName can be opened for reading ->
  #     self.scan  :=  a Scan object with filename=ranksFileName,
  #                    log=self.log, positioned at start of file
  # | else ->
  #     self.log   :=  error, can't open (ranksFileName)
  #     fail
  #-]
  if  not ( self.scan := Scan_Open ( ranksFileName, self.log ) )  then
    return Log_Error ( self.log,
      "Can't open file `", ranksFileName, "' for reading." );

  #-- 3 --
  #-[ if self.scan points to the start of a valid ranks file ->
  #     self  :=  self with .rankCodeMap, .ranks, and .txKeyLen set
  #               set from self.scan
  # | else ->
  #     self.rankCodeMap  :=    <anything>
  #     self.ranks        :=    <anything>
  #     self.txKeyLen     :=    <anything>
  #     self.scan         ||:=  scan errors from self.scan
  #-]
  Hier_Read_Loop ( self );
  Scan_Close ( self.scan );

  #-- 4 --
  #-[ if (the error count from self.log) > errCount ->
  #     fail
  # | else ->
  #     return &null
  #-]
  if  Log_Error_Count ( self.log ) > errCount  then
    fail
  else
    return &null;
end # -- Hier_Read ---


# - - -   H i e r _ R e a d _ L o o p   - - -

#-- 1996-07-16: verified, A. Stavely

#   [ if self.scan points to the start of a valid ranks file ->
#       self  :=  self with .rankCodeMap, .ranks, and .txKeyLen set
#                 set from self.scan
#   | else ->
#       self.rankCodeMap  :=    <anything>
#       self.ranks        :=    <anything>
#       self.txKeyLen     :=    <anything>
#       self.log          ||:=  scan errors from self.scan
#   ]

procedure Hier_Read_Loop ( self )
  #-- 1 --
  #-[ self.rankCodeMap  :=  an empty table with a &null default value
  #   self.ranks        :=  an empty list
  #   self.txKeyLen     :=  0
  #-]
  self.rankCodeMap    :=  table ( );
  self.ranks          :=  [];
  self.txKeyLen       :=  0;

  #-- 2 --
  #-[ self.rankCodeMap  +:=   entries mapping rank codes |-> Rank objects
  #                           for valid lines from self.scan
  #   self.ranks        ||:=  set of Rank objects for valid lines
  #                           from self.scan
  #   self.txKeyLen     +:=   sum of key lengths from valid lines
  #                           from self.scan
  #   self.scan         ||:=  errors from self, if any
  #-]
  every  Scan_Gen_Lines ( self.scan )  do
  { #-- 2 body --
    #-[ if self.scan's current line is a valid ranks line ->
    #     self.rankCodeMap  +:=   an entry mapping the rank code |-> a Rank
    #                             object made from that line
    #     self.ranks        ||:=  a new Rank object made from that line
    #     self.txKeyLen     +:=   the key length from that line
    # | else ->
    #     self.scan  ||:=  error message(s) from that line
    #-]
    Hier_Read_Line ( self );
  } #-- 2 body --

  #-- 3 --
  #-[ self.txKeyLen  -:=  the key length from self.ranks[1]
  #-]
  #-- Note: this is necessary because the root rank contributes
  #   no length to the txKey, and the root rank's txKey is "".
  #--
  self.txKeyLen  -:=  Rank_Key_Len ( self.ranks[1] );
end # --- Hier_Read_Loop ---


# - - -   H i e r _ R e a d _ L i n e   - - -

#-- 1996-07-16: verified, A. Stavely

#   [ if self.scan's current line is a valid ranks line ->
#       self.rankCodeMap  +:=   an entry mapping the rank code |-> a Rank
#                               object made from that line
#       self.ranks        ||:=  a new Rank object made from that line
#       self.txKeyLen     +:=   the key length from that line
#   | else ->
#       self.scan  ||:=  error message(s) from that line
#   ]

procedure Hier_Read_Line ( self )
  local rankCode    # Contents of rankCode field
  local optional    # 1 if optional field is true, else &null
  local keyLen      # Key length as an integer
  local name        # Rank name as a string
  local rank        # Rank object to be added

  #-- 1 --
  #-[ if self.scan's line starts with at least RANK_CODE_LEN characters
  #   and those characters do not duplicate any of the rank codes in
  #   self.rankCodeMap ->
  #     rankCode   :=  those characters
  #     self.scan  :=  self.scan advanced by RANK_CODE_LEN characters
  # | else ->
  #     self.scan  ||:=  error, expecting rank code
  #     fail
  #-]
  if  not ( rankCode := move ( RANK_CODE_LEN ) )  then
    return Scan_Error ( self.scan,
      "Expecting a ", RANK_CODE_LEN, "-letter rank code." );

  if  \ self.rankCodeMap[rankCode]  then
    return Scan_Error ( self.scan,
      "This rank code duplicates the one for ",
      Rank_Show ( self.rankCodeMap[rankCode] ) );

  #-- 2 --
  #-[ if self.scan's line starts with a valid optional-indicator ->
  #     optional   :=  1 for optional, &null otherwise
  #     self.scan  :=  self.scan advanced by one
  # | else ->
  #     self.scan  ||:=  error, expecting optional-indicator field
  #     fail
  #-]
  if  = " "  then
    optional  :=  &null
  else if  = "?"  then
    optional  :=  1
  else
    return Scan_Error ( self.scan,
      "Expecting a blank, or '?' if this rank is optional." );

  #-- 3 --
  #-[ if self.scan's line starts with a digit ->
  #     keyLen     :=  that digit as an integer
  #     self.scan  :=  self.scan advanced one
  # | else ->
  #     self.scan  ||:=  error, expecting a one-digit key length
  #     fail
  #-]
  if  not ( keyLen := integer ( tab ( any ( &digits ) ) ) )  then
  { Scan_Error ( self.scan,
      "Expecting a key length from 1 to 9.  For example, if this rank" );
    Scan_Message ( self.scan,
      "never has more than 9 taxa in it, use 1; if no more than 99," );
    Scan_Message ( self.scan,
      "use 2; if it might have up to 999 taxa in it, use 3; and so on." );
    fail;
  }

  #-- 4 --
  #-[ if self.scan starts with a letter ->
  #     name       :=  remainder of this line, trimmed
  #     self.scan  :=  self.scan advanced to end of line
  # | else ->
  #     self.scan  ||:=  scan error, expecting rank name starting w/letter
  #     fail
  #-]
  if  not any ( &letters )  then
    return Scan_Error ( self.scan,
      "Expecting the first letter of the rank's name here." );

  name  :=  trim ( tab ( 0 ) );
  
  #-- 6 --
  #-[ self  :=  self with a new Rank object with rankCode=(rankCode),
  #             optional=(optional), keyLen=(keyLen), name=(name), and
  #             depth=(1 + number of ranks in self)
  #-]
  rank  :=  Rank_New ( rankCode, optional, keyLen, name, 1 + * self.ranks );
  put ( self.ranks, rank );
  self.rankCodeMap[rankCode]  :=   rank;
  self.txKeyLen               +:=  keyLen;

  #-- 7 --
  return &null;
end # --- Hier_Read_Line ---