# abbind.icn:  AbBind object for AbTab (q.v.)
#--

$define  AB_BIND_REVISION   "$Revision: 1.9 $"
$define  AB_BIND_DATE       "$Date: 1996/11/10 23:33:51 $"

#================================================================
# Class AbBind:  Each instance represents one "binding" of an
# abbreviation, that is, one use of an abbreviation in a particular
# way.
#   See the extensive comments in the AbSym object about the
# relationship between AbSym objects and their bindings.
#   The AbBind object is one of the rare cases in which the author
# has actually needed polymorphism.  Later on in this file we
# describe several different types of bindings; each of this is
# physically represented by an AbBind object, but each is a
# different structural variant.  The .var field holds the
# information that differs within each variant type.
#   There are several methods that must be provided by each of
# these variants:
#     - The "show" method returns a string that describes
#       the variant in textual form, for use in error messages
#       and debug displays.
#     - The "combine" method determines whether an existing
#       binding can be combined harmoniously with a new binding
#       under the same abbreviation.  Currently, there is only
#       one case that succeeds: two CollBind bindings can be
#       combined, but all other combinations fail.
#     - The "lookup" method determines whether the binding
#       refers unambiguously to a specific Taxon or not.
#     - The "eng" method returns the English name on which
#       this binding is based, if any, or fails otherwise.
#     - The "class" method returns a string that is constant
#       for a given binding type.  This is necessary so that
#       "combine" methods can recognize the different variants.
#----------------------------------------------------------------
# EXPORTED METHODS
#----------------------------------------------------------------
# Ab_Bind_New ( abbr, var, show, combine, lookup, class )
#   [ if arguments satisfy the invariants of the corresponding
#     fields ->
#       return a new AbBind object with those fields
#   ]
#--
# Ab_Bind_Abbr ( self )         [ return self.abbr ]
#--
# Ab_Bind_Var ( self )          [ return self.var ]
#--
# Ab_Bind_Show ( self )         [ return self.show(self) ]
#--
# Ab_Bind_Combine ( self, bind2 )
#   [ if bind2 is an AbBind ->
#       return self.combine ( self, bind2 )  {which may fail}
#   ]
#--
# Ab_Bind_Lookup ( self )       [ return self.lookup(self) ]
#--
# Ab_Bind_Eng ( self            [ return self.eng(self) ]
#--
# Ab_Bind_Class ( self )        [ return self.class ]
#--


# - - -   State   - - -

  record abBindTag (
    abbr,       # The Abbr object for which this is a binding
    var,        # An object whose type depends on which variant
    show,       # The show() method
    combine,    # The combine() method
    lookup,     # The lookup() method
    eng,        # The eng() method
    class )     # The variant type, as a string


# - - -   Invariants   - - -

#--
# .abbr == the abbreviation for which this is a binding, as a string 
#--
# .show ==
#     a function with calling sequence
#       show ( self )
#     and intended function
#       [ returns a string describing self
#       ]
#--
# .combine ==
#     a function with calling sequence
#       combine ( self, b2 )
#     and intended function
#       [ if self and b2 are AbBind objects ->
#           if self and b2 can be combined ->
#             return a new AbBind combining self and b2
#           else -> fail
#       ]
#--
# .lookup ==
#     a function with calling sequence
#       lookup ( self )
#     and intended function
#       [ if self is unambiguously associated with a specific
#         Taxon object ->
#           return that Taxon object
#       | else -> fail
#       ]
#--
# .eng ==
#     a function with calling sequence
#       eng ( self )
#     and intended function
#       [ if self describes a binding based on an English name ->
#           return that name as a string
#         else -> fail
#       ]
#--
# .class == a string that is the same for all bindings of the same type
#--


# - - -   Defines   - - -

#--
# These defines are the .class values for the variants:
#--

$define  STD_BIND_CLASS     "StdBind"       # Standard binding
$define  COLL_BIND_CLASS    "CollBind"      # Collision binding
$define  HT_BIND_CLASS      "HtBind"        # Higher-taxon binding
$define  EQ_BIND_CLASS      "EqBind"        # Equivalent binding


# - - -   A b _ B i n d _ N e w   - - -

