#alpha shapes of kernel density estimators
AlphaDens := module()
option package;
export gaussker,gausskde,getcdf,densrange,drawdens,plotnld,shapekde,shapefit,hessnld,qfshape,toshape,sampshape,greedyland,densland,alphakde,legtrans,drawshape,alphafilt;

    gaussker := proc(h,d)
        md := module()
        option object;
        export h,d,getscale,setscale,getker,getcost,gradcost,mapker,mapcost,mapgrad,init;
        local ModulePrint,ModuleApply;
            ModulePrint::static := proc()
                return nprintf("gaussian kernel on R^%d, h=%f",d,h);
            end proc;
            getscale::static := ()->h;
            setscale::static := proc()
                h := args[1];
                return;
            end proc;
            getcost::static := proc(xx,yy)
                return add((xx[i]-yy[i])^2,i=1..d)/2/h^2;
            end proc;
            getker::static := proc(xx,yy)
                return exp(-getcost(xx,yy));
            end proc;
            ModuleApply := getker;
            gradcost::static := proc(xx,yy,V:=vecf(d))
                return vecf([seq((yy[j]-xx[j])/h^2,j=1..d)]);
            end proc;
            init::static := proc()
                h,d := args;
            end proc;
        end module;
        md:-init(args);
        return md;
    end proc;

    gradnld_c := proc(A::Array(datatype=float[8]),xx::Array(datatype=float[8]),h::float[8],tt::Array(datatype=float[8]),V::Array(datatype=float[8]),N::integer[4],d::integer[4])
        for j from 1 to d do
            c := 0.0;
            for i from 1 to N do
                c := c+tt[i]*(xx[j]-A[i,j])/h^2;
            end do;
            V[j] := c;
        end do;
    end proc;

    gradnld_c := Compiler:-Compile(gradnld_c);

    sampkde_c := proc(A::Array(datatype=float[8]),B::Array(datatype=float[8]),M::integer[4],N::integer[4],d::integer[4])
        for k from 1 to M do
            i := rand() mod N+1;
            for j from 1 to d do
                B[k,j] := B[k,j]+A[i,j];
            end do;
        end do;
    end proc;

    sampkde_c := Compiler:-Compile(sampkde_c);

    setsite_c := proc(A::Array(datatype=float[8]),h::float[8],aa::Array(datatype=float[8]),xx::Array(datatype=float[8]),R::Array(datatype=float[8]),tt::Array(datatype=float[8]),N::integer[4],d::integer[4])
        c0 := Float(infinity);
        for i from 1 to N do
            r := 0.0;
            for j from 1 to d do
                c := (xx[j]-A[i,j]);
                r := r+c*c;
            end do;
            r := r/2/h^2;
            R[i] := r;
            c0 := min(c0,r);
        end do;
        dens := 0.0;
        for i from 1 to N do
            tt[i] := aa[i]*exp(-R[i]+c0);
            dens := dens+tt[i];
        end do;
        for i from 1 to N do
            tt[i] := tt[i]/dens;
        end do;
        return c0-log(dens);
    end proc;

    setsite_c := Compiler:-Compile(setsite_c);

    gausskde := proc(A,h,aa)
        if(whattype(args[1])='GaussKDE') then
            f := args[1];
            return procname(f:-getdata());
        elif(nargs=2) then
            N := Dimension(A)[1];
            return procname(A,h,vecf([seq(1/N,i=1..N)]));
        end if;
        md := module()
        export A,h,aa,`numelems`,`whattype`,dens,nld,setsite,getsite,numpoints,getdim,getdata,getpoints,getscale,getconv,getcosts,kern,getdens,getnld,gradnld,getgrad,sample,init;
        local ModulePrint,ModuleApply,R,xx1,V,tt,N,d,densval,nldval;
            ModulePrint::static := proc()
                return nprintf("gaussian kernel density estimator in R^%d",d);
            end proc;
            `whattype`::static := proc()
                return 'GaussKDE';
            end proc;
            setsite::static := proc(xx)
                setvec(xx1,xx);
                nldval := setsite_c(A,h,aa,xx1,R,tt,N,d);
                densval := exp(-nldval);
                return true;
            end proc;
            getsite::static := ()->xx1;
            getdata::static := ()->A,h,aa;
            getdim::static := ()->d;
            numpoint::static := ()->N:
            getpoints::static := ()->A;
            getscale::static := ()->h;
            getweights::static := ()->aa;
            getconv::static := ()->tt;
            getcosts::static := ()->R;
            getdens::static := ()->densval;
            getnld::static := ()->nldval;
            dens::static := proc(xx)
                setsite(xx);
                return densval;
            end proc;
            nld::static := proc(xx)
                setsite(xx);
                return nldval;
            end proc;
            ModuleApply::static := dens;
            getgrad::static := proc()
                gradnld_c(A,xx1,h,tt,V,N,d);
                return V;
            end proc;
            gradnld::static := proc(xx)
                setsite(xx);
                return vecf(getgrad());
            end proc;
            sample::static := proc(M)
                if(type(M,'numeric')) then
                    return sample(matf(M,d));
                end if;
                B := Sample(Normal(0,h),args);
                sampkde_c(A,B,Dimension(B)[1],N,d);
                return B;
            end proc;
            init::static := proc()
                A,h,aa := args;
                N,d := Dimension(A);
                xx1,V,R,tt := allocla[float[8]](d,d,N,N);
                kern := gaussker(h,d);
                return;
            end proc;
        end module;
        md:-init(args);
        return md;
    end proc;

