text:
   {   Transp.mpl   }

TITLE
    TransportationProblem;

INDEX
    supply = (Wh1,Wh2,Wh3,Wh4,Wh5);
    dest   = (A1,A2,B1,B2,B3,C1,C2,C3);

DATA
    MaxCapacity[supply]  := (200,300,250,450,350);
    Required[dest]       := (188,214,137,199,225,200,177,185);

    ShippingCost[supply,dest] := (13, 22,  9, 14, 10, 32, 35, 36,
                                  12, 10, 11, 13,  7, 11, 16, 15,
                                  24, 22, 17, 11,  9,  8, 12,  8,
                                  43, 40, 25, 17, 21, 24, 27, 22,
                                  15,  9, 41, 38, 35,  8,  5, 13);

DECISION VARIABLES
    VolumeShipped[supply,dest]  ->  ""

MODEL

    MIN  TotalCost = SUM(supply,dest: ShippingCost * VolumeShipped);

SUBJECT TO

    Capacity[supply] : SUM(dest: VolumeShipped)    <  MaxCapacity ;
    Demand[dest]     : SUM(supply: VolumeShipped)  >  Required ;

END

ext: mpl

max_stars_repo_name: BjarniMax/mpl-models

max_issues_repo_name: BjarniMax/mpl-models

max_forks_repo_name: BjarniMax/mpl-models

lm_label:
1. YES
2. YES


text:
# Maple 2018.2 file to be called with
# read "log_trans_prob.mpl"

# we assume that b > 0!

with(LinearAlgebra):

trans_prob_unequal := proc(a, b, t, lambda, mu)
  local h, theta, psi, phi, alpha, beta, gamma:

  theta := lambda - mu:
  psi := lambda + mu:

  phi := (exp(theta * t) - 1) / (lambda * exp(theta * t) - mu):
  alpha := mu * phi:
  beta := lambda * phi:
  gamma := 1 - psi * phi:

  binomial(a + b - 1, a - 1) * alpha^a * beta^b + sum(binomial(a, h) * binomial(a + b - h - 1, a - 1) * alpha^(a - h) * beta^(b - h) * gamma^h, h = 1 .. min(a, b))
end proc:

trans_prob_equal := proc(a, b, t, lambda)
  local h, theta, alpha, gamma:

  theta := lambda * t:

  alpha := theta / (1 + theta):
  gamma := (1 - theta) / (1 + theta):

  binomial(a + b - 1, a - 1) * alpha^(a + b) + sum(binomial(a, h) * binomial(a + b - h - 1, a - 1) * alpha^(a + b - 2 * h) * gamma^h, h = 1 .. min(a, b))
end proc:

log_trans_prob := proc(a, b, t, lambda, mu)
  local s, lp:

  s := 0:
  lp := 0:

  if (lambda <> mu) then
    s := trans_prob_unequal(a, b, t, lambda, mu):
  else
    s := trans_prob_equal(a, b, t, lambda):
  end if:

  if evalf[20](s) > 0 then
    lp := ln(s):
  else
    lp := ln(normal(s)):
  end if:

  lp
end proc:

log_trans_prob_float := proc(a, b, t, lambda, mu)
  evalf[100](log_trans_prob(a, b, t, lambda, mu))
end proc:

# generate data for Figures 1 and 3
N := 1000:
A := 25:
B := 35:
T := 2:
L := 1:
M := 3:

values := Array([seq(0, i = 1 .. N)]):

for n to N do
  values[n] := log_trans_prob_float(A, B, T, L, n * M / N):
end do:

values := Transpose(Matrix(convert(values, list))):

Export("log_trans_prob_values_univariate.csv", values):

# generate data for Figure 4 (beware: it takes a long time)
N := 100:
A := 200:
B := 100:
T := 1:
L := 10:
M := 10:

values := Array([seq(0, i = 1 .. (N * N))]):

c0 := 1:
for c1 to N do
  for c2 to N do
    values[c0] := log_trans_prob_float(A, B, T, c1 * L / N, c2 * M / N):
    c0 := c0 + 1:
  end do:
end do:

values := Transpose(Matrix(convert(values, list))):

Export("log_trans_prob_values_bivariate.csv", values):


text:
euler_angle_matrix := (t) ->
<<cos(t[2])|
  -cos(t[3])*sin(t[2])|
  sin(t[2])*sin(t[3])>,
 <cos(t[1])*sin(t[2])|
  cos(t[1])*cos(t[2])*cos(t[3])-sin(t[1])*sin(t[3])|
  -cos(t[3])*sin(t[1])-cos(t[1])*cos(t[2])*sin(t[3])>,
 <sin(t[1])*sin(t[2])|
  cos(t[1])*sin(t[3])+cos(t[2])*cos(t[3])*sin(t[1])|
  cos(t[1])*cos(t[3])-cos(t[2])*sin(t[1])*sin(t[3])>
>;

mobius_embedding := (R,r) -> (t,u) ->
 (R + u*r*cos(2*Pi*t)) *~ [cos(4*Pi*t),sin(4*Pi*t),0] +~ [0,0,u *r* sin(2*Pi*t)];

torus_embedding := (R,r) -> (t,u) ->
 (R + r * cos(2*Pi*u)) *~ [cos(2*Pi*t),sin(2*Pi*t),0] +~ [0,0,(r * sin(2*Pi*u))];

simplex_embedding := proc(t)
 if nops(t) = 1 then
  return 0;
 elif nops(t) = 2 then
  return 2*t[1]-1;
 elif nops(t) = 3 then
  return [t[1]-t[2]/2-t[3]/2,sqrt(3)/2*(t[2]-t[3])];
 elif nops(t) = 4 then
  return [sqrt(2)*(2*t[2]-t[3]-t[4])/3,
          sqrt(2/3)*(t[3]-t[4]),
	  t[1]-(t[2]+t[3]+t[4])/3];
 else
  error("Simplex embedding only defined in dim <= 3");
 fi;