#-- 1996-08-22:  Verified with Stavely
#-- ALL PROCEDURES NEED REVERIFICATION due to addition of the `eng'
#   generic method

procedure Ab_Bind_New ( abbr, var, show, combine, lookup, eng, class )
  local self

  self          :=  abBindTag ( );
  self.abbr     :=  abbr;
  self.var      :=  var;
  self.show     :=  show;
  self.combine  :=  combine;
  self.lookup   :=  lookup;
  self.eng      :=  eng;
  self.class    :=  class;

  return self;
end # --- Ab_Bind_New ---


# - - -   A b _ B i n d _ A b b r   - - -

#-- 1996-08-22:  Verified with Stavely

procedure Ab_Bind_Abbr ( self )
  return self.abbr;
end


# - - -   A b _ B i n d _ V a r   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ab_Bind_Var ( self )
  return self.var;
end


# - - -   A b _ B i n d _ S h o w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ab_Bind_Show ( self )
  return self.show ( self );
end


# - - -   A b _ B i n d _ C o m b i n e   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ab_Bind_Combine ( self, bind2 )
  return self.combine ( self, bind2 );  # NB: may fail
end


# - - -   A b _ B i n d _ L o o k u p   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ab_Bind_Lookup ( self )
  return self.lookup ( self );      # NB: may fail
end


# - - -   A b _ B i n d _ E n g   - - -

procedure Ab_Bind_Eng ( self )
  return self.eng ( self );    # Note: may fail
end


# - - -   A b _ B i n d _ C l a s s   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ab_Bind_Class ( self )
  return self.class;
end


#================================================================
# Class StdBind:  A variant of AbBind for the abbreviation of a
# a standard taxon, that is, one in the `std' file or a
# subspecific form from the alternate forms file.
#----------------------------------------------------------------
# INVARIANTS
#----------------------------------------------------------------
# .var == a Taxon object to which Abbr unambiguously refers
#----------------------------------------------------------------
# EXPORTED METHODS
#----------------------------------------------------------------
# Std_Bind_New ( abbr, taxon )
#   [ if abbr is an Abbr and taxon is a Taxon ->
#       return an AbBind with:
#         .abbr     :=  abbr
#         .var      :=  taxon
#         .show     :=  Std_Bind_Show
#         .combine  :=  Std_Bind_Combine
#         .lookup   :=  Std_Bind_Lookup
#         .class    :=  STD_BIND_CLASS
#   ]
#--
# Std_Bind_Show ( self )
#   [ return a string describing the Taxon in self.var
#   ]
#--
# Std_Bind_Combine ( self )
#   [ fails, because a StdBind cannot coexist with any other binding
#   ]
#--
# Std_Bind_Lookup ( self )
#   [ return the Taxon in self.var
#   ]
#--
# Std_Bind_Eng ( self )
#	[ return the English name from the Taxon in self.var
#	]
#--


# - - -   S t d _ B i n d _ N e w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Std_Bind_New ( abbr, taxon )
  return Ab_Bind_New ( abbr, taxon,
    Std_Bind_Show, Std_Bind_Combine, Std_Bind_Lookup, Std_Bind_Eng,
    STD_BIND_CLASS );
end


# - - -   S t d _ B i n d _ S h o w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Std_Bind_Show ( self )
  return Taxon_Show ( self.var );
end


# - - -   S t d _ B i n d _ C o m b i n e   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Std_Bind_Combine ( self, b2 )
  fail;
end


# - - -   S t d _ B i n d _ L o o k u p   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Std_Bind_Lookup ( self )
  return self.var;
end


# - - -   S t d _ B i n d _ E n g   - - -

procedure Std_Bind_Eng ( self )
  return Taxon_Eng ( self.var );
end