#average the points of A
    shapefit_c := proc(A::Array(datatype=float[8]),tt::Array(datatype=float[8]),yy::Array(datatype=float[8]),N::integer[4],d::integer[4])
        for j from 1 to d do
            c := 0.0;
            for i from 1 to N do
                c := c+tt[i]*A[i,j];
            end do;
            yy[j] := c;
        end do;
    end proc;

    shapefit_c := Compiler:-Compile(shapefit_c);

    #the inverse homotopy from the paper
    shapekde := proc(f)
        f1 := args[1];
        md := module()
        option object;
        export f,getsite,setsite,getpoint,transmap,alpha,getalpha,retract;
        local ModuleApply,ModulePrint,A,h,N,d,tt,getcost,xx1,yy1;
            ModulePrint::static := proc()
                return nprintf("inverse homotopy p: R^%d-->R^%d",d,d);
            end proc;
            setsite::static := proc(xx)
                f:-setsite(xx);
                shapefit_c(A,tt,yy1,N,d);
                return true;
            end proc;
            getsite::static := ()->xx1;
            getpoint::static := ()->yy1;
            transmap::static := proc(xx)
                setsite(xx);
                return vecf(yy1);
            end proc;
            ModuleApply::static := transmap;
            getcost::static := f1:-kern:-getcost;
            getalpha::static := proc()
                return f:-getnld()-getcost(xx1,yy1);
            end proc;
            alpha::static := proc(xx)
                setsite(xx);
                return getalpha();
            end proc;
            retract::static := proc(xx)
                setsite(args);
                mindens := op(procname);
                a1 := -log(mindens);
                a := getalpha();
                if(a>a1) then
                    error "not in the domain";
                elif(f:-getnld()<=a1) then
                    return vecf(xx1);
                else
                    r := sqrt(2*h^2*(a1-a));
                    return yy1+r/sqrt(l2dd(xx1,yy1))*(xx1-yy1);
                end if;
            end proc;
            f := f1;
            A,h := f:-getpoints(),f:-getscale();
            N,d := Dimension(A);
            yy1 := allocla[float[8]](d);
            xx1 := f:-getsite();
            tt := f:-getconv();
        end module;
        return md;
    end proc;

    shapefit := proc(f,xx)
        pp := shapekde(f);
        pp:-setsite(xx);
        yy := pp:-getpoint();
        a := pp:-getalpha();
        getcost := f:-kern:-getcost;
        return ()->getcost(yy,args[1])+a;
    end proc;

    #sample points from the shape up to minimum transformed density mindens.
    sampshape := proc(pp,M,mindens:=0.0)
        d := pp:-f:-getdim();
        B,S,aa,T,xx := allocla[float[8]]([M,d],[M,d],M,[M,d],d);
        yy := pp:-getpoint();
        a1 := -log(mindens);
        k := 0;
        n := 0;
        while(n<M) do
            k := k mod M+1;
            if(k=1) then
                printf("sampling...\n");
                pp:-f:-sample(B);
            end if;
            getrow_c(B,k,xx,d);
            if(pp:-setsite(xx)) then
                a := pp:-getalpha();
                if(a<=a1) then
                    n := n+1;
                    setrow_c(S,n,yy,d);
                    setrow_c(T,n,xx,d);
                    aa[n] := a;
                end if;
            end if;
        end do;
        return S,aa,T;
    end proc;

    #returns the result of sorting aa in reverse order
    greedyland_c := proc(S::Array(datatype=float[8]),eps::float[8],inds::Array(datatype=integer[4]),M::integer[4],d::integer[4])
        n := 0;
        for k from 1 to M do
            for i from 1 to n do
                k1 := inds[i];
                r := 0.0;
                for j from 1 to d do
                    x := S[k1,j]-S[k,j];
                    r := r+x*x;
                end do;
                r := sqrt(r);
                if(r<eps) then
                    break;
                end if;
            end do;
            if(i<n+1) then
                next;
            end if;
            n := n+1;
            inds[n] := k;
        end do;
        return n;
    end proc;

    greedyland_c := Compiler:-Compile(greedyland_c);

