library(rLingo)

BassModelCT <- function(SALES, TRAINON, ULP, ULQ, ULM, LLP, LLQ, LLM)
{
    pResult <- list(ErrorCode = LSERR_NO_ERROR_LNG)

    #Create Lingo enviroment object
    pLINGO <- rLScreateEnvLng();
    if(is.null(pLINGO))
    {
        cat("\ncannot create LINGO environment!\n")
        return(pResult)
    }

    #Open LINGO's log file
    pResult <- rLSopenLogFileLng(pLINGO,"BassModelCT.log")
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #Pass memory transfer pointers to LINGO
    #Define pnPointersNow
    pnPointersNow = integer(1)

    #@POINTER(1)
    #Note that PERIOD is a set, so its pointer must be passed to LINGO first.
    PERIOD = c("")
    for(i in 1:length(SALES))
    {
        PERIOD = paste(PERIOD, i, "\n");
    }
    pResult <- rLSsetCharPointerLng(pLINGO, PERIOD, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(2)
    pResult <- rLSsetDouPointerLng(pLINGO, SALES, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(3)
    pResult <- rLSsetDouPointerLng(pLINGO, TRAINON, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(4)
    pResult <- rLSsetDouPointerLng(pLINGO, ULP, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(5)
    pResult <- rLSsetDouPointerLng(pLINGO, ULQ, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(6)
    pResult <- rLSsetDouPointerLng(pLINGO, ULM, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(7)
    pResult <- rLSsetDouPointerLng(pLINGO, LLP, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(8)
    pResult <- rLSsetDouPointerLng(pLINGO, LLQ, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(9)
    pResult <- rLSsetDouPointerLng(pLINGO, LLM, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(10)
    P = c(1.0)
    pResult <- rLSsetDouPointerLng(pLINGO, P, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(11)
    Q = c(1.0)
    pResult <- rLSsetDouPointerLng(pLINGO, Q, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(12)
    M = c(1.0)
    pResult <- rLSsetDouPointerLng(pLINGO, M, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(13)
    ERROR = numeric(length(SALES))
    pResult <- rLSsetDouPointerLng(pLINGO, ERROR, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(14)
    FORECAST = numeric(length(SALES))
    pResult <- rLSsetDouPointerLng(pLINGO, FORECAST, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(15)
    dStatus = c(-1.0)
    pResult <- rLSsetDouPointerLng(pLINGO, dStatus, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(16)
    dObjective = c(-1.0)
    pResult <- rLSsetDouPointerLng(pLINGO, dObjective, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #Here is the script we want LINGO to run
    cScript = "SET ECHOIN 1 \n TAKE BassModelCT.lng \n GO \n QUIT \n"

    #Run the script
    pResult <- rLSexecuteScriptLng(pLINGO, cScript)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #Close the log file
    pResult <- rLScloseLogFileLng(pLINGO)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #Check solver status
    if(dStatus == LS_STATUS_GLOBAL_LNG)
    {
        cat("\nGlobal optimum found!")
    }
    else if(dStatus == LS_STATUS_LOCAL_LNG)
    {
        cat("\nLocal optimum found!")
    }
    else
    {
        cat("\nSolution is non-optimal, status = ", dStatus, "\n")
        return(pResult)
    }

    #Check solution
    cat("\nMin sum of squared errors is", dObjective,"\n")
    #
    cat("Estimated market size, M is ", M,"\n")
    #
    cat("Innovator coefficient, p is ", P,"\n")
    #
    cat("Copycat, word-of-mouth coefficient, q is ", Q,"\n")

    #Delete Lingo enviroment object
    pResult <- rLSdeleteEnvLng(pLINGO)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    return(pResult)
}

#All inputs are initialized here
#SALES = c(37.3,24.7,17.8,12.5,9.60,7.37,4.60,2.93,2.27,1.43,1.29,0.940,0.804,0.529,0.417)
#Weekly sales (scaled) for the movie "The Doctor", see Lilien &Rangaswamy;
#SALES = c( 0.1, 3.0, 5.2, 7.0, 5.25, 4.9, 3.0, 2.4, 1.9, 1.3, 0.8, 0.6);
#Weekly sales for the movie "Gravity";
SALES = c(55.8, 43.2, 30.0, 20.1, 12.8, 8.5, 6.1, 3.2, 2.6);
TRAINON = c(6)
ULP = c(1.0)
ULQ = c(1.0)
ULM = c(9999)
LLP = c(0.0)
LLQ = c(0.0)
LLM = c(0.0)

#Run the function
BassModelCT(SALES, TRAINON, ULP, ULQ, ULM, LLP, LLQ, LLM)