#================================================================
# Class CollBind:  A variant of AbBind to represent all of the
# names involved in a collision.  The variant (.var) field
# is a set of strings containing the `disamb' (unambiguous
# substitute) abbreviations given for this abbreviation.
#   For example, Spoonbill Sandpiper and Spotted Sandpiper
# collide for the use of SPOSAN; their disambs are SPBSAN
# and SPTSAN, respectively.  So the CollBind for this cluster
# would have "SPOSAN" in its .abbr field, and its .var would
# be the set {"SPBSAN", "SPTSAN"}.
#----------------------------------------------------------------
# EXPORTED METHODS
#----------------------------------------------------------------
# Coll_Bind_New ( abbr, collSet )
#   [ if abbr is an Abbr and collSet is a set of Abbr strings ->
#       return a new AbBind object with:
#         .abbr     :=  abbr
#         .var      :=  collSet
#         .show     :=  Coll_Bind_Show
#         .combine  :=  Coll_Bind_Combine
#         .lookup   :=  Coll_Bind_Lookup
#         .eng      :=  Coll_Bind_Eng
#         .class    :=  COLL_BIND_CLASS
#   ]
#--
# Coll_Bind_Show ( self )
#   [ return a string describing self.abbr as an invalid abbreviation
#     and listing the elements of self.collSet as preferred substitutes
#   ]
#--
# Coll_Bind_Combine ( self, b2 )
#   [ if b2 is an AbBind object ->
#       if b2 is not a CollBind object -> fail
#       else ->
#         return a new CollBind with the same fields as self except that
#         its .var is the union of self.var and b2.var
#   ]
#--
# Coll_Bind_Lookup ( self )
#   [ fails, because a collision abbr does not clearly refer to a
#     single taxon
#   ]
#--
# Coll_Bind_Eng ( self )
#	[ fails, because a collision abbr does not involve just one
#     English name
#	]
#--


# - - -   Invariants   - - -

#--
# .var == a set of Abbr strings
#--


# - - -   C o l l _ B i n d _ N e w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Coll_Bind_New ( abbr, collSet )
  return Ab_Bind_New ( abbr, collSet,
    Coll_Bind_Show, Coll_Bind_Combine, Coll_Bind_Lookup, Coll_Bind_Eng,
    COLL_BIND_CLASS );
end


# - - -   C o l l _ B i n d _ S h o w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Coll_Bind_Show ( self )
  local result

  result  :=  "Invalid code `" || self.abbr || "', use one of: ";

  every  result ||:= " " || ( ! sort ( self.var ) );

  return result;
end


# - - -   C o l l _ B i n d _ C o m b i n e   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Coll_Bind_Combine ( self, b2 )
  #-- 1 --
  #-[ if b2 is not of class COLL_BIND_CLASS -> fail
  # | else -> I
  #-]
  if  b2.class ~== COLL_BIND_CLASS  then
    fail;

  #-- 2 --
  #-[ return a new Coll_Bind with abbr=(self.abbr) and
  #   collSet=(union of self.var and b2.var)
  #-]
  return Coll_Bind_New ( self.abbr, self.var ++ b2.var );
end


# - - -   C o l l _ B i n d _ L o o k u p   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Coll_Bind_Lookup ( self )
  fail;
end


# - - -   C o l l _ B i n d _ E n g   - - -

procedure Coll_Bind_Eng ( )
  fail;
end


#================================================================
# Class EqBind:  Each instance represents an Abbr which is stated
# to be a deprecated code which is the exact equivalent of some
# other Abbr (represented as an AbSym).  The .var field points
# to an eqBindVarTag record that contains the AbSym of the other
# Abbr, and also holds the English name on which this Abbr is
# based.
#----------------------------------------------------------------
# EXPORTED METHODS
#----------------------------------------------------------------
# Eq_Bind_New ( abbr, prefSym, eng )
#   [ if prefSym is an AbSym object ->
#       return a new AbBind object with:
#         .abbr     :=  abbr
#         .var      :=  an eqBindVarTag with fields:
#                         .abSym   :=  prefSym
#                         .eng     :=  eng
#         .show     :=  Eq_Bind_Show
#         .combine  :=  Eq_Bind_Combine
#         .lookup   :=  Eq_Bind_Lookup
#         .eng      :=  Eq_Bind_Eng
#         .class    :=  EQ_BIND_CLASS
#   ]
#--
# Eq_Bind_Show ( self )
#   [ return a string describing self.abbr as a deprecated abbreviation
#     and suggesting self.var's .abbr as an alternative
#   ]
#--
# Eq_Bind_Combine ( self, b2 )
#   [ fails, because an EqBind cannot coexist with any other binding
#   ]
#--
# Eq_Bind_Lookup ( self )
#   [ if self.var has a binding B which is not another EqBind,
#     or if self.var is the head of a chain of one or more EqBinds
#     that is not circular and leads eventually to a binding B that
#     is not an EqBind ->
#       return Ab_Bind_Lookup ( B )
#   | else -> fail
#   ]
#--
# Eq_Bind_Eng ( self )
#	[ return the English name on which self is based
#	]
#--


