# Inbreeding Calculations using routines written by Bill Szkotnicki
#  for large pedigrees following the Meuwissen and Luo algorithm
#  The DLL should be available in the computer lab.
#  At home you will have to copy the DLL from the ABMethods website

dyn.load("rclib.dll") # open source file and demo compiled routines
getLoadedDLLs()  # This shows what DLLs are being used

# The "wrapper" functions need to be defined, as given below
#  The routines were written in the C language, and a "wrapper"
#  is necessary for R to understand and use it.
#  You can also make wrappers for FORTRAN programs.

# Function to initialize the arrays for a pedigree
xpdinit <- function(n) {
  if (!is.numeric(n)) stop("argument n must be numeric")
  out <- .C("xpdinit",n=as.integer(n),rv=as.integer(0))
  return(out$rv)
}

# Function to release the memory for arrays used for the pedigree
xpdfree <- function() {
  out <- .C("xpdfree",rv=as.integer(0))
  return(out$rv)
}

# Function to add a new animal to the pedigree list,
#  returns the inbreeding coefficient of the new animal.
xpdadd <- function(sire,dam) {
  if (!is.numeric(sire)) stop("sire must be numeric")
  if (!is.numeric(dam)) stop("dam must be numeric")
  out <- .C("xpdadd",sire=as.integer(sire),dam=as.integer(dam),rv=as.double(0))
  return(out$rv)
}

# Function to compute the relationship between animals i and j
xpdrel <- function(i,j) {
  if (!is.numeric(i)) stop("i must be numeric")
  if (!is.numeric(j)) stop("j must be numeric")
  out <- .C("xpdrel",isin=as.integer(i),idin=as.integer(j),rv=as.double(0))
  return(out$rv)
}

# Function to calculate the 'b' value in A = TBT'
xpdd <- function(i) {
  if (!is.numeric(i)) stop("i must be numeric")
  out <- .C("xpdd",isin=as.integer(i),rv=as.double(0))
  return(out$rv)
}

# Function to calculate the inbreeding coefficient
xpdf <- function(i) {
  if (!is.numeric(i)) stop("i must be numeric")
  out <- .C("xpdf",isin=as.integer(i),rv=as.double(0))
  return(out$rv)
}

# Function to determine the number of animals in the pedigree.
xpdnanim <- function() {
  out <- .C("xpdnanim",rv=as.integer(0))
  return(out$rv)
}