end:

mobius_arc := (R,r) -> proc(t1,u1,t2,u2)
 local s1,s2;
 if u1 = 0 then
  s2 := t2;
  s1 := t1 - round(2*(t1 - t2))/2;
 elif u2 = 0 then
  s1 := t1;
  s2 := t2 - round(2*(t2 - t1))/2;
 else
  s1 := t1;
  s2 := t2 - round(t2-t1);
 fi;
 return spacecurve(mobius_embedding(R,r)(s1 + p*(s2-s1),u1 + p*(u2-u1)),p=0..1,args[5..-1]);
end:

sphere_arc := proc(a,b)
 local r,c,d,theta,i;
 r := evalf(sqrt(add(a[i]^2,i=1..3)));
 c := b -~ a;
 d := b +~ a;
 c := evalf(c *~ (r/sqrt(add(c[i]^2,i=1..3))));
 d := evalf(d *~ (r/sqrt(add(d[i]^2,i=1..3))));
 theta := evalf(arccos(add(a[i] * b[i],i=1..3)/r^2)/2);
 return spacecurve(d *~ cos(t) +~ c *~ sin(t),t = -theta..theta,args[3..-1]);
end:

spherical_angle := proc(a,b,c)
 local dp,ab,ac;
 dp := `dot/R`(3);
 ab := b -~ dp(b,a) *~ a;
 ac := c -~ dp(c,a) *~ a;
 return arccos(dp(ab,ac) /~ sqrt(dp(ab,ab) * dp(ac,ac)));
end:

spherical_triangle_area := proc(a,b,c)
 return spherical_angle(a,b,c) +
        spherical_angle(b,c,a) +
        spherical_angle(c,a,b) - Pi;
end:

spherical_triangle_area_alt := proc(a,b,c)
 local dp,f,x,y,z,F;
 dp := `dot/R`(3);
 f := (c) -> sqrt(1-c)/(sqrt(2) + sqrt(1+c));
 x,y,z := f(dp(b,c)),f(dp(c,a)),f(dp(a,b));
 F := (p,q,r) -> (p + q + r - p*q*r)/(1 - p*q - q*r - r*p);
 return 4 * arctan(sqrt(F( x, y, z) * F(-x, y, z) * F( x,-y, z) * F( x, y,-z)));
end:

simplex_outline := proc(d)
 local e,i,j,opts;
 if d <> 2 and d <> 3 then
  error("Simplex outline is only defined in dimensions 2 and 3");
 fi;

 e := table():
 for i from 0 to d do
  e[i] := simplex_embedding([0$i,1,0$(d-i)]);
 od:

 opts := [];
 if nargs > 1 then opts := [args[2..-1]]; fi;
 if d = 3 and opts = [] then opts := [colour=black]; fi;

 return display(seq(seq(line(e[i],e[j],op(opts)),j=i+1..d),i=0..d),
                scaling=constrained,axes=none);
end:

trefoil_embedding := (R,r) -> proc(t,u)
 local x,y,z,i;
 x := [sin(t) + 2*sin(2*t),cos(t) - 2 * cos(2*t),-sin(3*t)];
 y := [72*sin(2*t)+3*sin(8*t)-13*sin(4*t)+3*sin(7*t)-14*sin(5*t)+3*sin(t),
       3*cos(t)-3*cos(8*t)+3*cos(7*t)-72*cos(2*t)+14*cos(5*t)-13*cos(4*t),
       10*sin(6*t)-34*sin(3*t)];
 z := [-391*cos(t)+2*cos(8*t)-29*cos(7*t)+85*cos(2*t)-99*cos(5*t)+24*cos(4*t)+9*cos(10*t)-9*cos(11*t),
       -9*sin(11*t)+29*sin(7*t)+85*sin(2*t)-9*sin(10*t)+2*sin(8*t)-24*sin(4*t)-99*sin(5*t)+391*sin(t),
       -570-34*cos(3*t)-94*cos(6*t)+18*cos(9*t)];
 y := y /~ sqrt(add(y[i]^2,i=1..3));
 z := z /~ sqrt(add(z[i]^2,i=1..3));
 return R *~ x +~ (r * cos(u)) *~ y +~ (r * sin(u)) *~ z;
end:

trefoil_b := (t) -> [(2+cos(3*t))*cos(2*t),(2+cos(3*t))*sin(2*t),sin(3*t)];

klein_embedding := (t,u) ->
[(0.1*sin(3*Pi*t)+0.1*sin(Pi*t)+0.4*cos(Pi*t))*sin(2*Pi*u)-0.5*sin(4*Pi*t)+sin(2*Pi*t),
  0.2*sin(2*Pi*u)*sin(3*Pi*t)+2.*cos(2*Pi*t)+0.5,
  0.25*cos(2*Pi*u)*sin(2*Pi*t)+0.4*cos(2*Pi*u)];

klein_seam_a := (t) -> [0.8621-0.0015*cos(4*Pi*t)+0.0171*sin(2*Pi*t)-0.0002*sin(6*Pi*t),t];
klein_seam_b := (t) -> [0.1179+0.0031*cos(4*Pi*t)-0.0385*sin(2*Pi*t)+0.0005*sin(6*Pi*t),
                        -0.25+0.0597*cos(2*Pi*t)-0.0004*cos(6*Pi*t)+0.0049*sin(4*Pi*t)];
klein_seam := (t) -> [-0.2811+0.0051*cos(4*Pi*t)-0.1401*sin(2*Pi*t)+0.0005*sin(6*Pi*t),
                      1.7871-0.0061*cos(4*Pi*t)+0.3532*sin(2*Pi*t)-0.0005*sin(6*Pi*t),
                      0.2090*cos(2*Pi*t)-0.0010*cos(6*Pi*t)+0.0086*sin(4*Pi*t)];