# - - -   State   - - -

  record eqBindVarTag (		# Record type for EqBind .var field
	abSym,			# Symbol table entry for referenced equivalent
    eng )			# English name on which the Abbr is based


# - - -   Invariants   - - -

#--
# .var == an eqBindVarTag with fields:
#   .abSym == AbSym object whose Abbr is the one to which we are
#             directed, as the preferred form
#   .eng == The English name on which the Abbr is based
#--



# - - -   E q _ B i n d _ N e w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Eq_Bind_New ( abbr, prefSym, eng )
  local eqBindVar		# An eqBindVarTag for this binding's .var field

  eqBindVar        :=  eqBindVarTag ( );
  eqBindVar.abSym  :=  prefSym;
  eqBindVar.eng    :=  eng;

  return Ab_Bind_New ( abbr, eqBindVar,    
    Eq_Bind_Show, Eq_Bind_Combine, Eq_Bind_Lookup, Eq_Bind_Eng,
    EQ_BIND_CLASS );
end


# - - -   E q _ B i n d _ S h o w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Eq_Bind_Show ( self )
  return "Deprecated code `" || self.abbr || "', prefer " ||
    Ab_Sym_Abbr ( self.var.abSym );
end


# - - -   E q _ B i n d _ C o m b i n e   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Eq_Bind_Combine ( self, b2 )
  fail;
end


# - - -   E q _ B i n d _ E n g   - - -

procedure Eq_Bind_Eng ( self )
  return self.var.eng;
end


#================================================================
# NOTATIONAL DEFINITION.  The `eq-bind-chain-closure' function
# is used to find the taxon to which a particular EqBind refers.
#   The problem is that the data may contain reference loops.
# For example, suppose the data says that CATBIR=GRYCAT and
# GRYCAT=CATBIR.  If we just use straight recursion to chase
# these references, the program will loop.
#   So, when we start chasing a chain of EqBind bindings in
# hopes of finding one that isn't an EqBind, we do so while
# maintaining a set describing the abbrs of all the bindings
# we've seen so far, and fail if we get to an EqBind whose
# abbr is also in that set.  The set is symbolized as S in
# this notational definition:
#---------------------------------------------------------------
# eq-bind-chain-closure ( S, prefSym ) =
#   if prefSym has no binding -> fail
#   else if prefSym's binding B is not an EqBind ->
#     return Ab_Bind_Lookup(B)
#   else if Ab_Sym_Abbr(prefSym) is in set S ->
#     fail
#   else if prefSym's binding B is an EqBind ->
#     return eq-bind-chain-closure(S++set([S.abbr]), B.var)
#----------------------------------------------------------------


# - - -   E q _ B i n d _ L o o k u p   - - -

#-- 1996-08-26:  Verified with Stavely

#   [ return eq-bind-chain-closure ( set([self.abbr]), self.var.abSym)
#   ]

procedure Eq_Bind_Lookup ( self )
  return Eq_Bind_Chain_Closure ( set ( [ self.abbr ] ), self.var.abSym );
end



# - - -   E q _ B i n d _ C h a i n _ C l o s u r e   - - -

#-- 1996-08-26:  Verified with Stavely

#   [ if abbrSet is a set of Abbr objects and prefSym is an AbSym ->
#       abbrSet  :=  <anything>
#       return eq-bind-chain-closure ( abbrSet, prefSym )
#   ]

