library(rLingo)

SP_College <- function(TIME, ASSETS, INITIAL, GOAL, PENALTY, OUTCOMES, O_RETURN)
{
    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,"SP_College.log")
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

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

    #@POINTER(1)
    pResult <- rLSsetCharPointerLng(pLINGO, TIME, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

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

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

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

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

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

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

    lengthTIME = length(strsplit(TIME,' ')[[1]]) / 2
    lengthASSETS = length(strsplit(ASSETS,' ')[[1]]) / 2
    numScene = 2 ^ ( lengthTIME - 1 )
    
    #@POINTER(8)
    RETURN = array( 0, dim = c( lengthTIME, lengthASSETS, numScene ) ) 
    pResult <- rLSsetDouPointerLng(pLINGO, RETURN, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(9)
    OVER = array( 0, dim = c( numScene ) ) 
    pResult <- rLSsetDouPointerLng(pLINGO, OVER, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(10)
    UNDER = array( 0, dim = c( numScene ) ) 
    pResult <- rLSsetDouPointerLng(pLINGO, UNDER, pnPointersNow)
    if(pResult$ErrorCode != LSERR_NO_ERROR_LNG)
    {
        return(pResult)
    }

    #@POINTER(11)
    PRBSCENE = array( 0, dim = c( numScene ) ) 
    pResult <- rLSsetDouPointerLng(pLINGO, PRBSCENE, 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 SP_College.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)
    }

    cat( '\n                  Surplus     ' )
    for( j in 2:lengthTIME )
    {
        cat( '              ', strsplit(TIME,split=" ")[[1]][2*(j-1)+1] );      
    }
    cat("\n")

    cat( '   Scenario        Return      Prob' )
    for( j in 2:lengthTIME )
    {
        cat('     Bond   Stock')
    }
    cat("\n")

    X_SURPLUS = 0
    for( i in 1:numScene )
    {
        cat( sprintf( "%10d", i ) )
        cat( sprintf( "%15.3f", OVER[i] - UNDER[i] ) )
        cat( sprintf( "%10.3f", PRBSCENE[i] ) )
        for( t in 2:lengthTIME )
        {
             cat(' ')
             for( a in 1:lengthASSETS )
             {
                 cat( sprintf( "   %4.1f%%", 100*( RETURN[t,a,i] - 1 ) ) )
             }
        }
        cat("\n")
        X_SURPLUS = X_SURPLUS + PRBSCENE[i] * ( OVER[i] - UNDER[i] )
    }

    cat( sprintf( "\n   Expected Surplus: %15.3f\n", X_SURPLUS ) )

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

    return(pResult)
}

#All inputs are initialized here
#Time stages
TIME = c("T0 \n T1 \n T2 \n T3 \n")

#Names of investments available
ASSETS = c("BONDS \n STOCKS \n")

#Initial capital
INITIAL = c(55)

#Goal after three stages
GOAL = c(80)

#Penalty/unit short of goal
PENALTY = c(4)

OUTCOMES = c("GOOD \n BAD \n")

O_RETURN = c(1.14, 1.25, 1.12, 1.06)

#Run the function
SP_College(TIME, ASSETS, INITIAL, GOAL, PENALTY, OUTCOMES, O_RETURN)