orient_face := proc(ii,v)
 local dp,u0,u1,u2,vv,i;
 dp := (x,y) -> add(x[i] * y[i],i=1..3);
 u0 := [0,0,0];
 for i in ii do u0 := u0 +~ v[i]; od;
 u0 := evalf(u0 /~ sqrt(dp(u0,u0)));
 u1 := evalf(v[ii[1]]);
 u1 := u1 -~ dp(u1,u0) *~ u0;
 u1 := evalf(u1 /~ sqrt(dp(u1,u1)));
 u2 := [u0[2] * u1[3] - u0[3] * u1[2],
        u0[3] * u1[1] - u0[1] * u1[3],
        u0[1] * u1[2] - u0[2] * u1[1]];
 vv := map(i -> [evalf(arctan(dp(u2,v[i]),dp(u1,v[i]))),i],ii);
 return map(x -> x[2],sort(vv));
end:


text:
~ quaternions are represented as a vector(4)
~      r + xi + yj + zk => [r, x, y, z]

function quaternion_rotation(theta, v)
    st = sin(theta/2)
    return [cos(theta/2), st*v[0], st*v[1], st*v[2]]
end

function quaternion_add(x, y)
    return x + y
end

function quaternion_negate(x)
    return -x
end

function quaternion_subtract(x, y)
    return x - y
end

function quaternion_multiply(x, y)
    return [ x[0]*y[0] - x[1]*y[1] - x[2]*y[2] - x[3]*y[3], \
             x[0]*y[1] + x[1]*y[0] + x[2]*y[3] - x[3]*y[2], \
	     x[0]*y[2] + x[2]*y[0] + x[3]*y[1] - x[1]*y[3], \
	     x[0]*y[3] + x[3]*y[0] + x[1]*y[2] - x[2]*y[1] ]
end

function quaternion_conjugate(x)
    return [x[0], -x[1], -x[2], -x[3]]
end

function quaternion_normalize(x)
    return x/sqrt(x*x)
end

function quaternion_inverse(x)
    return quaternion_conjugate(x)/(x*x)
end

function quaternion_divide(x, y)
    return quaternion_multiply(x, quaternion_inverse(y))
end

function quaternion_rotate(x, y)
    return quaternion_multiply(quaternion_multiply(x, y), quaternion_inverse(x))
end

function quaternion_from_matrix(m)
    if m[2,2] < 0 then
        if m[0,0] > m[1,1] then
	    t = 1 + m[0,0] - m[1,1] - m[2,2]
	    q = [m[2,1] - m[1,2], t, m[1,0] + m[0,1], m[0,2] + m[2,0]]
	else
	    t = 1 - m[0,0] + m[1,1] - m[2,2]
	    q = [m[0,2] - m[2,0], m[1,0] + m[0,1], t, m[2,1] + m[1,2]]
	end
    else if m[0,0] < -m[1,1] then
        t = 1 - m[0,0] - m[1,1] + m[2,2]
	q = [m[1,0] - m[0,1], m[0,2] + m[2,0], m[2,1] + m[1,2], t]
    else
        t = 1 + m[0,0] + m[1,1] + m[2,2]
	q = [t, m[2,1] - m[1,2], m[0,2] - m[2,0], m[1,0] - m[0,1]]
    end
    return q/(2*sqrt(t))
end

function quaternion_to_matrix(q)
    return [ 1 - 2*q[2]*q[2] - 2*q[3]*q[3], 2*q[1]*q[2] - 2*q[3]*q[0], 2*q[1]*q[3] + 2*q[2]*q[0]
             2*q[1]*q[2] + 2*q[3]*q[0], 1 - 2*q[1]*q[1] - 2*q[3]*q[3], 2*q[2]*q[3] - 2*q[1]*q[0]
	     2*q[1]*q[3] - 2*q[2]*q[0], 2*q[2]*q[3] + 2*q[1]*q[0], 1 - 2*q[1]*q[1] - 2*q[2]*q[2] ]
end

function quaternion_slerp(xa, ya, t)
    x = quaternion_normalize(xa)
    y = quaternion_normalize(ya)
    dot = x*y
    if dot < 0 then
        x = -x
	dot = -dot
    end
    if dot > 0.9995 then
        return quaternion_normalize((1-t)*x + t*y)
    end
    theta0 = acos(dot)
    theta = t*theta0
    st = sin(theta)
    st0 = sin(theta0)
    s0 = cos(theta) - dot*st/st0
    s1 = st/st0
    return s0*x + s1*y
end

max_stars_repo_name: yugyfoog/MPL

max_issues_repo_name: yugyfoog/MPL

max_forks_repo_name: yugyfoog/MPL


text:
# validate new test case (Figure8_7.java)
with(simplex);

Constraints := [

# conservation of units at each node
e13+e14+e41+e15 = 400, # CHI
e21+e23+e24+e25 = 400, # DC

e13+e23     = 300, # HOU
e14+e41+e24 = 200, # ATL
e15+e25     = 300, # BOS

# maximum flow on individual edges
0 <= e13, e13 <= 200,
0 <= e14, e14 <= 350,
0 <= e41, e41 <= 200,
0 <= e21, e21 <= 200,
0 <= e23, e23 <= 280,
0 <= e15, e15 <= 200,
0 <= e24, e24 <= 200,
0 <= e25, e25 <= 350
];

Cost := 3*e41 + 7*e13 + 3*e14 + 4*e21 + 4*e23 + 7*e24 + 6*e15 + 6*e25;

# Invoke linear programming to solve problem
minimize (Cost, Constraints, NONNEGATIVE);