#go through S, in order, adding the next point with a minium separation
    greedyland := proc(S,r)
        N,d := Dimension(S);
        inds := allocla[integer[4]](N);
        n := greedyland_c(S,r,inds,N,d);
        return inds[1..n];
    end proc;

#return landmarks by proceding in increasing value of aa, accepting
#when distance at least eps from all chosen points.
    densland := proc(f,M,s,mindens:=0.0)
        pp := shapekde(f);
        S,aa,B := sampshape(pp,M,mindens);
        h := f:-getscale();
        eps := sqrt(-2*h^2*log(s));
        ord := convert(sortinds(aa,`<`),'list');
        S,aa,T := S[ord],aa[ord],T[ord];
        inds := convert(greedyland(S,eps),'list');
        return S[inds],aa[inds],B[inds];
    end proc;

#get the density value at the cutoff quantile value of 0<=s<=1
    getcdf := proc(f,s,M:=10000)
        A := f:-getpoints();
        N,d := Dimension(A);
        if(M=true) then
            V := rowmap(f:-nld,A);
        else
            V := vecf([seq(f:-nld(A[rand() mod N+1]),i=1..M)]);
        end if;
        sort[inplace](V,`>`);
        return exp(-V[ceil(M*(1-s))]);
    end proc;

    toshape := proc(f,B)
        M,d := Dimension(B);
        S,aa,xx := allocla[float[8]]([M,d],M,d);
        pp := shapekde(f);
        yy := pp:-getpoint();
        for k from 1 to M do
            getrow_c(B,k,xx,d);
            pp:-setsite(xx);
            setrow_c(S,k,yy,d);
            aa[k] := pp:-getalpha();
        end do;
        return S,aa;
    end proc;

#uses samples from the shape to determine the range spanned by the
#sublevel sets of -log(f)
    densrange := proc(f,mindens,M:=10000)
        B := f:-sample(M);
        S,aa := toshape(f,B);
        h := f:-getscale();
        pow := -2*h^2*aa;
        a1 := -2*h^2*log(mindens);
        return pdrange(S,pow,a1);
    end proc;

