function [x,f,exitflag,output] = minFunc(funObj,x0,options,varargin)
% minFunc(funObj,x0,options,varargin)
%
% Unconstrained optimizer using a line search strategy
%
% Uses an interface very similar to fminunc
%   (it doesn't support all of the optimization toolbox options,
%       but supports many other options).
%
% It computes descent directions using one of ('Method'):
%   - 'sd': Steepest Descent
%       (no previous information used, not recommended)
%   - 'csd': Cyclic Steepest Descent
%       (uses previous step length for a fixed length cycle)
%   - 'bb': Barzilai and Borwein Gradient
%       (uses only previous step)
%   - 'cg': Non-Linear Conjugate Gradient
%       (uses only previous step and a vector beta)
%   - 'scg': Scaled Non-Linear Conjugate Gradient
%       (uses previous step and a vector beta,
%           and Hessian-vector products to initialize line search)
%   - 'pcg': Preconditionined Non-Linear Conjugate Gradient
%       (uses only previous step and a vector beta, preconditioned version)
%   - 'lbfgs': Quasi-Newton with Limited-Memory BFGS Updating
%       (default: uses a predetermined nunber of previous steps to form a
%           low-rank Hessian approximation)
%   - 'newton0': Hessian-Free Newton
%       (numerically computes Hessian-Vector products)
%   - 'pnewton0': Preconditioned Hessian-Free Newton
%       (numerically computes Hessian-Vector products, preconditioned
%       version)
%   - 'qnewton': Quasi-Newton Hessian approximation
%       (uses dense Hessian approximation)
%   - 'mnewton': Newton's method with Hessian calculation after every
%   user-specified number of iterations
%       (needs user-supplied Hessian matrix)
%   - 'newton': Newton's method with Hessian calculation every iteration
%       (needs user-supplied Hessian matrix)
%   - 'tensor': Tensor
%       (needs user-supplied Hessian matrix and Tensor of 3rd partial derivatives)
%
% Several line search strategies are available for finding a step length satisfying
%   the termination criteria ('LS'):
%   - 0: Backtrack w/ Step Size Halving
%   - 1: Backtrack w/ Quadratic/Cubic Interpolation from new function values
%   - 2: Backtrack w/ Cubic Interpolation from new function + gradient
%   values (default for 'bb' and 'sd')
%   - 3: Bracketing w/ Step Size Doubling and Bisection
%   - 4: Bracketing w/ Cubic Interpolation/Extrapolation with function +
%   gradient values (default for all except 'bb' and 'sd')
%   - 5: Bracketing w/ Mixed Quadratic/Cubic Interpolation/Extrapolation
%   - 6: Use Matlab Optimization Toolbox's line search
%           (requires Matlab's linesearch.m to be added to the path)
%
%   Above, the first three find a point satisfying the Armijo conditions,
%   while the last four search for find a point satisfying the Wolfe
%   conditions.  If the objective function overflows, it is recommended
%   to use one of the first 3.
%   The first three can be used to perform a non-monotone
%   linesearch by changing the option 'Fref'.
%
% Several strategies for choosing the initial step size are avaiable ('LS_init'):
%   - 0: Always try an initial step length of 1 (default for all except 'cg' and 'sd')
%       (t = 1)
%   - 1: Use a step similar to the previous step (default for 'cg' and 'sd')
%       (t = t_old*min(2,g'd/g_old'd_old))
%   - 2: Quadratic Initialization using previous function value and new
%   function value/gradient (use this if steps tend to be very long)
%       (t = min(1,2*(f-f_old)/g))
%   - 3: The minimum between 1 and twice the previous step length
%       (t = min(1,2*t)
%   - 4: The scaled conjugate gradient step length (may accelerate
%   conjugate gradient methods, but requires a Hessian-vector product)
%       (t = g'd/d'Hd)
%
% Inputs:
%   funObj is a function handle
%   x0 is a starting vector;
%   options is a struct containing parameters
%  (defaults are used for non-existent or blank fields)
%   all other arguments are passed to funObj
%
% Outputs:
%   x is the minimum value found
%   f is the function value at the minimum found
%   exitflag returns an exit condition
%   output returns a structure with other information
%
% Supported Input Options
%   Display - Level of display [ off | final | (iter) | full | excessive ]
%   MaxFunEvals - Maximum number of function evaluations allowed (1000)
%   MaxIter - Maximum number of iterations allowed (500)
%   TolFun - Termination tolerance on the first-order optimality (1e-5)
%   TolX - Termination tolerance on progress in terms of function/parameter changes (1e-9)
%   Method - [ sd | csd | bb | cg | scg | pcg | {lbfgs} | newton0 | pnewton0 |
%       qnewton | mnewton | newton | tensor ]
%   c1 - Sufficient Decrease for Armijo condition (1e-4)
%   c2 - Curvature Decrease for Wolfe conditions (.2 for cg methods, .9 otherwise)
%   LS_init - Line Search Initialization -see above (2 for cg/sd, 4 for scg, 0 otherwise)
%   LS - Line Search type -see above (2 for bb, 4 otherwise)
%   Fref - Setting this to a positive integer greater than 1
%       will use non-monotone Armijo objective in the line search.
%       (20 for bb, 10 for csd, 1 for all others)
%   numDiff - compute derivative numerically
%       (default: 0) (this option has a different effect for 'newton', see below)
%   useComplex - if 1, use complex differentials when computing numerical derivatives
%       to get very accurate values (default: 0)
%   DerivativeCheck - if 'on', computes derivatives numerically at initial
%       point and compares to user-supplied derivative (default: 'off')
%   outputFcn - function to run after each iteration (default: []).  It
%       should have the following interface:
%       outputFcn(x,infoStruct,state,varargin{:})
%   useMex - where applicable, use mex files to speed things up (default: 1)
%
% Method-specific input options:
%   newton:
%       HessianModify - type of Hessian modification for direct solvers to
%       use if the Hessian is not positive definite (default: 0)
%           0: Minimum Euclidean norm s.t. eigenvalues sufficiently large
%           (requires eigenvalues on iterations where matrix is not pd)
%           1: Start with (1/2)*||A||_F and increment until Cholesky succeeds
%           (an approximation to method 0, does not require eigenvalues)
%           2: Modified LDL factorization
%           (only 1 generalized Cholesky factorization done and no eigenvalues required)
%           3: Modified Spectral Decomposition
%           (requires eigenvalues)
%           4: Modified Symmetric Indefinite Factorization
%           5: Uses the eigenvector of the smallest eigenvalue as negative
%           curvature direction
%       cgSolve - use conjugate gradient instead of direct solver (default: 0)
%           0: Direct Solver
%           1: Conjugate Gradient
%           2: Conjugate Gradient with Diagonal Preconditioner
%           3: Conjugate Gradient with LBFGS Preconditioner
%           x: Conjugate Graident with Symmetric Successive Over Relaxation
%           Preconditioner with parameter x
%               (where x is a real number in the range [0,2])
%           x: Conjugate Gradient with Incomplete Cholesky Preconditioner
%           with drop tolerance -x
%               (where x is a real negative number)
%       numDiff - compute Hessian numerically
%                 (default: 0, done with complex differentials if useComplex = 1)
%       LS_saveHessiancomp - when on, only computes the Hessian at the
%       first and last iteration of the line search (default: 1)
%   mnewton:
%       HessianIter - number of iterations to use same Hessian (default: 5)
%   qnewton:
%       initialHessType - scale initial Hessian approximation (default: 1)
%       qnUpdate - type of quasi-Newton update (default: 3):
%           0: BFGS
%           1: SR1 (when it is positive-definite, otherwise BFGS)
%           2: Hoshino
%           3: Self-Scaling BFGS
%           4: Oren's Self-Scaling Variable Metric method
%           5: McCormick-Huang asymmetric update
%       Damped - use damped BFGS update (default: 1)
%   newton0/pnewton0:
%       HvFunc - user-supplied function that returns Hessian-vector products
%           (by default, these are computed numerically using autoHv)
%           HvFunc should have the following interface: HvFunc(v,x,varargin{:})
%       useComplex - use a complex perturbation to get high accuracy
%           Hessian-vector products (default: 0)
%           (the increased accuracy can make the method much more efficient,
%               but gradient code must properly support complex inputs)
%       useNegCurv - a negative curvature direction is used as the descent
%           direction if one is encountered during the cg iterations
%           (default: 1)
%       precFunc (for pnewton0 only) - user-supplied preconditioner
%           (by default, an L-BFGS preconditioner is used)
%           precFunc should have the following interfact:
%           precFunc(v,x,varargin{:})
%   lbfgs:
%       Corr - number of corrections to store in memory (default: 100)
%           (higher numbers converge faster but use more memory)
%       Damped - use damped update (default: 0)
%   pcg:
%       cgUpdate - type of update (default: 2)
%   cg/scg/pcg:
%       cgUpdate - type of update (default for cg/scg: 2, default for pcg: 1)
%           0: Fletcher Reeves
%           1: Polak-Ribiere
%           2: Hestenes-Stiefel (not supported for pcg)
%           3: Gilbert-Nocedal
%       HvFunc (for scg only)- user-supplied function that returns Hessian-vector
%           products
%           (by default, these are computed numerically using autoHv)
%           HvFunc should have the following interface:
%           HvFunc(v,x,varargin{:})
%       precFunc (for pcg only) - user-supplied preconditioner
%           (by default, an L-BFGS preconditioner is used)
%           precFunc should have the following interfact:
%           precFunc(v,x,varargin{:})
%   bb:
%       bbType - type of bb step (default: 1)
%           0: min_alpha ||delta_x - alpha delta_g||_2
%           1: min_alpha ||alpha delta_x - delta_g||_2
%           2: Conic BB
%           3: Gradient method with retards
%   csd:
%       cycle - length of cycle (default: 3)
%
% Supported Output Options
%   iterations - number of iterations taken
%   funcCount - number of function evaluations
%   algorithm - algorithm used
%   firstorderopt - first-order optimality
%   message - exit message
%   trace.funccount - function evaluations after each iteration
%   trace.fval - function value after each iteration
%
% Author: Mark Schmidt (2006)
% Web: http://www.cs.ubc.ca/~schmidtm
%
% Sources (in order of how much the source material contributes):
%   J. Nocedal and S.J. Wright.  1999.  "Numerical Optimization".  Springer Verlag.
%   R. Fletcher.  1987.  "Practical Methods of Optimization".  Wiley.
%   J. Demmel.  1997.  "Applied Linear Algebra.  SIAM.
%   R. Barret, M. Berry, T. Chan, J. Demmel, J. Dongarra, V. Eijkhout, R.
%   Pozo, C. Romine, and H. Van der Vost.  1994.  "Templates for the Solution of
%   Linear Systems: Building Blocks for Iterative Methods".  SIAM.
%   J. More and D. Thuente.  "Line search algorithms with guaranteed
%   sufficient decrease".  ACM Trans. Math. Softw. vol 20, 286-307, 1994.
%   M. Raydan.  "The Barzilai and Borwein gradient method for the large
%   scale unconstrained minimization problem".  SIAM J. Optim., 7, 26-33,
%   (1997).
%   "Mathematical Optimization".  The Computational Science Education
%   Project.  1995.
%   C. Kelley.  1999.  "Iterative Methods for Optimization".  Frontiers in
%   Applied Mathematics.  SIAM.

if nargin < 3
    options = [];
end

% Get Parameters
[verbose,verboseI,debug,doPlot,maxFunEvals,maxIter,tolFun,tolX,method,...
    corrections,c1,c2,LS_init,LS,cgSolve,qnUpdate,cgUpdate,initialHessType,...
    HessianModify,Fref,useComplex,numDiff,LS_saveHessianComp,...
    DerivativeCheck,Damped,HvFunc,bbType,cycle,...
    HessianIter,outputFcn,useMex,useNegCurv,precFunc] = ...
    minFunc_processInputOptions(options);

if isfield(options, 'logfile')
    logfile = options.logfile;
else
    logfile = [];
end

% Constants
SD = 0;
CSD = 1;
BB = 2;
CG = 3;
PCG = 4;
LBFGS = 5;
QNEWTON = 6;
NEWTON0 = 7;
NEWTON = 8;
TENSOR = 9;

% Initialize
p = length(x0);
d = zeros(p,1);
x = x0;
t = 1;

% If necessary, form numerical differentiation functions
funEvalMultiplier = 1;
if numDiff && method ~= TENSOR
    varargin(3:end+2) = varargin(1:end);
    varargin{1} = useComplex;
    varargin{2} = funObj;
    if method ~= NEWTON
        if debug
            if useComplex
                fprintf('Using complex differentials for gradient computation\n');
            else
                fprintf('Using finite differences for gradient computation\n');
            end
        end
        funObj = @autoGrad;
    else
        if debug
            if useComplex
                fprintf('Using complex differentials for gradient computation\n');
            else
                fprintf('Using finite differences for gradient computation\n');
            end
        end
        funObj = @autoHess;
    end

    if method == NEWTON0 && useComplex == 1
        if debug
            fprintf('Turning off the use of complex differentials\n');
        end
        useComplex = 0;
    end

    if useComplex
        funEvalMultiplier = p;
    else
        funEvalMultiplier = p+1;
    end
end

% Evaluate Initial Point
if method < NEWTON
    [f,g] = feval(funObj, x, varargin{:});
else
    [f,g,H] = feval(funObj, x, varargin{:});
    computeHessian = 1;
end
funEvals = 1;

if strcmp(DerivativeCheck,'on')
    if numDiff
        fprintf('Can not do derivative checking when numDiff is 1\n');
    end
    % Check provided gradient/hessian function using numerical derivatives
    fprintf('Checking Gradient:\n');
    [f2,g2] = autoGrad(x,useComplex,funObj,varargin{:});

    fprintf('Max difference between user and numerical gradient: %f\n',max(abs(g-g2)));
    if max(abs(g-g2)) > 1e-4
        fprintf('User NumDif:\n');
        [g g2]
        diff = abs(g-g2)
        pause;
    end

    if method >= NEWTON
        fprintf('Check Hessian:\n');
        [f2,g2,H2] = autoHess(x,useComplex,funObj,varargin{:});

        fprintf('Max difference between user and numerical hessian: %f\n',max(abs(H(:)-H2(:))));
        if max(abs(H(:)-H2(:))) > 1e-4
            H
            H2
            diff = abs(H-H2)
            pause;
        end
    end
end

% Output Log
if verboseI
    fprintf('%10s %10s %15s %15s %15s\n','Iteration','FunEvals','Step Length','Function Val','Opt Cond');
end

if logfile
    fid = fopen(logfile, 'a');
    if (fid > 0)
        fprintf(fid, '-- %10s %10s %15s %15s %15s\n','Iteration','FunEvals','Step Length','Function Val','Opt Cond');
        fclose(fid);
    end
end

% Output Function
if ~isempty(outputFcn)
    callOutput(outputFcn,x,'init',0,funEvals,f,[],[],g,[],sum(abs(g)),varargin{:});
end

% Initialize Trace
trace.fval = f;
trace.funcCount = funEvals;

% Check optimality of initial point
if sum(abs(g)) <= tolFun
    exitflag=1;
    msg = 'Optimality Condition below TolFun';
    if verbose
        fprintf('%s\n',msg);
    end
    if nargout > 3
        output = struct('iterations',0,'funcCount',1,...
            'algorithm',method,'firstorderopt',sum(abs(g)),'message',msg,'trace',trace);
    end
    return;
end

% Perform up to a maximum of 'maxIter' descent steps:
for i = 1:maxIter

    % ****************** COMPUTE DESCENT DIRECTION *****************

    switch method
        case SD % Steepest Descent
            d = -g;

        case CSD % Cyclic Steepest Descent

            if mod(i,cycle) == 1 % Use Steepest Descent
                alpha = 1;
                LS_init = 2;
                LS = 4; % Precise Line Search
            elseif mod(i,cycle) == mod(1+1,cycle) % Use Previous Step
                alpha = t;
                LS_init = 0;
                LS = 2; % Non-monotonic line search
            end
            d = -alpha*g;

        case BB % Steepest Descent with Barzilai and Borwein Step Length

            if i == 1
                d = -g;
            else
                y = g-g_old;
                s = t*d;
                if bbType == 0
                    yy = y'*y;
                    alpha = (s'*y)/(yy);
                    if alpha <= 1e-10 || alpha > 1e10
                        alpha = 1;
                    end
                elseif bbType == 1
                    sy = s'*y;
                    alpha = (s'*s)/sy;
                    if alpha <= 1e-10 || alpha > 1e10
                        alpha = 1;
                    end
                elseif bbType == 2 % Conic Interpolation ('Modified BB')
                    sy = s'*y;
                    ss = s'*s;
                    alpha = ss/sy;
                    if alpha <= 1e-10 || alpha > 1e10
                        alpha = 1;
                    end
                    alphaConic = ss/(6*(myF_old - f) + 4*g'*s + 2*g_old'*s);
                    if alphaConic > .001*alpha && alphaConic < 1000*alpha
                        alpha = alphaConic;
                    end
                elseif bbType == 3 % Gradient Method with retards (bb type 1, random selection of previous step)
                    sy = s'*y;
                    alpha = (s'*s)/sy;
                    if alpha <= 1e-10 || alpha > 1e10
                        alpha = 1;
                    end
                    v(1+mod(i-2,5)) = alpha;
                    alpha = v(ceil(rand*length(v)));
                end
                d = -alpha*g;
            end
            g_old = g;
            myF_old = f;

        case CG % Non-Linear Conjugate Gradient

            if i == 1
                d = -g; % Initially use steepest descent direction
            else
                gtgo = g'*g_old;
                gotgo = g_old'*g_old;

                if cgUpdate == 0
                    % Fletcher-Reeves
                    beta = (g'*g)/(gotgo);
                elseif cgUpdate == 1
                    % Polak-Ribiere
                    beta = (g'*(g-g_old)) /(gotgo);
                elseif cgUpdate == 2
                    % Hestenes-Stiefel
                    beta = (g'*(g-g_old))/((g-g_old)'*d);
                else
                    % Gilbert-Nocedal
                    beta_FR = (g'*(g-g_old)) /(gotgo);
                    beta_PR = (g'*g-gtgo)/(gotgo);
                    beta = max(-beta_FR,min(beta_PR,beta_FR));
                end

                d = -g + beta*d;

                % Restart if not a direction of sufficient descent
                if g'*d > -tolX
                    if debug
                        fprintf('Restarting CG\n');
                    end
                    beta = 0;
                    d = -g;
                end

                % Old restart rule:
                %if beta < 0 || abs(gtgo)/(gotgo) >= 0.1 || g'*d >= 0

            end
            g_old = g;

        case PCG % Preconditioned Non-Linear Conjugate Gradient

            % Apply preconditioner to negative gradient
            if isempty(precFunc)
                % Use L-BFGS Preconditioner
                if i == 1
                    old_dirs = zeros(length(g),0);
                    old_stps = zeros(length(g),0);
                    Hdiag = 1;
                    s = -g;
                else
                    [old_dirs,old_stps,Hdiag] = lbfgsUpdate(g-g_old,t*d,corrections,debug,old_dirs,old_stps,Hdiag);

                    if useMex
                        s = lbfgsC(-g,old_dirs,old_stps,Hdiag);
                    else
                        s = lbfgs(-g,old_dirs,old_stps,Hdiag);
                    end
                end
            else % User-supplied preconditioner
                s = precFunc(-g,x,varargin{:});
            end

            if i == 1
                d = s;
            else

                if cgUpdate == 0
                    % Preconditioned Fletcher-Reeves
                    beta = (g'*s)/(g_old'*s_old);
                elseif cgUpdate < 3
                    % Preconditioned Polak-Ribiere
                    beta = (g'*(s-s_old))/(g_old'*s_old);
                else
                    % Preconditioned Gilbert-Nocedal
                    beta_FR = (g'*s)/(g_old'*s_old);
                    beta_PR = (g'*(s-s_old))/(g_old'*s_old);
                    beta = max(-beta_FR,min(beta_PR,beta_FR));
                end
                d = s + beta*d;

                if g'*d > -tolX
                    if debug
                        fprintf('Restarting CG\n');
                    end
                    beta = 0;
                    d = s;
                end

            end
            g_old = g;
            s_old = s;
        case LBFGS % L-BFGS

            % Update the direction and step sizes

            if i == 1
                d = -g; % Initially use steepest descent direction
                old_dirs = zeros(length(g),0);
                old_stps = zeros(length(d),0);
                Hdiag = 1;
            else
                if Damped
                    [old_dirs,old_stps,Hdiag] = dampedUpdate(g-g_old,t*d,corrections,debug,old_dirs,old_stps,Hdiag);
                else
                    [old_dirs,old_stps,Hdiag] = lbfgsUpdate(g-g_old,t*d,corrections,debug,old_dirs,old_stps,Hdiag);
                end

                if useMex
                    d = lbfgsC(-g,old_dirs,old_stps,Hdiag);
                else
                    d = lbfgs(-g,old_dirs,old_stps,Hdiag);
                end
            end
            g_old = g;

        case QNEWTON % Use quasi-Newton Hessian approximation

            if i == 1
                d = -g;
            else
                % Compute difference vectors
                y = g-g_old;
                s = t*d;

                if i == 2
                    % Make initial Hessian approximation
                    if initialHessType == 0
                        % Identity
                        if qnUpdate <= 1
                            R = eye(length(g));
                        else
                            H = eye(length(g));
                        end
                    else
                        % Scaled Identity
                        if debug
                            fprintf('Scaling Initial Hessian Approximation\n');
                        end
                        if qnUpdate <= 1
                            % Use Cholesky of Hessian approximation
                            R = sqrt((y'*y)/(y'*s))*eye(length(g));
                        else
                            % Use Inverse of Hessian approximation
                            H = eye(length(g))*(y'*s)/(y'*y);
                        end
                    end
                end

                if qnUpdate == 0 % Use BFGS updates
                    Bs = R'*(R*s);
                    if Damped
                        eta = .02;
                        if y'*s < eta*s'*Bs
                            if debug
                                fprintf('Damped Update\n');
                            end
                            theta = min(max(0,((1-eta)*s'*Bs)/(s'*Bs - y'*s)),1);
                            y = theta*y + (1-theta)*Bs;
                        end
                        R = cholupdate(cholupdate(R,y/sqrt(y'*s)),Bs/sqrt(s'*Bs),'-');
                    else
                        if y'*s > 1e-10
                            R = cholupdate(cholupdate(R,y/sqrt(y'*s)),Bs/sqrt(s'*Bs),'-');
                        else
                            if debug
                                fprintf('Skipping Update\n');
                            end
                        end
                    end
                elseif qnUpdate == 1 % Perform SR1 Update if it maintains positive-definiteness

                    Bs = R'*(R*s);
                    ymBs = y-Bs;
                    if abs(s'*ymBs) >= norm(s)*norm(ymBs)*1e-8 && (s-((R\(R'\y))))'*y > 1e-10
                        R = cholupdate(R,-ymBs/sqrt(ymBs'*s),'-');
                    else
                        if debug
                            fprintf('SR1 not positive-definite, doing BFGS Update\n');
                        end
                        if Damped
                            eta = .02;
                            if y'*s < eta*s'*Bs
                                if debug
                                    fprintf('Damped Update\n');
                                end
                                theta = min(max(0,((1-eta)*s'*Bs)/(s'*Bs - y'*s)),1);
                                y = theta*y + (1-theta)*Bs;
                            end
                            R = cholupdate(cholupdate(R,y/sqrt(y'*s)),Bs/sqrt(s'*Bs),'-');
                        else
                            if y'*s > 1e-10
                                R = cholupdate(cholupdate(R,y/sqrt(y'*s)),Bs/sqrt(s'*Bs),'-');
                            else
                                if debug
                                    fprintf('Skipping Update\n');
                                end
                            end
                        end
                    end
                elseif qnUpdate == 2 % Use Hoshino update
                    v = sqrt(y'*H*y)*(s/(s'*y) - (H*y)/(y'*H*y));
                    phi = 1/(1 + (y'*H*y)/(s'*y));
                    H = H + (s*s')/(s'*y) - (H*y*y'*H)/(y'*H*y) + phi*v*v';

                elseif qnUpdate == 3 % Self-Scaling BFGS update
                    ys = y'*s;
                    Hy = H*y;
                    yHy = y'*Hy;
                    gamma = ys/yHy;
                    v = sqrt(yHy)*(s/ys - Hy/yHy);
                    H = gamma*(H - Hy*Hy'/yHy + v*v') + (s*s')/ys;
                elseif qnUpdate == 4 % Oren's Self-Scaling Variable Metric update

                    % Oren's method
                    if (s'*y)/(y'*H*y) > 1
                        phi = 1; % BFGS
                        omega = 0;
                    elseif (s'*(H\s))/(s'*y) < 1
                        phi = 0; % DFP
                        omega = 1;
                    else
                        phi = (s'*y)*(y'*H*y-s'*y)/((s'*(H\s))*(y'*H*y)-(s'*y)^2);
                        omega = phi;
                    end

                    gamma = (1-omega)*(s'*y)/(y'*H*y) + omega*(s'*(H\s))/(s'*y);
                    v = sqrt(y'*H*y)*(s/(s'*y) - (H*y)/(y'*H*y));
                    H = gamma*(H - (H*y*y'*H)/(y'*H*y) + phi*v*v') + (s*s')/(s'*y);

                elseif qnUpdate == 5 % McCormick-Huang asymmetric update
                    theta = 1;
                    phi = 0;
                    psi = 1;
                    omega = 0;
                    t1 = s*(theta*s + phi*H'*y)';
                    t2 = (theta*s + phi*H'*y)'*y;
                    t3 = H*y*(psi*s + omega*H'*y)';
                    t4 = (psi*s + omega*H'*y)'*y;
                    H = H + t1/t2 - t3/t4;
                end

                if qnUpdate <= 1
                    d = -R\(R'\g);
                else
                    d = -H*g;
                end

            end
            g_old = g;

        case NEWTON0 % Hessian-Free Newton

            cgMaxIter = min(p,maxFunEvals-funEvals);
            cgForce = min(0.5,sqrt(norm(g)))*norm(g);

            % Set-up preconditioner
            precondFunc = [];
            precondArgs = [];
            if cgSolve == 1
                if isempty(precFunc) % Apply L-BFGS preconditioner
                    if i == 1
                        old_dirs = zeros(length(g),0);
                        old_stps = zeros(length(g),0);
                        Hdiag = 1;
                    else
                        [old_dirs,old_stps,Hdiag] = lbfgsUpdate(g-g_old,t*d,corrections,debug,old_dirs,old_stps,Hdiag);
                        if useMex
                            precondFunc = @lbfgsC;
                        else
                            precondFunc = @lbfgs;
                        end
                        precondArgs = {old_dirs,old_stps,Hdiag};
                    end
                    g_old = g;
                else
                    % Apply user-defined preconditioner
                    precondFunc = precFunc;
                    precondArgs = {x,varargin{:}};
                end
            end

            % Solve Newton system using cg and hessian-vector products
            if isempty(HvFunc)
                % No user-supplied Hessian-vector function,
                % use automatic differentiation
                HvFun = @autoHv;
                HvArgs = {x,g,useComplex,funObj,varargin{:}};
            else
                % Use user-supplid Hessian-vector function
                HvFun = HvFunc;
                HvArgs = {x,varargin{:}};
            end

            if useNegCurv
                [d,cgIter,cgRes,negCurv] = conjGrad([],-g,cgForce,cgMaxIter,debug,precondFunc,precondArgs,HvFun,HvArgs);
            else
                [d,cgIter,cgRes] = conjGrad([],-g,cgForce,cgMaxIter,debug,precondFunc,precondArgs,HvFun,HvArgs);
            end

            funEvals = funEvals+cgIter;
            if debug
                fprintf('newtonCG stopped on iteration %d w/ residual %.5e\n',cgIter,cgRes);

            end

            if useNegCurv
                if ~isempty(negCurv)
                    %if debug
                    fprintf('Using negative curvature direction\n');
                    %end
                    d = negCurv/norm(negCurv);
                    d = d/sum(abs(g));
                end
            end

        case NEWTON % Newton search direction

            if cgSolve == 0
                if HessianModify == 0
                    % Attempt to perform a Cholesky factorization of the Hessian
                    [R,posDef] = chol(H);

                    % If the Cholesky factorization was successful, then the Hessian is
                    % positive definite, solve the system
                    if posDef == 0
                        d = -R\(R'\g);

                    else
                        % otherwise, adjust the Hessian to be positive definite based on the
                        % minimum eigenvalue, and solve with QR
                        % (expensive, we don't want to do this very much)
                        if debug
                            fprintf('Adjusting Hessian\n');
                        end
                        H = H + eye(length(g)) * max(0,1e-12 - min(real(eig(H))));
                        d = -H\g;
                    end
                elseif HessianModify == 1
                    % Modified Incomplete Cholesky
                    R = mcholinc(H,debug);
                    d = -R\(R'\g);
                elseif HessianModify == 2
                    % Modified Generalized Cholesky
                    if useMex
                        [L D perm] = mcholC(H);
                    else
                        [L D perm] = mchol(H);
                    end
                    d(perm) = -L' \ ((D.^-1).*(L \ g(perm)));

                elseif HessianModify == 3
                    % Modified Spectral Decomposition
                    [V,D] = eig((H+H')/2);
                    D = diag(D);
                    D = max(abs(D),max(max(abs(D)),1)*1e-12);
                    d = -V*((V'*g)./D);
                elseif HessianModify == 4
                    % Modified Symmetric Indefinite Factorization
                    [L,D,perm] = ldl(H,'vector');
                    [blockPos junk] = find(triu(D,1));
                    for diagInd = setdiff(setdiff(1:p,blockPos),blockPos+1)
                        if D(diagInd,diagInd) < 1e-12
                            D(diagInd,diagInd) = 1e-12;
                        end
                    end
                    for blockInd = blockPos'
                        block = D(blockInd:blockInd+1,blockInd:blockInd+1);
                        block_a = block(1);
                        block_b = block(2);
                        block_d = block(4);
                        lambda = (block_a+block_d)/2 - sqrt(4*block_b^2 + (block_a - block_d)^2)/2;
                        D(blockInd:blockInd+1,blockInd:blockInd+1) = block+eye(2)*(lambda+1e-12);
                    end
                    d(perm) = -L' \ (D \ (L \ g(perm)));
                else
                    % Take Newton step if Hessian is pd,
                    % otherwise take a step with negative curvature
                    [R,posDef] = chol(H);
                    if posDef == 0
                        d = -R\(R'\g);
                    else
                        if debug
                            fprintf('Taking Direction of Negative Curvature\n');
                        end
                        [V,D] = eig(H);
                        u = V(:,1);
                        d = -sign(u'*g)*u;
                    end
                end

            else
                % Solve with Conjugate Gradient
                cgMaxIter = p;
                cgForce = min(0.5,sqrt(norm(g)))*norm(g);

                % Select Preconditioner
                if cgSolve == 1
                    % No preconditioner
                    precondFunc = [];
                    precondArgs = [];
                elseif cgSolve == 2
                    % Diagonal preconditioner
                    precDiag = diag(H);
                    precDiag(precDiag < 1e-12) = 1e-12 - min(precDiag);
                    precondFunc = @precondDiag;
                    precondArgs = {precDiag.^-1};
                elseif cgSolve == 3
                    % L-BFGS preconditioner
                    if i == 1
                        old_dirs = zeros(length(g),0);
                        old_stps = zeros(length(g),0);
                        Hdiag = 1;
                    else
                        [old_dirs,old_stps,Hdiag] = lbfgsUpdate(g-g_old,t*d,corrections,debug,old_dirs,old_stps,Hdiag);
                    end
                    g_old = g;
                    if useMex
                        precondFunc = @lbfgsC;
                    else
                        precondFunc = @lbfgs;
                    end
                    precondArgs = {old_dirs,old_stps,Hdiag};
                elseif cgSolve > 0
                    % Symmetric Successive Overelaxation Preconditioner
                    omega = cgSolve;
                    D = diag(H);
                    D(D < 1e-12) = 1e-12 - min(D);
                    precDiag = (omega/(2-omega))*D.^-1;
                    precTriu = diag(D/omega) + triu(H,1);
                    precondFunc = @precondTriuDiag;
                    precondArgs = {precTriu,precDiag.^-1};
                else
                    % Incomplete Cholesky Preconditioner
                    opts.droptol = -cgSolve;
                    opts.rdiag = 1;
                    R = cholinc(sparse(H),opts);
                    if min(diag(R)) < 1e-12
                        R = cholinc(sparse(H + eye*(1e-12 - min(diag(R)))),opts);
                    end
                    precondFunc = @precondTriu;
                    precondArgs = {R};
                end

                % Run cg with the appropriate preconditioner
                if isempty(HvFunc)
                    % No user-supplied Hessian-vector function
                    [d,cgIter,cgRes] = conjGrad(H,-g,cgForce,cgMaxIter,debug,precondFunc,precondArgs);
                else
                    % Use user-supplied Hessian-vector function
                    [d,cgIter,cgRes] = conjGrad(H,-g,cgForce,cgMaxIter,debug,precondFunc,precondArgs,HvFunc,{x,varargin{:}});
                end
                if debug
                    fprintf('CG stopped after %d iterations w/ residual %.5e\n',cgIter,cgRes);
                    %funEvals = funEvals + cgIter;
                end
            end

        case TENSOR % Tensor Method

            if numDiff
                % Compute 3rd-order Tensor Numerically
                [junk1 junk2 junk3 T] = autoTensor(x,useComplex,funObj,varargin{:});
            else
                % Use user-supplied 3rd-derivative Tensor
                [junk1 junk2 junk3 T] = feval(funObj, x, varargin{:});
            end
            options_sub.Method = 'newton';
            options_sub.Display = 'none';
            options_sub.TolX = tolX;
            options_sub.TolFun = tolFun;
            d = minFunc(@taylorModel,zeros(p,1),options_sub,f,g,H,T);

            if any(abs(d) > 1e5) || all(abs(d) < 1e-5) || g'*d > -tolX
                if debug
                    fprintf('Using 2nd-Order Step\n');
                end
                [V,D] = eig((H+H')/2);
                D = diag(D);
                D = max(abs(D),max(max(abs(D)),1)*1e-12);
                d = -V*((V'*g)./D);
            else
                if debug
                    fprintf('Using 3rd-Order Step\n');
                end
            end
    end

    if ~isLegal(d)
        fprintf('Step direction is illegal!\n');
        pause;
        return
    end

    % ****************** COMPUTE STEP LENGTH ************************

    % Directional Derivative
    gtd = g'*d;

    % Check that progress can be made along direction
    if gtd > -tolX
        exitflag=2;
        msg = 'Directional Derivative below TolX';
        break;
    end

    % Select Initial Guess
    if i == 1
        if method < NEWTON0
            t = min(1,1/sum(abs(g)));
        else
            t = 1;
        end
    else
        if LS_init == 0
            % Newton step
            t = 1;
        elseif LS_init == 1
            % Close to previous step length
            t = t*min(2,(gtd_old)/(gtd));
        elseif LS_init == 2
            % Quadratic Initialization based on {f,g} and previous f
            t = min(1,2*(f-f_old)/(gtd));
        elseif LS_init == 3
            % Double previous step length
            t = min(1,t*2);
        elseif LS_init == 4
            % Scaled step length if possible
            if isempty(HvFunc)
                % No user-supplied Hessian-vector function,
                % use automatic differentiation
                dHd = d'*autoHv(d,x,g,0,funObj,varargin{:});
            else
                % Use user-supplid Hessian-vector function
                dHd = d'*HvFunc(d,x,varargin{:});
            end

            funEvals = funEvals + 1;
            if dHd > 0
                t = -gtd/(dHd);
            else
                t = min(1,2*(f-f_old)/(gtd));
            end
        end

        if t <= 0
            t = 1;
        end
    end
    f_old = f;
    gtd_old = gtd;

    % Compute reference fr if using non-monotone objective
    if Fref == 1
        fr = f;
    else
        if i == 1
            old_fvals = repmat(-inf,[Fref 1]);
        end

        if i <= Fref
            old_fvals(i) = f;
        else
            old_fvals = [old_fvals(2:end);f];
        end
        fr = max(old_fvals);
    end

    computeHessian = 0;
    if method >= NEWTON
        if HessianIter == 1
            computeHessian = 1;
        elseif i > 1 && mod(i-1,HessianIter) == 0
            computeHessian = 1;
        end
    end

    % Line Search
    f_old = f;
    if LS < 3 % Use Armijo Bactracking
        % Perform Backtracking line search
        if computeHessian
            [t,x,f,g,LSfunEvals,H] = ArmijoBacktrack(x,t,d,f,fr,g,gtd,c1,LS,tolX,debug,doPlot,LS_saveHessianComp,funObj,varargin{:});
        else
            [t,x,f,g,LSfunEvals] = ArmijoBacktrack(x,t,d,f,fr,g,gtd,c1,LS,tolX,debug,doPlot,1,funObj,varargin{:});
        end
        funEvals = funEvals + LSfunEvals;

    elseif LS < 6
        % Find Point satisfying Wolfe

        if computeHessian
            [t,f,g,LSfunEvals,H] = WolfeLineSearch(x,t,d,f,g,gtd,c1,c2,LS,25,tolX,debug,doPlot,LS_saveHessianComp,funObj,varargin{:});
        else
            [t,f,g,LSfunEvals] = WolfeLineSearch(x,t,d,f,g,gtd,c1,c2,LS,25,tolX,debug,doPlot,1,funObj,varargin{:});
        end
        funEvals = funEvals + LSfunEvals;
        x = x + t*d;

    else
        % Use Matlab optim toolbox line search
        [t,f_new,fPrime_new,g_new,LSexitFlag,LSiter]=...
            lineSearch({'fungrad',[],funObj},x,p,1,p,d,f,gtd,t,c1,c2,-inf,maxFunEvals-funEvals,...
            tolX,[],[],[],varargin{:});
        funEvals = funEvals + LSiter;
        if isempty(t)
            exitflag = -2;
            msg = 'Matlab LineSearch failed';
            break;
        end

        if method >= NEWTON
            [f_new,g_new,H] = funObj(x + t*d,varargin{:});
            funEvals = funEvals + 1;
        end
        x = x + t*d;
        f = f_new;
        g = g_new;
    end

    % Output iteration information
    if verboseI
        fprintf('%10d %10d %15.5e %15.5e %15.5e\n',i,funEvals*funEvalMultiplier,t,f,sum(abs(g)));
    end

    if logfile
        fid = fopen(logfile, 'a');
        if (fid > 0)
            fprintf(fid, '-- %10d %10d %15.5e %15.5e %15.5e\n',i,funEvals*funEvalMultiplier,t,f,sum(abs(g)));
            fclose(fid);
        end
    end

    % Output Function
    if ~isempty(outputFcn)
        callOutput(outputFcn,x,'iter',i,funEvals,f,t,gtd,g,d,sum(abs(g)),varargin{:});
    end

    % Update Trace
    trace.fval(end+1,1) = f;
    trace.funcCount(end+1,1) = funEvals;

    % Check Optimality Condition
    if sum(abs(g)) <= tolFun
        exitflag=1;
        msg = 'Optimality Condition below TolFun';
        break;
    end

    % ******************* Check for lack of progress *******************

    if sum(abs(t*d)) <= tolX
        exitflag=2;
        msg = 'Step Size below TolX';
        break;
    end

    if abs(f-f_old) < tolX
        exitflag=2;
        msg = 'Function Value changing by less than TolX';
        break;
    end

    % ******** Check for going over iteration/evaluation limit *******************

    if funEvals*funEvalMultiplier > maxFunEvals
        exitflag = 0;
        msg = 'Exceeded Maximum Number of Function Evaluations';
        break;
    end

    if i == maxIter
        exitflag = 0;
        msg='Exceeded Maximum Number of Iterations';
        break;
    end

end

if verbose
    fprintf('%s\n',msg);
end
if nargout > 3
    output = struct('iterations',i,'funcCount',funEvals*funEvalMultiplier,...
        'algorithm',method,'firstorderopt',sum(abs(g)),'message',msg,'trace',trace);
end

% Output Function
if ~isempty(outputFcn)
    callOutput(outputFcn,x,'done',i,funEvals,f,t,gtd,g,d,sum(abs(g)),varargin{:});
end

end


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: lda_exc *)

$define lda_x_params
$include "lda_x.mpl"
$include "attenuation.mpl"

a_cnst := (4/(9*Pi))^(1/3)*p_a_hyb_omega_0_/2:

lda_x_ax := -RS_FACTOR*X_FACTOR_C/2^(4/3):
lda_x_erf_spin := (rs, z) ->
  lda_x_ax*opz_pow_n(z,4/3)/rs * attenuation_erf(a_cnst*rs/opz_pow_n(z,1/3)):

f_lda_x_erf := (rs, z) -> lda_x_erf_spin(rs, z) + lda_x_erf_spin(rs, -z):

f := (rs, z) -> f_lda_x_erf(rs, z):


`permutation_matrix` := proc(s)
  local n,g,i;

  n := nops(s);
  g := Matrix(n,n);
  for i from 1 to n do
   g[s[i],i] := 1;
  od:
  return g;
end:

`elementary_matrix/D` := (n) -> proc(i,a)
  local g,k;
  g := Matrix(n,n);
  for k from 1 to n do g[k,k] := 1; od;
  g[i,i] := a;
  return g;
end:

`elementary_matrix/E` := (n) -> proc(i,j,a_)
  local g,k;
  g := Matrix(n,n);
  for k from 1 to n do g[k,k] := 1; od;
  g[i,j] := `if`(nargs > 2,a_,1);
  return g;
end:

`elementary_matrix/F` := (n) -> proc(i,j)
  local g,k;
  g := Matrix(n,n);
  for k from 1 to n do g[k,k] := 1; od;
  g[i,i] := 0; g[j,j] := 0;
  g[i,j] := 1; g[j,i] := 1;
  return g;
end:

make_general_linear := proc(n,p)
  local G,i,j,k,m,g,L,f;

  m := n^2;

  G := table():
  G["p"] := p;
  G["id"] := IdentityMatrix(n);
  G["o"] := (g,h) -> map(mods,g . h,G["p"]);
  G["inv"] := g -> map(mods,1/g,G["p"]);
  G["order"] := mul(p^n - p^i,i = 0..n-1);

  L := [[]];
  for i from 1 to m do
   L := [seq(seq([op(u),j],j=0..p-1),u in L)];
  od:

  f := proc(u)
   local i,j,k,g;
   g := Matrix(n,n);
   k := 1;
   for i from 1 to n do
    for j from 1 to n do
     g[i,j] := mods(u[k],p); k := k + 1;
    od:
   od:
   if mods(Determinant(g),p) <> 0 then
    return g;
   else
    return NULL;
   fi;
  end:

  G["elements"] := map(f,L);

  return eval(G);
end:

bruhat_permutation := (n,p) -> proc(g)
 local h,i,j,k,a,q,qi;

 if [Dimension(g)] <> [n,n] then
  error("Not an n x n matrix");
 fi;

 h := eval(g);
 q := [];
 for i from n to 1 by -1 do
  j := 1;
  while h[i,j] = 0 do j := j+1; od;
  q := [j,op(q)];
  a := mods(1/h[i,j],p);
  h := map(mods,`elementary_matrix/D`(n)(i,a) . h,p);
  for k from 1 to i-1 do
   h := map(mods,`elementary_matrix/E`(n)(k,i,-h[k,j]) . h,p);
  od;
 od;
 qi := table():
 for i from 1 to n do qi[q[i]] := i; od:

 return([seq(qi[i],i=1..n)]);
end:

# This returns a triple [b,w,c] where b is upper triangular,
# w is a permutation matrix, c is upper unitriangular and g = bwc.

bruhat_decomposition := (n,p) -> proc(g)
 local h,i,j,k,a,b,c,x,q,w;

 if [Dimension(g)] <> [n,n] then
  error("Not an n x n matrix");
 fi;

 h := eval(g);
 q := [];
 b := Matrix(n,n);
 for k from 1 to n do b[k,k] := 1; od:

 for i from n to 1 by -1 do
  j := 1;
  while h[i,j] = 0 do j := j+1; od;
  q := [j,op(q)];
  x := mods(1/h[i,j],p);
  b := map(mods, b . `elementary_matrix/D`(n)(i,h[i,j]),p);
  h := map(mods, `elementary_matrix/D`(n)(i,x) . h,p);
  for k from 1 to i-1 do
   b := map(mods,b . `elementary_matrix/E`(n)(k,i,h[k,j]),p);
   h := map(mods,`elementary_matrix/E`(n)(k,i,-h[k,j]) . h,p);
  od;
 od;
 w := permutation_matrix(q);
 c := w . h;
 return([b,Transpose(w),c]);
end:


HagerZhang := module()

  description "HagerZhang";

  # Module defined as a package (i.e.) collection of procedures
  option package, load = ModuleLoad, unload = ModuleUnLoad;

  export lines, linesearch, esatta, AB_list, doplot, doplot2;

  local ModuleLoad,
        ModuleUnLoad,
        _debug,
        FINAL, ITER, PARAMETERS, GRADIENT, SEARCHDIR,
        ALPHA, BETA, BRACKET, LINESEARCH, UPDATE, SECANT2,
        BISECT, BARRIERCOEF, DEFAULTDELTA, DEFAULTSIGMA,
        max_iter, A_list, B_list;

  uses LinearAlgebra;

  ModuleUnLoad := proc()
    printf("HagerZhang unload\n");
    NULL;
  end proc:

  ModuleLoad := proc()
    printf("HagerZhang load\n");
    _debug   := true;
    # Display flags are represented as a bitfield
    FINAL       := 1;
    ITER        := 2;
    PARAMETERS  := 8;
    GRADIENT    := 16;
    SEARCHDIR   := 32;
    ALPHA       := 64;
    BETA        := 128;
    BRACKET     := 256;
    LINESEARCH  := 512;
    UPDATE      := 1024;
    SECANT2     := 2048;
    BISECT      := 4096;
    BARRIERCOEF := 8192;

    DEFAULTDELTA := 0.1; # Values taken from HZ paper (Nocedal & Wright recommends 0.01?)
    DEFAULTSIGMA := 0.9; # Values taken from HZ paper (Nocedal & Wright recommends 0.1 for GradientDescent)

    max_iter    := 40;
    NULL;
  end proc;

  # Explicitly call ModuleLoad here so the type is registered when this
  # code is cut&pasted in.  ModuleLoad gets called when the module is
  # read from the repository, but the code used to define a module
  # (like the command below) is not called at library read time.
  ModuleLoad();

  AB_list := proc()
    A_list, B_list;
  end proc;

  min_quadratic := proc ( a, fa, Dfa, b, fb )
    local t, delta; # A+B*(x-a)+C*(x-a)^2
    # p  = fa + Dfa*(x-a)+t*(x-a)^2
    # p' = Dfa+2*t*(x-a)
    ##t     := ((fb-fa)/(b-a)-Dfa)/(b-a);
    ##delta := -Dfa/(2*t);
    t     := (fb-fa)/(b-a)-Dfa;
    delta := max(tau1,min(1-tau1,-Dfa/(2*t)));
    a+(b-a)*delta;
  end proc;

  lines := proc( f0, df0, L )
    [ [0,f0], [L,f0+L*rho*df0] ], [ [0,f0], [L,f0+L*sigma*df0] ];
  end proc;

  #
  # Conjugate gradient line search implementation from:
  #   W. W. Hager and H. Zhang (2006) Algorithm 851: CG_DESCENT, a
  #     conjugate gradient method with guaranteed descent. ACM
  #     Transactions on Mathematical Software 32: 113–137.
  #
  # Code comments such as "HZ, stage X" or "HZ, eqs Y" are with
  # reference to a particular point in this paper.
  #
  # There are some modifications and/or extensions from what's in the
  # paper (these may or may not be extensions of the cg_descent code
  # that can be downloaded from Hager's site; his code has undergone
  # numerous revisions since publication of the paper):
  # linesearch: the Wolfe conditions are checked only after alpha is
  #   generated either by quadratic interpolation or secant
  #   interpolation, not when alpha is generated by bisection or
  #   expansion. This increases the likelihood that alpha will be a
  #   good approximation of the minimum.
  #
  # linesearch: In step I2, we multiply by psi2 only if the convexity
  #   test failed, not if the function-value test failed. This
  #   prevents one from going uphill further when you already know
  #   you're already higher than the point at alpha=0.
  #
  # both: checks for Inf/NaN function values
  #
  # both: support maximum value of alpha (equivalently, c). This
  #   facilitates using these routines for constrained minimization
  #   when you can calculate the distance along the path to the
  #   disallowed region. (When you can't easily calculate that
  #   distance, it can still be handled by returning Inf/NaN for
  #   exterior points. It's just more efficient if you know the
  #   maximum, because you don't have to test values that won't
  #   work.) The maximum should be specified as the largest value for
  #   which a finite value will be returned.  See, e.g., limits_box
  #   below.  The default value for alphamax is Inf. See alphamaxfunc
  #   for cgdescent and alphamax for HagerZhang.

  #const DEFAULTDELTA = 0.1 # Values taken from HZ paper (Nocedal & Wright recommends 0.01?)
  #const DEFAULTSIGMA = 0.9 # Values taken from HZ paper (Nocedal & Wright recommends 0.1 for GradientDescent)

  # NOTE:
  #   [1] The type `T` in the `HagerZhang{T}` need not be the same `T` as in
  #       `hagerzhang!{T}`; in the latter, `T` comes from the input vector `x`.
  #   [2] the only method parameter that is not included in the
  #       type is `iterfinitemax` since this value needs to be
  #       inferred from the input vector `x` and not from the type information
  #       on the parameters
  #
  # Conjugate gradient line search implementation from:
  # W. W. Hager and H. Zhang (2006) Algorithm 851: CG_DESCENT, a
  # conjugate gradient method with guaranteed descent. ACM
  # Transactions on Mathematical Software 32: 113–137.

  # TODO: Should we deprecate the interface that only uses the phi and phid\phi arguments?
  linesearch := proc( phi, dphi, c, phi_0, dphi_0 )
    local delta, sigma, alphamax, rho, epsilon, gamma,
          linesearchmax, psi3, display, mayterminate;

    if not (isfinite(phi_0) and isfinite(dphi_0)) then
       error("Value and slope at step length = 0 must be finite.");
    end;
    if dphi_0 >= eps * abs(phi_0) then
      error("Search direction is not a descent direction.");
    elif dphi_0 >= 0 then
      return 0, phi_0
    end

    # Prevent values of x_new = x+αs that are likely to make
    # phi(x_new) infinite
    iterfinitemax::Int = ceil(Int, -log2(eps(T)))
    alphas = [0] # for bisection
    values = [phi_0]
    slopes = [dphi_0]
    if display and LINESEARCH > 0 then
      println("New linesearch\n");
    end

    phi_lim = phi_0 + epsilon * abs(phi_0);
    @assert c >= 0
    c <= eps(T) && return zeroT, phi_0
    @assert isfinite(c) && c <= alphamax
    phi_c, dphi_c = phidphi(c)
    iterfinite = 1
    while !(isfinite(phi_c) && isfinite(dphi_c)) && iterfinite < iterfinitemax
        mayterminate[] = false
        iterfinite += 1
        c *= psi3
        phi_c, dphi_c = phidphi(c)
    end
    if !(isfinite(phi_c) && isfinite(dphi_c))
        @warn("Failed to achieve finite new evaluation point, using alpha=0")
        mayterminate[] = false # reset in case another initial guess is used next
        return zeroT, phi_0
    end
    push!(alphas, c)
    push!(values, phi_c)
    push!(slopes, dphi_c)

    # If c was generated by quadratic interpolation, check whether it
    # satisfies the Wolfe conditions
    if mayterminate[] &&
          satisfies_wolfe(c, phi_c, dphi_c, phi_0, dphi_0, phi_lim, delta, sigma)
        if display & LINESEARCH > 0
            println("Wolfe condition satisfied on point alpha = ", c)
        end
        mayterminate[] = false # reset in case another initial guess is used next
        return c, phi_c # phi_c
    end
    # Initial bracketing step (HZ, stages B0-B3)
    isbracketed = false
    ia = 1
    ib = 2
    @assert length(alphas) == 2
    iter = 1
    cold = -one(T)
    while !isbracketed && iter < linesearchmax
        if display & BRACKET > 0
            println("bracketing: ia = ", ia,
                    ", ib = ", ib,
                    ", c = ", c,
                    ", phi_c = ", phi_c,
                    ", dphi_c = ", dphi_c)
        end
        if dphi_c >= zeroT
            # We've reached the upward slope, so we have b; examine
            # previous values to find a
            ib = length(alphas)
            for i = (ib - 1):-1:1
                if values[i] <= phi_lim
                    ia = i
                    break
                end
            end
            isbracketed = true
        elseif values[end] > phi_lim
            # The value is higher, but the slope is downward, so we must
            # have crested over the peak. Use bisection.
            ib = length(alphas)
            ia = 1
            if c ≉  alphas[ib] || slopes[ib] >= zeroT
                error("c = ", c)
            end
            # ia, ib = bisect(phi, lsr, ia, ib, phi_lim) # TODO: Pass options
            ia, ib = bisect!(phidphi, alphas, values, slopes, ia, ib, phi_lim, display)
            isbracketed = true
        else
            # We'll still going downhill, expand the interval and try again.
            # Reaching this branch means that dphi_c < 0 and phi_c <= phi_0 + ϵ_k
            # So cold = c has a lower objective than phi_0 up to epsilon.
            # This makes it a viable step to return if bracketing fails.

            # Bracketing can fail if no cold < c <= alphamax can be found with finite phi_c and dphi_c.
            # Going back to the loop with c = cold will only result in infinite cycling.
            # So returning (cold, phi_cold) and exiting the line search is the best move.
            cold = c
            phi_cold = phi_c
            if nextfloat(cold) >= alphamax
                mayterminate[] = false # reset in case another initial guess is used next
                return cold, phi_cold
            end
            c *= rho
            if c > alphamax
                c = alphamax
                if display & BRACKET > 0
                    println("bracket: exceeding alphamax, using c = alphamax = ", alphamax,
                    ", cold = ", cold)
                end
            end
            phi_c, dphi_c = phidphi(c)
            iterfinite = 1
            while !(isfinite(phi_c) && isfinite(dphi_c)) && c > nextfloat(cold) && iterfinite < iterfinitemax
                alphamax = c # shrinks alphamax, assumes that steps >= c can never have finite phi_c and dphi_c
                iterfinite += 1
                if display & BRACKET > 0
                    println("bracket: non-finite value, bisection")
                end
                c = (cold + c) / 2
                phi_c, dphi_c = phidphi(c)
            end
            if !(isfinite(phi_c) && isfinite(dphi_c))
                if display & BRACKET > 0
                    println("Warning: failed to expand interval to bracket with finite values. If this happens frequently, check your function and gradient.")
                    println("c = ", c,
                            ", alphamax = ", alphamax,
                            ", phi_c = ", phi_c,
                            ", dphi_c = ", dphi_c)
                end
                return cold, phi_cold
            end
            push!(alphas, c)
            push!(values, phi_c)
            push!(slopes, dphi_c)
        end
        iter += 1
    end
    while iter < linesearchmax
        a = alphas[ia]
        b = alphas[ib]
        @assert b > a
        if display & LINESEARCH > 0
            println("linesearch: ia = ", ia,
                    ", ib = ", ib,
                    ", a = ", a,
                    ", b = ", b,
                    ", phi(a) = ", values[ia],
                    ", phi(b) = ", values[ib])
        end
        if b - a <= eps(b)
            mayterminate[] = false # reset in case another initial guess is used next
            return a, values[ia] # lsr.value[ia]
        end
        iswolfe, iA, iB = secant2!(phidphi, alphas, values, slopes, ia, ib, phi_lim, delta, sigma, display)
        if iswolfe
            mayterminate[] = false # reset in case another initial guess is used next
            return alphas[iA], values[iA] # lsr.value[iA]
        end
        A = alphas[iA]
        B = alphas[iB]
        @assert B > A
        if B - A < gamma * (b - a)
            if display & LINESEARCH > 0
                println("Linesearch: secant succeeded")
            end
            if nextfloat(values[ia]) >= values[ib] && nextfloat(values[iA]) >= values[iB]
                # It's so flat, secant didn't do anything useful, time to quit
                if display & LINESEARCH > 0
                    println("Linesearch: secant suggests it's flat")
                end
                mayterminate[] = false # reset in case another initial guess is used next
                return A, values[iA]
            end
            ia = iA
            ib = iB
        else
            # Secant is converging too slowly, use bisection
            if display & LINESEARCH > 0
                println("Linesearch: secant failed, using bisection")
            end
            c = (A + B) / convert(T, 2)

            phi_c, dphi_c = phidphi(c)
            @assert isfinite(phi_c) && isfinite(dphi_c)
            push!(alphas, c)
            push!(values, phi_c)
            push!(slopes, dphi_c)

            ia, ib = update!(phidphi, alphas, values, slopes, iA, iB, length(alphas), phi_lim, display)
        end
        iter += 1
    end

    throw(LineSearchException("Linesearch failed to converge, reached maximum iterations $(linesearchmax).",
                              alphas[ia]))

end

# Check Wolfe & approximate Wolfe
function satisfies_wolfe(c::T,
                         phi_c::Real,
                         dphi_c::Real,
                         phi_0::Real,
                         dphi_0::Real,
                         phi_lim::Real,
                         delta::Real,
                         sigma::Real) where T<:Number
    wolfe1 = delta * dphi_0 >= (phi_c - phi_0) / c &&
               dphi_c >= sigma * dphi_0
    wolfe2 = (2 * delta - 1) * dphi_0 >= dphi_c >= sigma * dphi_0 &&
               phi_c <= phi_lim
    return wolfe1 || wolfe2
end

# HZ, stages S1-S4
function secant(a::Real, b::Real, dphi_a::Real, dphi_b::Real)
    return (a * dphi_b - b * dphi_a) / (dphi_b - dphi_a)
end
function secant(alphas, values, slopes, ia::Integer, ib::Integer)
    return secant(alphas[ia], alphas[ib], slopes[ia], slopes[ib])
end
# phi
function secant2!(phidphi,
                  alphas,
                  values,
                  slopes,
                  ia::Integer,
                  ib::Integer,
                  phi_lim::Real,
                  delta::Real = DEFAULTDELTA,
                  sigma::Real = DEFAULTSIGMA,
                  display::Integer = 0)
    phi_0 = values[1]
    dphi_0 = slopes[1]
    a = alphas[ia]
    b = alphas[ib]
    dphi_a = slopes[ia]
    dphi_b = slopes[ib]
    T = eltype(slopes)
    zeroT = convert(T, 0)
    if !(dphi_a < zeroT && dphi_b >= zeroT)
        error(string("Search direction is not a direction of descent; ",
                     "this error may indicate that user-provided derivatives are inaccurate. ",
                      @sprintf "(dphi_a = %f; dphi_b = %f)" dphi_a dphi_b))
    end
    c = secant(a, b, dphi_a, dphi_b)
    if display & SECANT2 > 0
        println("secant2: a = ", a, ", b = ", b, ", c = ", c)
    end
    @assert isfinite(c)
    # phi_c = phi(tmpc, c) # Replace
    phi_c, dphi_c = phidphi(c)
    @assert isfinite(phi_c) && isfinite(dphi_c)

    push!(alphas, c)
    push!(values, phi_c)
    push!(slopes, dphi_c)

    ic = length(alphas)
    if satisfies_wolfe(c, phi_c, dphi_c, phi_0, dphi_0, phi_lim, delta, sigma)
        if display & SECANT2 > 0
            println("secant2: first c satisfied Wolfe conditions")
        end
        return true, ic, ic
    end

    iA, iB = update!(phidphi, alphas, values, slopes, ia, ib, ic, phi_lim, display)
    if display & SECANT2 > 0
        println("secant2: iA = ", iA, ", iB = ", iB, ", ic = ", ic)
    end
    a = alphas[iA]
    b = alphas[iB]
    doupdate = false
    if iB == ic
        # we updated b, make sure we also update a
        c = secant(alphas, values, slopes, ib, iB)
    elseif iA == ic
        # we updated a, do it for b too
        c = secant(alphas, values, slopes, ia, iA)
    end
    if (iA == ic || iB == ic) && a <= c <= b
        if display & SECANT2 > 0
            println("secant2: second c = ", c)
        end
        # phi_c = phi(tmpc, c) # TODO: Replace
        phi_c, dphi_c = phidphi(c)
        @assert isfinite(phi_c) && isfinite(dphi_c)

        push!(alphas, c)
        push!(values, phi_c)
        push!(slopes, dphi_c)

        ic = length(alphas)
        # Check arguments here
        if satisfies_wolfe(c, phi_c, dphi_c, phi_0, dphi_0, phi_lim, delta, sigma)
            if display & SECANT2 > 0
                println("secant2: second c satisfied Wolfe conditions")
            end
            return true, ic, ic
        end
        iA, iB = update!(phidphi, alphas, values, slopes, iA, iB, ic, phi_lim, display)
    end
    if display & SECANT2 > 0
        println("secant2 output: a = ", alphas[iA], ", b = ", alphas[iB])
    end
    return false, iA, iB
end

# HZ, stages U0-U3
# Given a third point, pick the best two that retain the bracket
# around the minimum (as defined by HZ, eq. 29)
# b will be the upper bound, and a the lower bound
function update!(phidphi,
                 alphas,
                 values,
                 slopes,
                 ia::Integer,
                 ib::Integer,
                 ic::Integer,
                 phi_lim::Real,
                 display::Integer = 0)
    a = alphas[ia]
    b = alphas[ib]
    T = eltype(slopes)
    zeroT = convert(T, 0)
    # Debugging (HZ, eq. 4.4):
    @assert slopes[ia] < zeroT
    @assert values[ia] <= phi_lim
    @assert slopes[ib] >= zeroT
    @assert b > a
    c = alphas[ic]
    phi_c = values[ic]
    dphi_c = slopes[ic]
    if display & UPDATE > 0
        println("update: ia = ", ia,
                ", a = ", a,
                ", ib = ", ib,
                ", b = ", b,
                ", c = ", c,
                ", phi_c = ", phi_c,
                ", dphi_c = ", dphi_c)
    end
    if c < a || c > b
        return ia, ib #, 0, 0  # it's out of the bracketing interval
    end
    if dphi_c >= zeroT
        return ia, ic #, 0, 0  # replace b with a closer point
    end
    # We know dphi_c < 0. However, phi may not be monotonic between a
    # and c, so check that the value is also smaller than phi_0.  (It's
    # more dangerous to replace a than b, since we're leaving the
    # secure environment of alpha=0; that's why we didn't check this
    # above.)
    if phi_c <= phi_lim
        return ic, ib#, 0, 0  # replace a
    end
    # phi_c is bigger than phi_0, which implies that the minimum
    # lies between a and c. Find it via bisection.
    return bisect!(phidphi, alphas, values, slopes, ia, ic, phi_lim, display)
end

# HZ, stage U3 (with theta=0.5)
function bisect!(phidphi,
                 alphas::AbstractArray{T},
                 values,
                 slopes,
                 ia::Integer,
                 ib::Integer,
                 phi_lim::Real,
                 display::Integer = 0) where T
    gphi = convert(T, NaN)
    a = alphas[ia]
    b = alphas[ib]
    # Debugging (HZ, conditions shown following U3)
    zeroT = convert(T, 0)
    @assert slopes[ia] < zeroT
    @assert values[ia] <= phi_lim
    @assert slopes[ib] < zeroT       # otherwise we wouldn't be here
    @assert values[ib] > phi_lim
    @assert b > a
    while b - a > eps(b)
        if display & BISECT > 0
            println("bisect: a = ", a, ", b = ", b, ", b - a = ", b - a)
        end
        d = (a + b) / convert(T, 2)
        phi_d, gphi = phidphi(d)
        @assert isfinite(phi_d) && isfinite(gphi)

        push!(alphas, d)
        push!(values, phi_d)
        push!(slopes, gphi)

        id = length(alphas)
        if gphi >= zeroT
            return ia, id # replace b, return
        end
        if phi_d <= phi_lim
            a = d # replace a, but keep bisecting until dphi_b > 0
            ia = id
        else
            b = d
            ib = id
        end
    end
    return ia, ib
end
© 2021 GitHub, Inc.
Terms
Privacy
Security
Status
Docs
Contact GitHub
Pricing
API
Training
Blog
About
Loading complete

  esatta := proc( fun )
    local res, alpha;
    #res := Optimization[Minimize](
    res := Optimization[NLPSolve](
      fun(alpha),
      {alpha >= 0, alpha <= 3},
      #initialpoint={alpha=1},
      iterationlimit=50
    ):
    subs(res[2],alpha);
  end proc:

  doplot := proc( f_in, df_in, alpha, amax)
    local f0, df0, x, AA, BB, CC, DD;
    f0  := evalf(f_in(0));
    df0 := evalf(df_in(0));

    AA := plot(f_in(x),x=0..amax);
    BB := plot([[0,f0],[amax,f0+amax*rho*df0]],color="LimeGreen");
    CC := plot([[0,f0],[amax,f0+amax*sigma*df0]],color="blue");
    DD := plot([[alpha,f_in(alpha)]],color="red",style = point);
    display(AA,BB,CC,DD);
  end;

  doplot2 := proc( f_in, df_in, alpha, amax, A_list, B_list )
    local i, f0, df0, x, AA, BB, CC, DD, EE;
    f0  := evalf(f_in(0));
    df0 := evalf(df_in(0));

    AA := plot(f_in(x),x=0..amax);
    BB := plot([[0,f0],[amax,f0+amax*rho*df0]],color="LimeGreen");
    CC := plot([[0,f0],[amax,f0+amax*sigma*df0]],color="blue");
    DD := plot([[alpha,f_in(alpha)]],color="red",style = point);
    EE := plot([seq([[A_list[i],-i/5],[B_list[i],-i/5]],i=1..nops(A_list))],color="black");
    display(AA,BB,CC,DD,EE);
  end;

end module:


TITLE
    Invest4Scen;

INDEX
    invtype := (Stock, Bond) -> (S,B);

STOCHASTIC

STAGES
    period := 1..4;

SCENARIOS
    sc := 1..8;

TREE
    BINARY;

PROBABILITIES
    prob[sc] := ALLEQUAL;

RANDOM DATA
    Returns[invtype, period, sc] :=
      [Stock, 1, 1, 1.25,
       Stock, 1, 2, 1.25,
       Stock, 1, 3, 1.25,
       Stock, 1, 4, 1.25,
       Stock, 1, 5, 1.06,
       Stock, 1, 6, 1.06,
       Stock, 1, 7, 1.06,
       Stock, 1, 8, 1.06,
       Stock, 2, 1, 1.25,
       Stock, 2, 2, 1.25,
       Stock, 2, 3, 1.06,
       Stock, 2, 4, 1.06,
       Stock, 2, 5, 1.25,
       Stock, 2, 6, 1.25,
       Stock, 2, 7, 1.06,
       Stock, 2, 8, 1.06,
       Stock, 3, 1, 1.25,
       Stock, 3, 2, 1.06,
       Stock, 3, 3, 1.25,
       Stock, 3, 4, 1.06,
       Stock, 3, 5, 1.25,
       Stock, 3, 6, 1.06,
       Stock, 3, 7, 1.25,
       Stock, 3, 8, 1.06,
       Bond, 1, 1, 1.14,
       Bond, 1, 2, 1.14,
       Bond, 1, 3, 1.14,
       Bond, 1, 4, 1.14,
       Bond, 1, 5, 1.12,
       Bond, 1, 6, 1.12,
       Bond, 1, 7, 1.12,
       Bond, 1, 8, 1.12,
       Bond, 2, 1, 1.14,
       Bond, 2, 2, 1.14,
       Bond, 2, 3, 1.12,
       Bond, 2, 4, 1.12,
       Bond, 2, 5, 1.14,
       Bond, 2, 6, 1.14,
       Bond, 2, 7, 1.12,
       Bond, 2, 8, 1.12,
       Bond, 3, 1, 1.14,
       Bond, 3, 2, 1.12,
       Bond, 3, 3, 1.14,
       Bond, 3, 4, 1.12,
       Bond, 3, 5, 1.14,
       Bond, 3, 6, 1.12,
       Bond, 3, 7, 1.14,
       Bond, 3, 8, 1.12];

DATA
    InitialWealth = 55;
    Goal := 80;
    SurplusReward := 1;
    ShortPenalty  := 4;

VARIABLES
    Invest[period<LAST(period),invtype] -> x;

LASTSTAGE VARIABLES
    Shortage -> Sh;
    Excess -> Ex;

MODEL

   MAX obj = SurplusReward*Excess - ShortPenalty*Shortage;

SUBJECT TO

   InitInvest[period=1] -> InitInv:
       InitialWealth
     =
       SUM(invtype: Invest);

   InvestBal[period=2..LAST(period)-1] -> InvBal:
       SUM(invtype: Invest[period-1] * Returns[period-1])
     =
       SUM(invtype: Invest);

   EndInvest[period=LAST(period)] -> EndInv:
       SUM(invtype: Invest[period-1]* Returns[period-1])  + Shortage - Excess
     =
       Goal;

END


`is_element/E/subdiv` := (p::nonnegint,n::nonnegint,m::nonnegint) -> proc(theta)
 global reason;
 local tag,src,tgt,i,t;
 tag := "is_element/E/subdiv";

 if p = 0 then
  return evalb(n = m and theta = []);
 fi;

 if not(type(theta,list(list(nonnegint)))) then
  reason := [tag,"theta is not a list of lists of natural numbers",theta];
  return false;
 fi;

 if nops(theta) <> p then
  reason := [tag,"theta is not a list of length p",theta,p];
  return false;
 fi;

 tgt := NULL;
 for i from 1 to p do
  if theta[i] = [] then
   reason := [tag,"theta[i] is empty",theta,i];
   return false;
  fi;
  t := max(op(theta[i]));
  if {op(theta[i])} <> {seq(j,j=0..t)} then
   reason := [tag,"theta[i] does not give an epimorphism",theta,i,t];
   return false;
  fi;
  tgt := tgt,t;
 od:
 tgt := [tgt];

 src := map(nops,theta) -~ 1;

 if src[1] <> n then
  reason := [tag,"chain does not start with [n]",theta,src,n];
  return false;
 fi;

 if tgt[p] <> m then
  reason := [tag,"chain does not end with [m]",theta,tgt,m];
  return false;
 fi;

 if [op(src),m] <> [n,op(tgt)] then
  reason := [tag,"sources and targets do not match",theta,src,tgt,n,m];
  return false;
 fi;

 return true;
end:

`is_leq/E/subdiv` := NULL;

`list_elements/E/subdiv/aux` := proc(n::nonnegint,m::nonnegint)
 option remember;
 local N,M,E;

 N := {seq(i,i=0..n)};
 M := {seq(i,i=0..m)};
 E := `list_elements/epi`(N,M);
 E := map(f -> [seq(f[i],i=0..n)],E);
 return E;
end:

`list_elements/E/subdiv` := proc(p::nonnegint,n::nonnegint,m::nonnegint)
 option remember;
 local L,k,E0,E1;

 if p = 0 then
  if n = m then
   return [[]];
  else
   return [];
  fi;
 else
  L := NULL;
  for k from m to n do
   E0 := `list_elements/E/subdiv`(p-1,n,k);
   E1 := `list_elements/E/subdiv/aux`(k,m);
   L := L,seq(seq([op(e0),e1],e1 in E1),e0 in E0);
  od:
 fi;
 return [L];
end:

`random_element/E/subdiv` := (p::nonnegint,n::nonnegint,m::nonnegint) -> proc()
 local k,q,f,g;

 if m > n then
  return FAIL;
 fi;

 if p = 0 then
  if m = n then
   return [];
  else
   return FAIL;
  fi;
 elif p = 1 then
  g := `random_element/epi`({seq(j,j=0..n)},{seq(j,j=0..m)})();
  return [[seq(g[j],j=0..n)]];
 else
  k := rand(m..n)();
  q := rand(1..p-1)();
  f := `random_element/E/subdiv`(q,n,k)();
  g := `random_element/E/subdiv`(p-q,k,m)();
  return [op(f),op(g)];
 fi;
end:

`count_elements/E/subdiv` := proc(p::nonnegint,n::nonnegint,m::nonnegint)
 option remember;
 if p = 0 then
  return `if`(n = m,1,0);
 else
  return add(`count_elements/E/subdiv`(p-1,n,k) *
             Stirling2(k+1,m+1) * (m+1)!,k=m..n);
 fi;
end:

`degrees/E/subdiv` := (p,n,m) -> (theta) ->
 [op(map(nops,theta) -~ 1),m];

######################################################################

`is_element/EE/subdiv` := (p::nonnegint,n::nonnegint) -> proc(theta)
 global reason;
 local tag,src,tgt,i,m,t,b;
 tag := "is_element/EE/subdiv";

 if p = 0 then
  if theta = [] then
   return true;
  else
   reason := [tag,"for p=0 the only element is []",theta];
   return phi;
  fi;
 fi;

 if not(type(theta,list(list(nonnegint)))) then
  reason := [tag,"theta is not a list of lists of natural numbers",theta];
  return false;
 fi;

 if nops(theta) <> p then
  reason := [tag,"theta is not a list of length p",theta,p];
  return false;
 fi;

 if theta[p] = [] then
  reason := [tag,"theta[p] = []",theta,p];
  return false;
 fi;

 m := max(op(theta[p]));

 b := `is_element/E/subdiv`(p,n,m)(theta);
 if not(b) then
  reason := [tag,"is_element/E/subdiv failed",m,reason];
  return false;
 fi;

 return true;
end:

`is_leq/EE/subdiv` := NULL;

`list_elements/EE/subdiv` := proc(p::nonnegint,n::nonnegint)
 option remember;
 [seq(op(`list_elements/E/subdiv`(p,n,m)),m=0..n)];
end:

`random_element/EE/subdiv` := (p::nonnegint,n::nonnegint) -> proc()
 local m;
 m := rand(0..n)();
 return `random_element/E/subdiv`(p,n,m)();
end:

`count_elements/EE/subdiv` := proc(p::nonnegint,n::nonnegint)
 add(`count_elements/E/subdiv`(p,n,m),m=0..n);
end:

`find_count_coeffs/EE/subdiv` := proc(n)
 local E,a,p,k;
 E := [seq(`count_elements/EE/subdiv`(p,n) - add((-1)^(n+k)*a[n,k]*((k+1)!)^p,k=0..n),p=1..n+5)];
 return solve(E);
end:

`degrees/EE/subdiv` := (p,n) -> (theta) ->
 [op(map(nops,theta) -~ 1),max(op(theta[p]))];

######################################################################

`is_element/threads/subdiv` := (p::nonnegint,n::nonnegint) -> (theta) -> proc(i)
 global reason;
 local tag,k,m;

 tag := "is_element/threads/subdiv";

 if not(type(i,list(nonnegint)) and nops(i) = p+1) then
  reason := [tag,"i is not a list of p+1 natural numbers",i,p];
  return false;
 fi;

 k := `degrees/EE/subdiv`(p,n)(theta);

 for m from 0 to p do
  if i[m+1] > k[m+1] then
   return false;
  fi;

  if m < p and theta[m+1][i[m+1]+1] > i[m+2] then
   return false;
  fi;
 od:

 return true;
end:

`is_leq/threads/subdiv` := NULL;

`list_elements/threads/subdiv` := (p::nonnegint,n::nonnegint) -> proc(theta)
 local i,k,m,phi,L,M;

 if p = 0 then
  return [seq([i],i=0..n)];
 else
  m := max(op(theta[p]));
  phi := [op(1..p-1,theta)];
  L := `list_elements/threads/subdiv`(p-1,n)(phi);
  M := NULL;
  for i in L do
   k := theta[p][i[p]+1];
   M := M,seq([op(i),j],j=k..m);
  od:
  return [M];
 fi;
end:

`random_element/threads/subdiv` := (p::nonnegint,n::nonnegint) -> (theta) -> proc()
 local i,j,k,m0,m1;

 k := `degrees/EE/subdiv`(p,n)(theta);
 i := [rand(0..n)()];
 for j from 1 to p do
  m0 := theta[j][i[j]+1];
  m1 := k[j+1];
  i := [op(i),rand(m0..m1)()];
 od;

 return i;
end:

`count_elements/threads/subdiv` := NULL;

`mu/threads/subdiv` := (p::nonnegint,n::nonnegint) -> (theta) -> proc(i)
 local k,u,m;

 k := `degrees/EE/subdiv`(p,n)(theta);

 u := k[p+1]+1;
 for m from 0 to p-1 do
  u := u * nops(select(j -> (j <= i[m+2]),theta[m+1]));
 od:

 return u;
end:

`xi/EE/subdiv` := (p::nonnegint,n::nonnegint) -> proc(theta)
 local x,II,i;

 if p = 0 then
  return [1$(n+1)]/~(n+1);
 fi;

 x := table([seq(i=0,i=0..n)]);
 II := `list_elements/threads/subdiv`(p,n)(theta);
 for i in II do
  x[i[1]] := x[i[1]] + 1/`mu/threads/subdiv`(p,n)(theta)(i);
 od:
 return [seq(x[i],i=0..n)];
end:

######################################################################
# F(p,n) is the set of vertices in the (p+1)-fold barycentric
# subdivision of the n-simplex

`is_element/FF/subdiv` := (p::nonnegint,n::nonnegint) -> proc(alpha_theta)
 local alpha,theta,m;

 if not(type(alpha_theta,list) and nops(alpha_theta) = 2) then
  return false;
 fi;

 alpha,theta := op(alpha_theta);

 if not(type(alpha,list(nonnegint)) and nops(alpha) > 0) then
  return false;
 fi;

 m := nops(alpha) - 1;

 if not(`is_element/simplicial_mono_alt`(m,n)(alpha)) then
  return false;
 fi;

 if not(`is_element/EE/subdiv`(p,m)(theta)) then
  return false;
 fi;

 return true;
end:

`list_elements/FF/subdiv` := proc(p,n)
 local L,N,m,alpha,theta;

 L := NULL:
 N := [seq(i,i=0..n)];
 for alpha in combinat[powerset](N) do
  m := nops(alpha) - 1;
  if m >= 0 then
   L := L,seq([alpha,theta],theta in `list_elements/EE/subdiv`(p,m));
  fi;
 od:

 return [L];
end:

`random_element/FF/subdiv` := (p,n) -> proc()
 local d,m,alpha,theta;

 d := rand(1..n)();
 alpha := `random_subset_of`({seq(i,i=0..n)},d);
 alpha := sort([op(alpha)]);
 m := nops(alpha) - 1;
 theta := `random_element/EE/subdiv`(p,m)();
 return [alpha,theta];
end:

# This function is not quite right.  It seems to find a correct morphism
# when one exists, but it claims that morphisms exist when that is not the case.

`find_morphism/FF/subdiv` := (p::nonnegint,n::nonnegint) -> proc(alpha_theta0,alpha_theta1)
 local alpha0,alpha1,theta0,theta1,m0,m1,k0,k1,f,h,i,j,u,v,xi,V,W,G,H;

 alpha0,theta0 := op(alpha_theta0);
 alpha1,theta1 := op(alpha_theta1);
 m0 := nops(alpha0) - 1;
 m1 := nops(alpha1) - 1;
 k0 := `degrees/EE/subdiv`(p,m0)(theta0);
 k1 := `degrees/EE/subdiv`(p,m1)(theta1);

 f := table([seq(i=FAIL,i=0..n)]);
 for i from 0 to m1 do f[alpha1[i+1]] := i; od;
 xi := [[seq(f[alpha0[i+1]],i=0..m0)]];
 if member(FAIL,xi[1]) then return FAIL; fi;
 for j from 0 to p-1 do
  V := {seq(w,w=0..k0[j+1])};
  W := {seq(w,w=0..k0[j+1+1])};
  G := [seq(select(v -> theta0[j+1][v+1] <= w,V),w in W)];
  H := map(A -> map(v -> theta1[j+1][xi[j+1][v+1]+1],A),G);
  h := map(max,H);
  if h <> sort([op({op(h)})]) then
   return false;
  fi;
  xi := [op(xi),h];
 od;

 return xi;
end:

`is_leq/FF/subdiv` := (p::nonnegint,n::nonnegint) -> proc(alpha_theta0,alpha_theta1)
 evalb(`find_morphism/FF/subdiv`(p,n)(alpha_theta0,alpha_theta1) <> FAIL);
end:

`xi/FF/subdiv` := (p::nonnegint,n::nonnegint) -> proc(alpha_theta)
 local alpha,theta,i,m,x,y,yt;

 alpha,theta := op(alpha_theta);
 m := nops(alpha) - 1;
 x := `xi/EE/subdiv`(p,m)(theta);
 yt := table([seq(i=0,i=0..n)]);
 for i from 0 to m do
  yt[alpha[i+1]] := x[i+1];
 od:
 y := [seq(yt[i],i=0..n)];
 return y;
end:

# Every vertex of the (p+1)-fold subdivision is the barycentre of
# a d-simplex of the p-fold subdivision for some d.  This function
# returns d.

`rank/FF/subdiv` := (p::nonnegint,n::nonnegint) -> proc(alpha_theta)
 local alpha,theta,m;

 alpha,theta := op(alpha_theta);
 m := nops(alpha) - 1;

 if p = 0 then
  return m;
 else
  return max(op(theta[p]));
 fi;
end:

######################################################################
# Here zeta is a strictly increasing map [j] -> [k] and theta is an
# unordered surjective map [m] -> [k].  The function returns a triple
# [n,beta,phi] where beta : [n] -> [m] is strictly increasing and
# phi : [n] -> [j] is surjective.  In an appropriate context we will
# have alpha^*([x,theta]) = [beta^*(x),phi].

`rewrite/epi/subdiv` := proc(zeta,theta)
 local i,j,m,J,M,k1,N,n,xi,phi;

 j := nops(zeta) - 1;
 m := nops(theta) - 1;
 J := {seq(j0,j0=0..j)};
 M := {seq(m0,m0=0..m)};

 k1 := op(-1,zeta);
 N := select(m0 -> theta[m0+1] <= k1,M);
 n := nops(N) - 1;
 xi := sort([op(N)]);
 phi := NULL;

 for i from 0 to n do
  phi := phi,min(select(j0 -> zeta[j0+1] >= theta[xi[i+1]+1],J));
 od:
 phi := [phi];

 return [n,xi,phi];
end:

`rewrite/FF/subdiv` := (p,n) -> (zeta) -> proc(alpha_theta)
 local alpha,theta,k0,m,xi,phi,alpha1,theta1;
 alpha,theta := op(alpha_theta);

 if p = 0 then
  k0 := nops(zeta) - 1;
  return [[seq(alpha[zeta[i+1]+1],i=0..k0)],[]];
 else
  k0 := nops(zeta) - 1;
  m,xi,phi := op(`rewrite/epi/subdiv`(zeta,theta[p]));
  alpha1,theta1 := op(`rewrite/FF/subdiv`(p-1,n)(xi)([alpha,[op(1..-2,theta)]]));
  return [alpha1,[op(theta1),phi]];
 fi;
end:

`rewrite_aux/FF/subdiv` := (p,n) -> (zeta) -> proc(alpha_theta)
 local alpha,theta,k0,m,xi,phi,xi1,alpha1,theta1;
 alpha,theta := op(alpha_theta);

 if p = 0 then
  k0 := nops(zeta) - 1;
  return [[zeta],[seq(alpha[zeta[i+1]+1],i=0..k0)],[]];
 else
  k0 := nops(zeta) - 1;
  m,xi,phi := op(`rewrite/epi/subdiv`(zeta,theta[p]));
  xi1,alpha1,theta1 := op(`rewrite_aux/FF/subdiv`(p-1,n)(xi)([alpha,[op(1..-2,theta)]]));
  return [[op(xi1),zeta],alpha1,[op(theta1),phi]];
 fi;
end:

`vertices/FF/subdiv` := (p,n) -> proc(alpha_theta)
 local r;
 r := `rank/FF/subdiv`(p,n)(alpha_theta);
 return [seq(`rewrite/FF/subdiv`(p,n)([i])(alpha_theta),i=0..r)];
end:


with(Groebner):
F:={2*x1 + 5*x2 + x3,2*x1 + x2 + x3,9*x1 + 6*x2 + x3,x1^2 + x2^2 + x3^2 - 1}:
m_ord:=tdeg(x1,x2,x3):
G:=Basis(F,m_ord):
NormalSet(G,m_ord)[1]


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* nop scaling *)
s_scaling_0 := s -> s:

(* original scaling of Heyd *)
strans :=  8.3:
smax   :=  8.572844:
sconst := 18.79622316:
s_scaling_1 := s -> my_piecewise3(
  s < strans, s,
  smax - sconst/s^2
):

(* first version of the scaling by TM Henderson, apparently used by Gaussian *)
s_scaling_2 := s -> my_piecewise3(
  s < 1,  s,
  my_piecewise3(s > 15, smax, m_max(m_min(s, 15), 1) - log(1 + exp(m_max(m_min(s, 15), 1) - smax)))
):

(* second version of the scaling by TM Henderson *)
s_scaling_3 := s -> s - (1 - exp(-s))*log(1 + exp(s - smax)):

(* appendix of JCP 128, 194105 (2008) *)
s_p :=  [0.615482, 1.136921, -0.449154, 0.0175739*8.572844]:
s_q :=  [1.229195, -0.0269253, 0.313417, -0.0508314, 0.0175739]:

s_scaling_4 := s->
  s*(1 + s^3*add(s_p[i]*s^i, i=1..4))/(1 + s^3*add(s_q[i]*s^i, i=1..5)):


`is_element/nat_partitions` := (total::nonnegint,num_parts::nonnegint) -> proc(u)
 return type(u,list(nonnegint)) and nops(u) = num_parts and `+`(op(u)) = total;
end:

`is_leq/nat_partitions` := NULL;

`list_elements/nat_partitions` := proc(total,num_parts)
 local L,M,i,j,m,u;

 if num_parts = 0 then
  if total = 0 then
   return [[]];
  else
   return [];
  fi;
 fi;

 if num_parts = 1 then return [[total]]; fi;

 L := [seq([i],i=0..total)];
 for j from 2 to num_parts-1 do
  M := NULL;
  for u in L do
   m := total - `+`(op(u));
   M := M,seq([op(u),j],j=0..m);
  od:
  L := [M];
 od:
 L := map(u -> [op(u),total - `+`(op(u))],L);

 return L;
end:

`count_elements/nat_partitions` := (total::nonnegint,num_parts::nonnegint) ->
 binomial(total+num_parts-1,total);

`random_element/nat_partitions` := (total::nonnegint,num_parts::nonnegint) -> proc()
 local X,i;
 if total = 0 and num_parts = 0 then
  return [];
 fi;

 X := random_subset_of({seq(i,i=1..total+num_parts-1)},num_parts-1);
 X := [0,op(sort(X)),total+num_parts];
 return [seq(X[i+1]-X[i]-1,i=1..num_parts)];
end:

`is_element/pos_partitions` := (total::nonnegint,num_parts::nonnegint) -> proc(u)
 return type(u,list(posint)) and nops(u) = num_parts and `+`(op(u)) = total;
end:

`is_leq/pos_partitions` := NULL;

`random_element/pos_partitions` := (total::nonnegint,num_parts::nonnegint) -> proc()
 local p;
 if num_parts > total then return FAIL; fi;
 p := `random_element/nat_partitions`(total - num_parts,num_parts)();
 return p +~ 1;
end:

`list_elements/pos_partitions` := proc(total,num_parts)
 map(u -> u +~ 1,`list_elements/nat_partitions`(total - num_parts,num_parts));
end:

`count_elements/pos_partitions` := (total::nonnegint,num_parts::nonnegint) ->
 binomial(total-1,num_parts-1);