text:
# This is a row reduction algorithm for matrices over the p-local integers.
# It returns a triple [L,P,x].  Here P is an invertible matrix with P.M = L,
# so the row span of L is the same as that of M.  All rows of zeros in L
# appear at the bottom.  Every nonzero row contains an entry called a pivot.
# All pivot entries are powers of p.  If a pivot entry is p^v, then
# + all entries to the left are divisible by p^(v+1)
# + all entries to the right are divisible by p^v
# + all entries above or below are in the range {0,...,p^v - 1}
# These conditions force many entries to be zero.  I think that
# they characterise the result up to reordering the rows.  We use the
# following ordering:
# + If two rows have different valuations, then the one with lower
#    valuation comes first
# + If two rows have the same valuation, then the one with the pivot
#    further to the left comes first.
# The component x in the return value gives information abot the pivots.
# Explicitly, if the i'th entry in x is [j,v] then there is a pivot entry
# of p^v in position (i,j).

Zpl_reduce := proc(M,p)
 local L,L1,P,P1,r,c,i,j,k,h,m,J,K,v,v_min,v_min_pos,pivots,cmp,x;
 L := Copy(M);
 r,c := Dimension(M);
 P := Matrix(r,r);
 for i from 1 to r do P[i,i] := 1; od;
 v := Matrix(r,c);
 i := 0;
 J := {seq(j,j=1..r)};
 K := {seq(k,k=1..c)};
 pivots := NULL;
 v_min_pos := [0,0];
 while v_min_pos <> NULL do
  v_min := infinity;
  v_min_pos := NULL;
  for k in K do
   for j in J do
    v[j,k] := padic_val(L[j,k],p);
    if v[j,k] < v_min then
     v_min := v[j,k];
     v_min_pos := [j,k];
    fi;
   od;
  od;
  if v_min_pos = NULL then
   break;
  fi;
  j,k := op(v_min_pos);
  pivots := pivots,[j,k,v_min];
  m := p^v_min/L[j,k];
  RowOperation(L,j,m,inplace=true);
  RowOperation(P,j,m,inplace=true);
  for h from 1 to r do
   if h <> j then
    m := (L[h,k] - modp(L[h,k],p^v_min))/p^v_min;
    RowOperation(L,[h,j],-m,inplace=true);
    RowOperation(P,[h,j],-m,inplace=true);
   fi;
  od;
  J := sort(J minus {j});
  K := sort(K minus {k});
 od;
 cmp := proc(x,y)
  if x[3] < y[3] then return true; fi;
  if x[3] > y[3] then return false; fi;
  return evalb(x[2] < y[2]);
 end:
 pivots := sort([pivots],cmp);
 L1 := convert(L,listlist);
 P1 := convert(P,listlist);
 L1 := Matrix([seq(L1[x[1]],x in pivots),seq(L1[j],j in J)]);
 P1 := Matrix([seq(P1[x[1]],x in pivots),seq(P1[j],j in J)]);
 return [L1,P1,[seq([x[2],x[3]],x in pivots)]];
end:

######################################################################
# This is an implementation of the p-local integers that can be
# used with LinearAlgebra[Generic][SmithForm].  However, Smith
# forms are not unique, and it does not seem easy to control which
# version we get if we use LinearAlgebra[Generic][SmithForm].
# The above function Zpl_reduce does essentially the same job
# but with a more precisely specified result.

Zpl[`0`] := 0;
Zpl[`1`] := 1;
Zpl[`+`] := `+`;
Zpl[`-`] := `-`;
Zpl[`*`] := `*`;
Zpl[`=`] := `=`;

Zpl[Quo] := proc(a,b,r)
 local b0,q0,r0;
 b0 := p^padic_val(b,p);
 r0 := modp(a,b0);
 q0 := (a - r0)/b;
 if nargs >= 3 then r := r0; fi;
 return q0;
end:

Zpl[Rem] := proc(a,b,q)
 local b0,q0,r0;
 b0 := p^padic_val(b,p);
 r0 := modp(a,b0);
 q0 := (a - r0)/b;
 if nargs >= 3 then q := q0; fi;
 return r0;
end:

Zpl[EuclideanNorm] := ((m) -> padic_val(m,p));
Zpl[UnitPart] := ((m) -> m/p^padic_val(m,p));
Zpl[Gcdex] := proc(a,b,s,t)
 local u,v;
 u := padic_val(a,p);
 v := padic_val(b,p);
 if u <= v then
  if nargs >= 4 then
   s := p^u/a; t := 0;
  fi;
  return p^u;
 else
  if nargs >= 4 then
   s := 0; t := p^v/b;
  fi;
  return p^v;
 fi;
end:


text:
# We identify R^4 with the quaternions by the rule
# [x1,x2,x3,x4] |-> x1 i + x2 j + x3 k + x4.

`mu/H` := proc(a,b)
 if nargs = 0 then
  return [0,0,0,1];
 elif nargs = 1 then
  return args[1];
 elif nargs > 2 then
  return `mu/H`(a,`mu/H`(args[2..-1]));
 else
  return
  [  a[1]*b[4] + a[2]*b[3] - a[3]*b[2] + a[4]*b[1] ,
   - a[1]*b[3] + a[2]*b[4] + a[3]*b[1] + a[4]*b[2] ,
     a[1]*b[2] - a[2]*b[1] + a[3]*b[4] + a[4]*b[3] ,
   - a[1]*b[1] - a[2]*b[2] - a[3]*b[3] + a[4]*b[4]
  ];
 fi;
end:

`conj/H` := proc(a)
 [-a[1],-a[2],-a[3],a[4]];
end:

`square_norm/H` := proc(a) local i; return add(a[i]^2,i=1..4); end:

`norm/H` := proc(a) local i; return sqrt(add(a[i]^2,i=1..4)); end:

`inv/H` := (a) -> `conj/H`(a) /~ `square_norm/H`(a);

`phi/angles/H` := (t) ->
 [cos(t[1])*cos(t[2]),cos(t[1])*sin(t[2]),sin(t[1])*cos(t[3]),sin(t[1])*sin(t[3])];

# This is essentially a |-> a * i * (conjugate of a)
hopf_map := (a) ->
 [a[1]^2-a[2]^2-a[3]^2+a[4]^2,
  2*a[1]*a[2]+2*a[3]*a[4],
  2*a[1]*a[3]-2*a[2]*a[4]];