#inherits from drawsublev. computes the range and the minimum density
#cutoff from the cdf command and densrange.
    drawdens := proc(f,s)
        numcdf,numrng := 10000,10000;
        A := f:-getpoints();
        N,d := Dimension(A);
        if(d<>2) then
            error "must be 2-dimensional"
        end if;
        mindens := getcdf(f,s,numcdf)*(1+randf(0,.01));
        rng := densrange(f,mindens,numrng);
        im := imrng(rng);
        drawsublev(f:-nld,-log(mindens),im);
        return disprng([seq(point([A[i,1],A[i,2]],symbol=solidcircle,symbolsize=5),i=1..N)],im);
    end proc;

#plot the negative log of f in a suitable range. also plots extra
#functions in the additional arguments in the same range.
    plotnld := proc(f,s)
    local x;
        numcdf,numrng,lgap := 1000,1000,.05;
        A := f:-getpoints();
        N,d := Dimension(A);
        if(d<>1) then
            error "must be 1-dimensional"
        end if;
        mindens := getcdf(f,s,numcdf);
        maxdens := max(rowmap(f,A));
        rng1 := op(densrange(f,mindens,numrng));
        c,d := -log(maxdens),-log(mindens);
        c := d-(1+lgap)*(d-c);
        rng2 := c..d;
        Fl := [plot(x->f:-nld([x]),rng1)];
        for F in args[3..nargs] do
            Fl := [op(Fl),plot(x->F([x]),rng1,color=blue)];
        end do;
        return display(Fl,view=[rng1,rng2]);
    end proc;

    alphafilt := proc(S,aa,r,k1)
        X := alpharadii(S,r,k1);
        n,k1 := X:-numverts(),X:-getdim();
        Y := fplex(n);
        for k from 0 to k1 do
            for sig in X[k] do
                Y:-addfilt(sig,max([seq(aa[i],i=sig)]));
            end do;
        end do;
        return Y;
    end proc;

#the alpha complex filtered by density
    alphakde := proc(f,M,s,mindens,k1)
        h := f:-getscale();
        S,aa,B := densland(f,M,s,mindens);
        r := sqrt(-2*h^2*log(s));
        return alphafilt(S,aa,r,k1),S;
        #X := alpharadii(S,r,k1);
        #return lazyfilt(X,aa),S;
    end proc;

    legtrans_c := proc(arr1::Array(datatype=float[8]),X1::Array(datatype=float[8]),X2::Array(datatype=float[8]),Y1::Array(datatype=float[8]),Y2::Array(datatype=float[8]),arr2::Array(datatype=float[8]),E::Array(datatype=integer[4]),m1::integer[4],m2::integer[4],n1::integer[4],n2::integer[4])
        for j1 from 1 to n1 do
            for j2 from 1 to n2 do
                c := -Float(infinity);
                for i1 from 1 to m1 do
                    c1 := -Float(infinity);
                    for i2 from E[j1] to m2 do
                        d1 := X1[i1]*Y1[j1]+X2[i2]*Y2[j2]-arr1[i1,i2];
                        if(d1<=c1) then
                            break;
                        end if;
                        c1 := d1;
                        if(c1>c) then
                            c := c1;
                            k := i2;
                        end if;
                    end do;
                    c1 := d1;
                    if(c1>c) then
                        c := c1;
                        k := i2;
                    end if;
                end do;
                E[j1] := k;
                arr2[j1,j2] := c;
            end do;
        end do;
    end proc;

    legtrans_c := Compiler:-Compile(legtrans_c);