procedure Eq_Bind_Chain_Closure ( abbrSet, prefSym )
  local symBind     # The current binding of prefSym, if any
  local symAbbr     # If symBind is an EqBind, its prefSym's .abbr

  #-- 1 --
  #-[ if prefSym is unbound -> fail
  # | else ->
  #     symBind  :=  its binding
  #-]
  if  not ( symBind := Ab_Sym_Binding ( prefSym ) )  then
    fail;

  #-- 2 --
  #-[ if symBind is not an EqBind ->
  #     return Ab_Bind_Lookup ( symBind )
  # | else -> I
  #-]
  if  Ab_Bind_Class ( symBind ) ~== EQ_BIND_CLASS  then
    return Ab_Bind_Lookup ( symBind );

  #-- 3 --
  #-[ if symBind is an AbBind object ->
  #     symAbbr  :=  the Abbr from symBind
  #-]
  symAbbr  :=  symBind.abbr;

  #-- 4 --
  #-[ if symAbbr is an Abbr object ->
  #     if symAbbr is in abbrSet ->
  #       fail (because this reference chain is a circuit)
  #     else ->
  #       abbrSet  ++:=  symAbbr
  #-]
  if  member ( abbrSet, symAbbr )  then
    fail
  else
    insert ( abbrSet, symAbbr );

  #-- 5 --
  #-[ return eq-bind-chain-closure ( abbrSet, symBind.var.abSym )
  #-]
  #--NOTE: We know that symBind.var.abSym is an AbSym because
  #  symBind is an EqBind (because prime 2 eliminated all other cases)
  #  and there is an invariant to the effect that an EqBind's .var.abSym
  #  is an EqBind.
  #--
  return Eq_Bind_Chain_Closure ( abbrSet, symBind.var.abSym );
end # --- Eq_Bind_Chain_Closure ---


#================================================================
# Class HtBind:  Each instance represents an Abbr that refers to
# a standard taxon of a higher rank than species.
#----------------------------------------------------------------
# Exported methods
#----------------------------------------------------------------
# Ht_Bind_New ( abbr, taxon, eng, tex )
#   [ if abbr is an Abbr, taxon is a Taxon, eng is an English name
#     as a string, and tex is a TeX-encoded English name as a 
#     string ->
#       return a new AbBind object with:
#         .abbr     :=  abbr
#         .var      :=  an htBindVarTag with:
#                         .taxon  :=  taxon
#                         .eng    :=  eng
#                         .tex    :=  tex
#         .show     :=  Ht_Bind_Show
#         .combine  :=  Ht_Bind_Combine
#         .lookup   :=  Ht_Bind_Lookup
#         .eng      :=  Ht_Bind_Eng
#         .class    :=  HT_BIND_CLASS
#   ]
#--
# Ht_Bind_Show ( self )
#   [ return a string describing self as a higher-taxon abbreviation
#     self.abbr representing English name self.var.eng and
#     taxon self.var.taxon
#   ]
#--
# Ht_Bind_Combine ( self )
#   [ fails, because an HtBind cannot coexist with any other binding
#   ]
#--
# Ht_Bind_Lookup ( self )
#   [ return self.var.taxon
#   ]
#--
# Ht_Bind_Eng ( self )
#	[ return self.var.eng
#	]
#--


# - - -   State   - - -

  record htBindVarTag (     # Record type for HtBind .var field
    taxon,      # Related taxon
    eng,        # English name corresponding to this Abbr
    tex )       # TeX-encoded name for this Abbr


# - - -   Invariants   - - -

#--
# .var == an htBindVarTag with fields:
#           .taxon == a Taxon object
#           .eng == an English name as a string
#           .tex == a TeX-encoded English name as a string
#--


# - - -   H t _ B i n d _ N e w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ht_Bind_New ( abbr, taxon, eng, tex )
  return Ab_Bind_New ( abbr, htBindVarTag ( taxon, eng, tex ),
    Ht_Bind_Show, Ht_Bind_Combine, Ht_Bind_Lookup, Ht_Bind_Eng,
    HT_BIND_CLASS );
end


# - - -   H t _ B i n d _ S h o w   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ht_Bind_Show ( self )
  return self.var.eng || "=" || Taxon_Show ( self.var.taxon );
end


# - - -   H t _ B i n d _ C o m b i n e   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ht_Bind_Combine ( self, b2 )
  fail;
end


# - - -   H t _ B i n d _ L o o k u p   - - -

#-- 1996-08-26:  Verified with Stavely

procedure Ht_Bind_Lookup ( self )
  return self.var.taxon;
end


# - - -   H t _ B i n d _ E n g   - - -

procedure Ht_Bind_Eng ( self )
  return self.var.eng;
end