`rotation_matrix/H` := (a) -> Matrix(
 [[a[1]^2-a[2]^2-a[3]^2+a[4]^2,
   2*a[1]*a[2]-2*a[3]*a[4],
   2*a[1]*a[3]+2*a[2]*a[4]],
  [2*a[1]*a[2]+2*a[3]*a[4],
   -a[1]^2+a[2]^2-a[3]^2+a[4]^2,
   -2*a[1]*a[4]+2*a[2]*a[3]],
  [2*a[1]*a[3]-2*a[2]*a[4],
   2*a[1]*a[4]+2*a[2]*a[3],
   -a[1]^2-a[2]^2+a[3]^2+a[4]^2]]
  ) / (a[1]^2+a[2]^2+a[3]^2+a[4]^2);


text:
with(LinearAlgebra,
     Multiply, Transpose):
with(Groebner,
     Basis, Reduce, InterReduce, LeadingTerm, LeadingMonomial, TestOrder):

writeto("output.txt"):

truncatePolynomial := proc (f, order_1, order_2)
local poly, leading_coeff_1, leading_mon_1, leading_term,
    curr_index, polys:

    poly := expand(f):

    if evalb(type(poly, `+`)) then
        leading_coeff_1, leading_mon_1 := LeadingTerm(poly, order_1):
        leading_term                   := leading_coeff_1 * leading_mon_1:
        curr_index                     := 1:

        polys := sort([op(poly)], (b, a) -> TestOrder(a, b, order_2)):

        while evalb(polys[curr_index] <> leading_term) do
            curr_index := curr_index + 1:
        end do:

        if curr_index = 1 then
            return polys[1]:
        else
            return add(x, x in polys[1..curr_index]):
        end if:
    else
        return poly:
    end if:
end proc:

basisConversion := proc (basis, order_1, order_2)
local F_original, F_sanity_check, F, F_t, num_iter,
    F_t_gb, multipliers,
    G, repeat, curr_index, num_elements:

    F_original := Basis(basis, order_1):

    lprint("Step 1"):
    F   := Basis(basis, order_1):
    F_t := map(v -> truncatePolynomial(v, order_1, order_2), F):
    lprint("Current F", F):
    lprint("Current F_t", F_t):

    num_iter := 1:

    while true do
        lprint("Iteration ", num_iter):
        num_iter := num_iter + 1:

        lprint("Step 2"):
        F_t_gb, multipliers := Basis(F_t, order_2, output=extended):
        lprint("Matrix of multipliers M': ", multipliers):
        lprint("H (= M' F_t): ", F_t_gb):

        lprint("Step 3"):
        G := convert(simplify(
            Multiply(convert(multipliers, Matrix), Transpose(convert(F, Matrix)))), list):
        lprint("G (= M' * F): ", G):

        lprint("Step 4"):
        repeat       := false:
        curr_index   := 1:
        num_elements := numelems(F_t_gb):
        while curr_index < num_elements do
            if evalb(LeadingMonomial(F_t_gb[curr_index], order_2)
                     <> LeadingMonomial(G[curr_index], order_2)) then
                lprint("There are the witness polynomials that prove"\
                       "G_s is not empty (g_j, h_j) respectively ",
                       F_t_gb[curr_index], G[curr_index]):
                repeat := true:
                break:
            end if:
            curr_index := curr_index + 1:
        end do:

        #F   := G:
        F   := InterReduce(G, order_2):

        F_sanity_check := Basis(F, order_1):
        lprint("GB w.r.t. >1 of current F", F_sanity_check):
        lprint("GB w.r.t. >1 of original input", F_original):
        ASSERT(evalb(F_original = F_sanity_check)):

        if repeat = false then
            lprint("Done"):
            return F:
        else
            F_t := map(v -> truncatePolynomial(v, order_1, order_2), F):
            lprint("Current F", F):
            lprint("Current F_t", F_t):
        end if:
    end do:

end proc:

testBasisConversion := proc (basis, order_1, order_2)
local output_1, output_2:
    lprint():
    lprint("Basis conversion of ", basis, " from ", order_1, " to ", order_2):
    output_1 := basisConversion(basis, order_1, order_2):
    output_2 := Basis(basis, order_2):
    lprint("Result obtained using implemented algorithm ", output_1):
    lprint("Result obtained using Maple Basis algorithm ", output_2):
    lprint("Are these results the same? ", evalb(output_1 = output_2)):
end proc:

# ---------------------------------------------------------------------------
# Testing
testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(x, y, z)):
#testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(x, z, y)):
#testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(y, x, z)):
#testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(y, z, x)):
#testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(z, x, y)):
#testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], grlex(x, y, z), plex(z, y, x)):
#testBasisConversion([y^2-x,x^2-y*z-1,z^2-x], plex(x, y, z), grlex(x, y, z)):
#testBasisConversion([x*y+z-x*z, x^2-z, 2*x^3-x^2*y*z-1], tdeg(x, y, z), plex(z, y, x)):
#testBasisConversion([x + y + z, x*y + y*z + z*x, x*y*z-1], grlex(x, y, z), plex(x, y, z)):
#testBasisConversion([x + y + z + u, x*y + y*z + z*u + u*x, x*y*z + y*z*u + z*u*x + u*x*y, x*y*z*u-1], grlex(x, y, z, u), plex(x, y, z, u)):
# ---------------------------------------------------------------------------

max_stars_repo_name: typesAreSpaces/Basis-Conversion

max_issues_repo_name: typesAreSpaces/Basis-Conversion

max_forks_repo_name: typesAreSpaces/Basis-Conversion


text:
# Andrews-Paule identity. See §7.1 in “Multiple binomial sums”.

S := Sum(z^n*Sum(Sum(Multinomial([i,j])^2*Multinomial([2*n-2*j,2*n-2*i]), i=0..infinity), j=0..infinity), n=0..infinity);