#legendre-fenchel transform of an array with coordinate positions
#given in Xl,Yl.
    legtrans := proc(arr,Xl,Yl)
    if(not type(args[1],'Array')) then
        f,grid1,grid2 := args;
        return legtrans(grid1:-map2arr(f),grid1:-getcoords(),grid2:-getcoords());
    end if;
        d := nops(Xl);
        ml := [seq(Dimension(X),X=Xl)];
        nl := [seq(Dimension(Y),Y=Yl)];
        E := allocarr[integer[4]](nl[1..d-1]);
        ArrayTools:-Fill(1,E);
        ans := allocarr[float[8]](nl);
        legtrans_c(arr,op(Xl),op(Yl),ans,E,op(ml),op(nl));
        return ans;
    end proc;

    drawshape := proc(f,mindens,im)
        if(whattype(im)<>'ImageRange') then
            im1 := imrng(args[2..nargs]);
            drawshape(f,mindens,im1);
            im1:-draw();
            return im1;
        end if;
        h := f:-getscale();
        rng := im:-getrng();
        grid := tensgrid(rng,im:-gridsize());
        arr1 := grid:-map2arr(xx->h^2*f:-nld(xx));
        arr2 := grid:-map2arr(xx->(xx[1]^2+xx[2]^2)/2)-arr1;
        arr3 := legtrans(arr2,grid:-getcoords(),grid:-getcoords());
        arr4 := grid:-map2arr(xx->(xx[1]^2+xx[2]^2)/2)-arr3;
        subcolor(-arr4,-h^2*log(mindens),drawsublev:-getcolor(),im:-getarr());
        return im;
    end proc;

    hessnld_c := proc(A::Array(datatype=float[8]),xx::Array(datatype=float[8]),h::float[8],tt::Array(datatype=float[8]),V::Array(datatype=float[8]),H::Array(datatype=float[8]),N::integer[4],d::integer[4])
        for j1 from 1 to d do
            for j2 from 1 to d do
                c := 0.0;
                for i from 1 to N do
                    c := c+tt[i]*(A[i,j1]-xx[j1])*(A[i,j2]-xx[j2])/h^4;
                end do;
                H[j1,j2] := V[j1]*V[j2]-c;
            end do;
            H[j1,j1] := H[j1,j1]+1/h^2;
        end do;
    end proc;

    hessnld_c := Compiler:-Compile(hessnld_c);

    #hessian of the negative log of f
    hessnld := proc(f,xx)
        A,h := f:-getpoints(),f:-getscale();
        N,d := Dimension(A);
        f:-calcweights(xx);
        tt := f:-getconv();
        V := f:-gradnld();
        H := allocla[float[8]]([d,d]);
        hessnld_c(A,xx,h,tt,V,H,N,d);
        return H;
    end proc;

#quadratic approximation of alpha(xx)
    qfshape := proc(f)
        md := module()
        export f,h,H,H1,N,d,init;
        local ModuleApply,ModulePrint,xx1,L,L1;
            ModulePrint::static := proc()
                return nprintf("hessian approximation of the legendre transform");
            end proc;
            ModuleApply::static := proc(xx)
                for j from 1 to d do
                    xx1[j] := xx[j];
                end do;
                f:-calcweights(xx);
                tt := f:-getconv();
                c0 := f:-getnld();
                V := f:-gradnld();
                hessnld_c(A,xx1,h,tt,V,H,N,d);
                for i from 1 to d do
                    for j from 1 to d do
                        H[i,j] := -H[i,j];
                    end do;
                    H[i,i] := H[i,i]+1/h^2;
                end do;
                cholesky_c(H,L,L1,H1,d);
                return c0+add(add(H1[i,j]*V[i]*V[j],i=1..2),j=1..2)/2;
            end proc;
            init::static := proc()
                f := args;
                A,h := f:-A,f:-h;
                N,d := Dimension(A);
                H,H1,L,L1,xx1 := allocla[float[8]]([d,d],[d,d],[d,d],[d,d],d);
            end proc;
        end module;
        md:-init(f);
        return md;
    end proc;

end module;