R, ord := BinomSums[sumtores](S, u);

# Checking
BinomSums[rser](R, ord, 6);
BinomSums[computesum](S, 5);

# We obtain the following differential operator annihilating the generating function S:
dop := 1048576*D^6*z^8 + 2883584*D^6*z^7-40960*D^6*z^6 +
22020096*D^5*z^7-29696*D^6*z^5 + 64225280*D^5*z^6 + 1296*D^6*z^4 +
1269760*D^5*z^5 + 146407424*D^4*z^6-605184*D^5*z^4 + 455041024*D^4*z^5 +
16848*D^5*z^3 + 24412672*D^4*z^4 + 363069440*D^3*z^5-3632352*D^4*z^3 +
1211465728*D^3*z^4 + 59292*D^4*z^2 + 106845184*D^3*z^3 +
305827840*D^2*z^4-7352832*D^3*z^2 + 1109626112*D^2*z^3 + 58320*D^3*z +
139138736*D^2*z^2 + 60272640*D*z^3-4247073*D^2*z + 244005120*D*z^2 + 9720*D^2 +
42117840*D*z + 691200*z^2-374625*D + 3369600*z + 996300;

# Conversion to a differential equation with initial condition
init := BinomSums[computesum](S, 6):
deq := {
  DETools[diffop2de](dop, y(z), [D,z]),
  seq( (D@@i)(y)(0) = i!*coeff(init, z, i), i=0..4 )
  };

# Conversion to a recurrence.
rec := gfun[diffeqtorec](deq, y(z), u(n));

# Resolution of the recurrence.
rsolve(rec, u(n));

max_stars_repo_name: lairez/binomsum

max_issues_repo_name: lairez/binomsum

max_forks_repo_name: lairez/binomsum


text:
program sample29;
	/* Calculator program	*/
	/*  c n : clear & set n	*/
	/*  + n : add n			*/
	/*  - n : subtract n	*/
	/*  * n : multiply n	*/
	/*  / n : divide by n		*/
	/*  o : off				*/
var unused1: integer;
    UnusedArrayForTest: array[200] of char;
procedure gcmlcm(m, n, gc, lc : integer);
	/* gc := GCM(m,n), lc := LCM(m,n) */
	/* m and n are not changed        */
var a,b,r : integer;
begin
a := m;
b := n;
while b <> 0 do begin
r := a - (a div b) * b;
a := b;
b := r
end;
gc := a;
lc := (m div gc) * n
end;
procedure abs(a, b : integer);
begin
if a < 0 then b := -a  else b := a
end;
procedure gcm(a, b, gc : integer);
var lc, aa, bb : integer;
begin
if (a = 0) or (b = 0) then gc := 1
else begin
call abs(a,aa);  call abs(b,bb);
call gcmlcm(aa, bb, gc, lc)
end
end;
procedure lcm(a, b, lc : integer);
var gc, aa, bb : integer;
begin
if (a = 0) or (b = 0) then lc := 1
else begin
call abs(a,aa);  call abs(b,bb);
call gcmlcm(aa, bb, gc, lc)
end
end;
var unusedchar : char;
procedure reduce(a1, a2 : integer);
  var gc:integer;
begin
if a1 = 0 then begin a2 := 1; return end;
if a2 = 0 then begin a1 := 1; return end;
if a2 < 0 then begin a1 := -a1;      a2 := - a2 end;
 call gcm(a1, a2, gc);
a1 := a1 div gc;
a2 := a2 div gc
end;

procedure sum(x1, x2, y1, y2 : integer);
var lc, y11 : integer;
begin
call lcm(x2, y2, lc);
x1 := x1 * (lc div x2);
y11 := y1 * (lc div y2);
x1 := x1 + y11;
x2 := lc;
call reduce(x1, x2)
end;
procedure sub(x1, x2, y1, y2 : integer);
var lc, y11 : integer;
begin
call sum(x1, x2, -y1, y2)
end;
procedure mult(x1, x2, y1, y2 : integer);
var gc,y22,y11 : integer;
begin
call gcm(x1, y2, gc);
x1 := x1 div gc;
y22 := y2 div gc;
call gcm(x2, y1, gc);
x2 := x2 div gc;
y11 := y1 div gc;
x1 := x1 * y11;
x2 := x2 * y22;
call reduce(x1, x2)
end;
procedure divide(x1, x2, y1, y2 : integer);
begin
call mult(x1, x2, y2, y1)
end;
var unusedarray : array[100] of char;
procedure printfinal(a, b : integer);
begin
if a = 0 then writeln('Final Result =', a)
else if b = 1 then writeln('Final Result =', a)
else writeln('Final Result =', a, '/', b)
end;
procedure printtemp(a, b : integer);
begin
if a = 0 then writeln('Temporary Result =', a)
else if b = 1 then writeln('Temporary Result =', a)
else writeln('Temporary Result =', a, '/', b)
end;

var	x1, x2, y1,y2 : integer;
var	com :char;
endflag : boolean;
begin
writeln('   *** Calculator -- h for help ***');
x1 := 0;  x2 :=1;
endflag := false;
while not endflag do begin
writeln(' Please input command :');
readln(com, y1);  y2 := 1;
if (com = 'c')  or (com = 'C') then begin x1 := y1; x2 := y2 end
else if com = '+' then call sum(x1, x2, y1, y2)
else if com = '-' then call sub(x1, x2, y1, y2)
else if com = '*' then call mult(x1, x2, y1, y2)
else if com = '/' then call divide(x1, x2, y1, y2)
else if (com = 'o') or (com = 'O') then endflag := true
else begin
writeln;
writeln('Calculator Usage:');
writeln('  c number : clear & set it');
writeln('  + number : add it');
writeln('  - number : subtract it');
writeln('  * number : multiply it');
writeln('  / number : divide by it');
writeln('  o        : off(terminate execution)');
writeln
end;
if endflag then call printfinal(x1, x2)
else call printtemp(x1, x2)
end
end.

max_issues_repo_name: shouth/LanguageProcessing

max_forks_repo_name: Hiroya-W/lang-processing

lm_label:
1. Yes
2. Yes


text:
# Strehl's identity. See §7.2.1 in “Multiple binomial sums”.

# The identity is S1 = S2.
S1 := Sum(z^n*Sum(Binomial3(n,k)*Multinomial([n,k])*Sum(Binomial3(k,j)^3, j=0..infinity), k=0..infinity), n=0..infinity);
S2 := Sum(z^n*Sum(Binomial3(n,k)^2*Binomial3(n+k,k)^2, k=0..infinity), n=0..infinity);

# Quick check
BinomSums[computesum](S1, 5) - BinomSums[computesum](S2, 5);

R1, ord1 := BinomSums[sumtores](S1, u);

# Consistency check
BinomSums[rser](R1, ord1, 6);

R2, ord2 := BinomSums[sumtores](S2, u);

# Consistency check
BinomSums[rser](R2, ord2, 6);

# For R1 and R2 we find the same Picard Fuchs equation :
# D^3 + (6*t^2 - 153*t + 3)/(t^3 - 34*t^2 + t)*D^2 + (7*t^2 - 112*t + 1)/(t^4 - 34*t^3 + t^2)*D + (t - 5)/(t^4 - 34*t^3 + t^2)
# Since the initial conditions are the same, S1 = S2.


text:
TITLE
	SNDP_stochastic_MIP;

STOCHASTIC

SCENARIO
	SCEN := 1..3;

INDEX
	VAR_INDEX := (_A12, _B12, _A13, _B13, _A32, _A33, _C24, _C34) : 4;	! index should be created from 4 letters (avoid letter conflict)
	BIN_VAR_INDEX := (_C2, _C3) : 3;
	CONSTR_INDEX := 1..11;

PROBABILITIES
	Prob[SCEN] := (0.25, 0.5, 0.25);

DATA
	Cost[VAR_INDEX] := (2, 2, 2, 2, 1, 0, -11, -10);		!vector qT, transportation costs, selling price (signs are reverted in order to transform to MIN problem)
	Fixed_Cost[BIN_VAR_INDEX] := (2000, 2000);			!vector c, set up costs (signs are reverted in order to transform to MIN problem)
	T[CONSTR_INDEX, BIN_VAR_INDEX] := (	0,		0
						0,		0
						0,		0
						0,		0
						0,		0
						0,		0
						0,		0
						0,		0
						0,		0
						5000,		0
						0,		5000);	!matrix T (technological in 2 stage model)
	W[CONSTR_INDEX, VAR_INDEX] := (	1, 0, 0, 0, 1, 0, -2, 0,
					-1, 0, 0, 0, -1, 0, 2, 0,
					0, 0, 1, 0, 0, 1, 0, -2,
					0, 0, -1, 0, 0, -1, 0, 2,
					0, 1, 0, 0, 0, 0, -3, 0,
					0, -1, 0, 0, 0, 0, 3, 0,
					0, 0, 0, 1, 0, 0, 0, -3,
					0, 0, 0, -1, 0, 0, 0, 3,
					0, 0, 0, 0, 0, 0, -1, -1,
					0, 0, 0, 0, 0, 0, -1, 0,
					0, 0, 0, 0, 0, 0, 0, -1);	!matrix W (recourse in 2 stage model)
RANDOM DATA
	h[SCEN, CONSTR_INDEX] := (0, 0, 0, 0, 0, 0, 0, 0, -2000, 0, 0
				0, 0, 0, 0, 0, 0, 0, 0, -5000, 0, 0
				0, 0, 0, 0, 0, 0, 0, 0, -8000, 0, 0);

STAGE1 BINARY VARIABLES
	y[BIN_VAR_INDEX];

STAGE2 VARIABLES
	x[VAR_INDEX];

MIN									!MAX was transformed to MIN
	Objective = sum(BIN_VAR_INDEX: Fixed_Cost * y) + sum(VAR_INDEX: Cost * x);

SUBJECT TO
    	Constr[CONSTR_INDEX]: sum(VAR_INDEX: W * x) >= h - sum(BIN_VAR_INDEX: T * y);

END

max_stars_repo_name: pashtetGP/optconvert

max_issues_repo_name: pashtetGP/optconvert

max_forks_repo_name: pashtetGP/optconvert


text:
(* 2020 Susi Lehtola and Miguel A. L. Marques

   This script is used to check the convergence of the series
   expansions of the various attenuation functions, and to
   establish cutoff values for their series expansions.
*)

$include "attenuation.mpl"

(* For exact results we use 1000 digit *)
exact_digits := 1000:
(* Double precision has 15 digits *)
double_digits := 15:
(* An acceptable relative error at double precision is 1e-13 *)
error_thr := 1e-13:

check_asymptotics := proc(f, a);
    (* Grid spacing *)
    da := 0.01:
    (* Value for a to start with *)
    amax := 5:

    (* First, we compare we find a point where to make the cutoff *)
    for acut from amax by -da to da do
        (* Exact result *)
        Digits := exact_digits:
        exact := evalf(f(acut)):
        (* Double precision *)
        Digits := double_digits:
        local doubleprec := evalf(f(acut)):
        (* Error *)
        local err := doubleprec/exact-1:
        #printf("Cutoff %e exact % e double % e error % e\n", acut, exact, doubleprec, err):
        if (abs(err) < error_thr) then
            break:
        end if:
    end do:

    (* Now we find the series expansion that has the same level of agreement *)
    for expord from 4 to 1000 by 2 do
        f_series := a -> eval(throw_out_large_n(convert(series(f(b), b=infinity, expord+padding_order), polynom), expord), b=a):
        local ser := evalf(f_series(acut)):
        local err := ser/exact-1:
        #printf("Expansion order %3d original % e asymptotic % e error % "
        #       "e\n", expord, exact, ser, err);
        if (abs(err) < error_thr) then
            (* Check if the expansion is accurate everywhere *)
            accurate := true:
            for aval from acut by da to amax do
                (* Exact result *)
                Digits := exact_digits:
                lexact := evalf(f(aval)):
                (* Double precision *)
                Digits := double_digits:
                lser := evalf(f_series(aval)):
                (* Error *)
                local lerr := lser/lexact-1:
                #printf("a= %e exact % e double % e error % e\n", aval, lexact, lser, lerr):
                if (abs(lerr) > error_thr) then
                    accurate := false:
                    break:
                end if:
            end do:
            if accurate then
                break:
            end if:
        end if:
    end do:

    printf("Cutoff should be at a= %.2f and use a series expansion of "
           "order %d\n", acut, expord):
end proc:

printf("attenuation_erf\n"):
check_asymptotics(attenuation_erf0, a):

printf("\nattenuation_erf_f2\n"):
check_asymptotics(attenuation_erf_f20, a):

printf("\nattenuation_erf_f3\n"):
check_asymptotics(attenuation_erf_f30, a):

printf("\nattenuation_gau\n"):
check_asymptotics(attenuation_gau0, a):

printf("\nattenuation_yukawa\n"):
check_asymptotics(attenuation_yukawa0, a):


text:
(*
 Copyright (C) 2018 Susi Lehtola

 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: gga_exc *)

(* x has a different definition in the Chachiyo paper  *)
chachiyo_x := x -> 2/9 * (Pi/3)**(1/3) * (2**(-1/3) * x):

(* equation 1 *)
chachiyo_f0 := x -> (3*x^2 + Pi^2*log(x+1)) / ((3*x + Pi^2)*log(x+1)):

chachiyo_f := x -> chachiyo_f0(chachiyo_x(x)):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(chachiyo_f, rs, z, xs0, xs1):


text:
#If X ~ Exp(λ) then kX ~ Exp(λ/k).

#Equivalent: If X ~ Exp(α) then kX ~ Exp(kα)

#Proof:
PDF_exponential := (alpha, x) -> exp(-x/alpha)/alpha;

PDF_kX := (alpha, x, k) -> PDF_exponential(alpha, x/k)/k;
simplify(PDF_kX(alpha, x, k));

PDF_exp_scaled := (alpha, x, k) -> PDF_exponential(k*alpha, x);
simplify(PDF_exp_scaled(alpha, x, k));

evalb(PDF_kX(alpha, x, k) = PDF_exp_scaled(alpha, x, k));

max_stars_repo_name: vmchale/hakaru

max_issues_repo_name: vmchale/hakaru

max_forks_repo_name: vmchale/hakaru


text:
(*
 Copyright (C) 2021 Susi Lehtola

 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 *)

(* Data in table 1 *)
w20_a0 := proc(z)
  if (z=0) then
    (1-log(2))/Pi^2
  elif (z=1) then
    (1-log(2))/(2*Pi^2)
  end if
end proc:

w20_a1 := proc(z)
  if (z=0) then
    (9*Pi/4)^(-1/3) * 1/(4*Pi^3) * ( 7*Pi^2/6 - 12*log(2) - 1 )
  elif (z=1) then
    2^(-4/3) * (9*Pi/4)^(-1/3) * 1/(4*Pi^3) * ( 13*Pi^2/12 - 12*log(2) + 1/2 )
  end if
end proc:

w20_b0 := proc(z)
  if (z=0) then
    -0.071100 + log(2)/6 - 3/(4*Pi^2)*evalf(Zeta(3))
  elif (z=1) then
    -0.049917 + log(2)/6 - 3/(4*Pi^2)*evalf(Zeta(3))
  end if
end proc:

w20_b1 := proc(z)
  if (z=0) then
    -0.01
  elif (z=1) then
    (* Compare eq 12 to eqs 15 and 16 *)
    0
  end if
end proc:

w20_f0 := -0.9:
w20_f1 := 1.5:
w20_f2 := 0:

(* eq 6 *)
w20_cs := z -> 3/10*(9*Pi/4)^(2/3) * 1/2*((1+z)^(5/3) + (1-z)^(5/3)):
(* eq 7 *)
w20_cx := z -> -3/(4*Pi)*(9*Pi/4)^(1/3) * 1/2*((1+z)^(4/3) + (1-z)^(4/3)):

(* eq 8 *)
w20_ec := (rs, z) -> -w20_a0(z)/2 * log(1 + w20_DF(rs,z,w20_f0-w20_cx(z))/rs + w20_E(rs,z)/rs^(3/2) + w20_DF(rs,z,w20_f2-w20_cs(z))/rs^2) + w20_G(rs,z):

(* eqs 9 and 11 only differ by the f_i - c_j(z) term *)
w20_DF := (rs, z, cfterm) -> exp(-2*w20_b0(z)/w20_a0(z)) - 2 * (1 - exp(-(rs/100)^2))*( cfterm/w20_a0(z) + 1/2 * exp(-2*w20_b0(z)/w20_a0(z)) ):

(* eq 10 *)
w20_E := (rs, z) -> - 2*(1 - exp(-(rs/100)^2))*w20_f1 / w20_a0(z):

(* eq 12, rewritten in terms of a decaying exponential to avoid overflow *)
w20_G := (rs, z) -> rs*exp(-(rs/100)^2) / (exp(-(rs/100)^2) + 10*rs^(5/4)) * ( -w20_a1(z)*log(1 + 1/rs) + w20_b1(z) ):

(* eq 17 *)
f_w20 := (rs, zeta) -> w20_ec(rs,0) + (w20_ec(rs,1) - w20_ec(rs,0))*f_zeta(zeta):

f := (rs, zeta) -> f_w20(rs, zeta):