program sample11p;
var n : integer;
procedure kazuyomikomi;
begin
	writeln('input the number of data');
	readln(n)
end;
var sum : integer;
procedure wakakidasi;
begin
	writeln('Sum of data = ', sum)
end;
var data : integer;
procedure goukei;
begin
	sum := 0;
	while n > 0 do begin
		readln(data);
		sum := sum + data;
		n := n - 1
	end
end;
begin
	call kazuyomikomi;
	call goukei;
	call wakakidasi
end.


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

`eta/nonempty_subsets` := (A::set) -> `if`(nops(A)=1,A,FAIL);

`gamma/nonempty_subsets` := (A::set,B::set) -> (p) -> proc(U,V)
 map(op,map(u -> V[u],U));
end;


func $fact (
 var %n i32) i32 {
@fred2
 if (ne i32 i32 (dread i32 %n, constval i32 1)) {
     brfalse @fred2 (dread i32 %n)
@fred1
     return (constval i32 0) }
 else {
     return (constval i32 1) } }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


program change;  /* sample2a.mpl */ { compute change program. What is change? }
             { no 5, 50, 500, & 5000 yen used }
  var n, count : integer;
begin
  writeln('please input change');  readln(n);    count := 0;
while n>0 do begin
    while n>=10 do begin
        while n>=  100 do begin
           while n>=1000 do begin
             while n  >=10000 do begin
               count := count +1; n := n-10000;
             end;
             if count >0 then writeln('10000 yen : ',  count);
             count := 0;
             if n < 1000 then break;
             count := count +1; n := n-1000;
           end;
             if count >0 then writeln(' 1000 yen : ',  count);
             count := 0;
             if n < 100 then break;
              count := count +1; n := n-100;
         end;
         if count >0 then     writeln('  100 yen : ',  count);
             count := 0;
             if n < 10 then break;
              count := count +1; n := n-10;
      end;
         if count >0 then     writeln('   10 yen : ',  count);
             count := 0;
             if n < 1 then break;
              count := count +1; n := n-1;
 end;
 if count >            0 then writeln('    1 yen : ',  count);
/*  if n !=0 then break;  */
end.


var $myStruct < struct{
    @number i32,
    @p <* i8> }>
func $main ()i32{
     #Character
     var %sChar i8
     var %usChar i8
     #signed and unsigned short integer
     var %shortInt i16
     var %shortInt2 i16
     var %sShortInt i16
     var %sShortInt2 i16
     var %usShortInt i16
     var %usShortInt2 i16
     #signed and unsigned integer
     var %int1 i32
     var %sInt i32
     var %usInt i32
     var %usInt2 i32
     #signed and unsigned long integer
     var %long1 i64
     var %long2 i64
     var %sLong1 i64
     var %sLong2 i64
     var %usLong i64
     var %usLong2 i64
     var %lLong1 i64
     var %iLong2 i64
     var %sLlong1 i64
     var %sLlonog2 i64
     var %usLlong i64
     var %usLlong2 i64
     #float
     var %Float f32
     #double
     var %Double f64
     #long double
     var %lDouble f64
     #Address
     var %array <[10] i8>
     iassign<* i8>(
      array 1 a64<*[10] i8>(addrof a64 %array, constval i64 1),
      constval i32 120)}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


main()inline{
	Trace3(i, j, k);
	do(7){
		Trace3(i, j, k);
		do(3){
			Trace3(i, j, k);
			do(5) Trace3(i, j, k);
		}
	}
	i = j < k ? j : k;
}


kernelopts(assertlevel=1):
assert_count := 0;
assert_verbosely := false;
assert_stop_on_fail := true;

#@ _ASSERT
_ASSERT := proc(p,s::string)
 global assert_count,assert_verbosely,assert_stop_on_fail,assert_fail_data;
 assert_count := assert_count+1;
 if assert_verbosely then printf("Checking: %s\n",s); fi;
 if not p then
  assert_fail_data := args[3..-1];
  if assert_stop_on_fail then
   error cat("Assertion failed: ",s);
  else
   printf(cat("Assertion failed: ",s,"\n"));
  fi;
 fi;
end:

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

# checklist is a list of checking functions.  check_all() runs all
# the checking functions in the list.  add_check() adds a function
# to the list.

checklist := []: #@ checklist

check_all := proc()
 global assert_count;
 local C;

 assert_count := 0;

 for C in checklist do C(); od:
end:

add_check := proc(C)
 global checklist;

 checklist := [op(checklist),C];
end:

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

num_steps := 100;

check_set_generic := proc(S::string,params := [])
 local
  small_context,params0,
  is_element,random_element,list_elements,count_elements,is_equal,is_leq,
  `has/is_element`,`has/random_element`,`has/list_elements`,
  `has/count_elements`,`has/is_equal`,`has/is_leq`,
  p,x,y,t,i,j,L,L_full,L_rand,L_rand_ok,L_rand_bad,found;

 printf("\nChecking %s\n",S);

 is_element := eval(convert(cat("is_small_element/",S),name));

 if type(is_element,procedure) then
  small_context := true;
  is_element      := eval(convert(cat("is_small_element/"    ,S),name));
  random_element  := eval(convert(cat("random_small_element/",S),name));
  list_elements   := eval(convert(cat("list_small_elements/" ,S),name));
  count_elements  := eval(convert(cat("count_small_elements/",S),name));
  is_equal        := eval(convert(cat("is_equal/"            ,S),name));
  is_leq          := eval(convert(cat("is_leq/"              ,S),name));
  printf("Elements are filtered by size\n");
 else
  small_context := false;
  is_element      := eval(convert(cat("is_element/"    ,S),name));
  random_element  := eval(convert(cat("random_element/",S),name));
  list_elements   := eval(convert(cat("list_elements/" ,S),name));
  count_elements  := eval(convert(cat("count_elements/",S),name));
  is_equal        := eval(convert(cat("is_equal/"      ,S),name));
  is_leq          := eval(convert(cat("is_leq/"        ,S),name));
 fi;

 `has/is_element`     := type(is_element,procedure);
 `has/random_element` := type(random_element,procedure);
 `has/list_elements`  := type(list_elements,procedure);
 `has/count_elements` := type(count_elements,procedure);
 `has/is_equal`       := type(is_equal,procedure);
 `has/is_leq`         := type(is_leq,procedure);

 if `has/is_element` then
  for p in params do is_element := eval(is_element(op(p))); od;
 elif is_element <> NULL then
  printf("Warning: no is_element function has been defined.\n");
 fi;

 if `has/random_element` then
  for p in params do random_element := eval(random_element(op(p))); od;
 elif random_element <> NULL then
  printf("Warning: no random_element function has been defined.\n");
 fi;

 if `has/list_elements` then
  for p in params do list_elements := eval(list_elements(op(p))); od;
 elif list_elements <> NULL then
  printf("Warning: no list_elements function has been defined.\n");
 fi;

 if `has/count_elements` then
  for p in params do count_elements := eval(count_elements(op(p))); od;
 elif count_elements <> NULL then
  printf("Warning: no count_elements function has been defined.\n");
 fi;

 params0 := params;
 if small_context then
  params0 := [op(1..-2,params)];
 fi;

 if `has/is_equal` then
  for p in params0 do is_equal := eval(is_equal(op(p))); od;
 else
  is_equal := (x,y) -> evalb(x = y);
 fi;

 if `has/is_leq` then
  for p in params0 do is_leq := eval(is_leq(op(p))); od;
 elif is_leq <> NULL then
  printf("Warning: no is_leq function has been defined.\n");
 fi;

 L := NULL;

 if `has/random_element` and `has/is_element` then
  printf("Checking is_element on random elements: ");
  L_rand := [seq(random_element(),i=1..10)];
  L_rand_ok,L_rand_bad := selectremove(x -> (x <> FAIL),L_rand);
  t := `and`(true,op(map(is_element,L_rand_ok)));
  if t then
   L := L_rand_ok;
   if L_rand_bad = [] then
    printf("OK\n");
   elif L_rand_ok <> [] then
    printf("OK (but some examples could not be generated)\n");
   else
    printf("Could not generate any examples\n");
   fi;
  else
   printf("FAIL\n");
  fi;
 fi;

 if `has/list_elements` and `has/is_element` then
  printf("Checking is_element on listed elements: ");
  L_full := list_elements;
  if type([L_full],[list]) then
   L := L_full;
   t := `and`(op(map(is_element,L_full)));
   if t then
    printf("OK (%d elements)\n",nops(L_full));
   else
    printf("FAIL\n");
   fi;
  else
   printf("Element list is not a list\n");
   L := [];
   L_full := [];
  fi;
 fi;

 if `has/random_element` and `has/list_elements` and `has/is_element`
     and L_rand_ok <> [] then
  printf("Comparing random elements and listed elements: ");
  t := true;
  for x in L_rand_ok do
   found := false;
   for y in L_full do
    if is_equal(x,y) then
     found := true;
     break;
    fi;
   od;
   if not found then
    t := false;
    break;
   fi;
  od;
  printf(`if`(t,"OK\n","FAIL\n"));
 fi;

 if L <> NULL and `has/is_equal` then
  printf("Checking is_equal: ");
  t := true;
  for i from 1 to nops(L) do
   t := t and is_equal(L[i],L[i]);
   if not t then break; fi;
   if `has/list_elements` then
    for j from i+1 to nops(L) do
     t := t and not(is_equal(L[i],L[j]));
     if not t then break; fi;
    od;
   fi;
   if not t then break; fi;
  od;
  printf(`if`(t,"OK\n","FAIL\n"));
 fi;

 if `has/list_elements` and `has/count_elements` then
  printf("Checking count_elements (%A) vs listed elements: ",count_elements);
  t := evalb(count_elements = nops(L_full));
  printf(`if`(t,"OK\n","FAIL\n"));
 fi;
end:

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

check_map_generic := proc(fs::string,X::string,Y::string,params_f,params_X,params_Y)
 global reason;
 local P_f,P_X,P_Y,list_elements_X,random_element_X,is_element_X,is_element_Y,p,x,y,L,f,ok,i;

 printf("Checking %s : %s -> %s\n",fs,X,Y);

 P_f := `if`(nargs > 3,params_f,[]);
 P_X := `if`(nargs > 4,params_X,P_f);
 P_Y := `if`(nargs > 5,params_Y,P_X);

 list_elements_X := eval(convert(cat("list_elements/",X),name));
 if list_elements_X <> NULL then
  for p in P_X do
   list_elements_X := eval(list_elements_X(op(p)));
  od;
  L := list_elements_X;
 else
  random_element_X := eval(convert(cat("random_element/",X),name));
  if random_element_X = NULL then
   error sprintf("Neither list_elements/%s nor random_element/%s is defined",X,X);
  fi;
  for p in P_X do
   random_element_X := eval(random_element_X(op(p)));
  od;
  L := [seq(random_element_X(),i=1..num_steps)];
 fi;

 f := eval(convert(fs,name));
 for p in P_f do f := eval(f(op(p))); od;

 is_element_X := eval(convert(cat("is_element/",X),name));
 for p in P_X do
  is_element_X := eval(is_element_X(op(p)));
 od;

 is_element_Y := eval(convert(cat("is_element/",Y),name));
 for p in P_Y do
  is_element_Y := eval(is_element_Y(op(p)));
 od;

 ok := true;
 for x in L do
  if not(is_element_X(x)) then
   ok := false;
   reason := ["x is not in X",x];
   break;
  fi;

  y := f(x);

  if not(is_element_Y(y)) then
   ok := false;
   reason := ["f(x) = y is not in Y",x,y];
   break;
  fi;
 od:

 printf(`if`(ok,"OK\n","FAIL\n"));
end:

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

check_binop_generic :=
 proc(fs::string,X::string,Y::string,Z::string,params_f,params_X,params_Y,params_Z)
 global reason;
 local P_f,P_X,P_Y,P_Z,
       list_elements_X,random_element_X,is_element_X,
       list_elements_Y,random_element_Y,is_element_Y,
       is_element_Z,p,x,y,z,L_X,L_Y,f,ok,ns,curry,i;

 printf("Checking %s : %s x %s -> %s\n",fs,X,Y,Z);

 P_f := `if`(nargs > 3,params_f,[]);
 P_X := `if`(nargs > 4,params_X,P_f);
 P_Y := `if`(nargs > 5,params_Y,P_X);
 P_Z := `if`(nargs > 5,params_Z,P_Y);
 curry := false;

 if member("curry",[_rest]) then
  curry := true;
 fi;

 ns := ceil(sqrt(evalf(num_steps)));

 list_elements_X := eval(convert(cat("list_elements/",X),name));
 if list_elements_X <> NULL then
  for p in P_X do
   list_elements_X := eval(list_elements_X(op(p)));
  od;
  L_X := list_elements_X;
 else
  random_element_X := eval(convert(cat("random_element/",X),name));
  if random_element_X = NULL then
   error sprintf("Neither list_elements/%s nor random_element/%s is defined",X,X);
  fi;
  for p in P_X do
   random_element_X := eval(random_element_X(op(p)));
  od;
  L_X := [seq(random_element_X(),i=1..ns)];
 fi;

 list_elements_Y := eval(convert(cat("list_elements/",Y),name));
 if list_elements_Y <> NULL then
  for p in P_Y do
   list_elements_Y := eval(list_elements_Y(op(p)));
  od;
  L_Y := list_elements_Y;
 else
  random_element_Y := eval(convert(cat("random_element/",Y),name));
  if random_element_Y = NULL then
   error sprintf("Neither list_elements/%s nor random_element/%s is defined",Y,Y);
  fi;
  for p in P_Y do
   random_element_Y := eval(random_element_Y(op(p)));
  od;
  L_Y := [seq(random_element_Y(),i=1..ns)];
 fi;

 f := eval(convert(fs,name));
 for p in P_f do f := eval(f(op(p))); od;

 is_element_X := eval(convert(cat("is_element/",X),name));
 for p in P_X do
  is_element_X := eval(is_element_X(op(p)));
 od;

 is_element_Y := eval(convert(cat("is_element/",Y),name));
 for p in P_Y do
  is_element_Y := eval(is_element_Y(op(p)));
 od;

 is_element_Z := eval(convert(cat("is_element/",Z),name));
 for p in P_Z do
  is_element_Z := eval(is_element_Z(op(p)));
 od;

 ok := true;
 for x in L_X do
  if not(is_element_X(x)) then
   ok := false;
   reason := ["x is not in X",x];
   break;
  fi;

  for y in L_Y do
   if not(is_element_Y(y)) then
    ok := false;
    reason := ["y is not in Y",y];
    break;
   fi;

   if curry then
    z := f(x,y);
   else
    z := f(x)(y);
   fi;

   if not(is_element_Z(z)) then
    ok := false;
    reason := ["f(x,y) = z is not in Z",x,y,z];
    break;
   fi;
  od;
 od:

 printf(`if`(ok,"OK\n","FAIL\n"));
end:

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

check_operad := proc(O::string,params,A,B,C)
 global reason;
 local is_element,is_equal,random_element,eta,gamma,
       x,i,p,q,qp,Fp,Fq,Fqp,U,V,W,ok,c,b;

 printf("Checking operad structure for %s: ",O);

 is_element     := eval(convert(cat("is_element/",O),name));
 is_equal       := eval(convert(cat("is_equal/",O),name));
 random_element := eval(convert(cat("random_element/",O),name));
 eta            := eval(convert(cat("eta/",O),name));
 gamma          := eval(convert(cat("gamma/",O),name));

 for x in params do
  is_element     := eval(is_element(op(x)));
  is_equal       := eval(is_equal(op(x)));
  random_element := eval(random_element(op(x)));
  eta            := eval(eta(op(x)));
  gamma          := eval(gamma(op(x)));
 od:

 for i from 1 to num_steps do
  p := `random_element/epi`(A,B)();
  q := `random_element/epi`(B,C)();
  qp := `compose/maps`(A,B,C)(p,q);
  Fp := fibres(A,B)(p);
  Fq := fibres(B,C)(q);
  Fqp := fibres(A,C)(qp);
  U := random_element(C)();
  V := table({seq(c = random_element(Fq[c])(),c in C)});
  W := table({seq(b = random_element(Fp[b])(),b in B)});
  ok := `check_gamma_axiom`(A,B,C,p,q,U,V,W,
   is_element,is_equal,gamma);
  if not ok then printf("FAIL\n");
   reason := ["gamma axiom failed",A,B,C,eval(p),eval(q),eval(U),eval(V),eval(W),reason];
   return false;
  fi;
 od:

 printf("OK\n");
end:

check_operad_morphism := proc(f::string,f_params,
                              C::string,C_params,
                              D::string,D_params,
                              A,B)
 global reason;
 local is_el_CC,is_equal_CC,gamma_CC,
       is_el_DD,is_equal_DD,gamma_DD,
       rand_CC,phi,x,i,p,Fp,U,V,ok,b;

 printf("Checking operad morphism %s : %s -> %s\n",f,C,D);

 is_el_CC    := eval(convert(cat("is_element/",C),name));
 is_equal_CC := eval(convert(cat("is_equal/",C),name));
 gamma_CC    := eval(convert(cat("gamma/",C),name));
 rand_CC     := eval(convert(cat("random_element/",C),name));

 is_el_DD    := eval(convert(cat("is_element/",D),name));
 is_equal_DD := eval(convert(cat("is_equal/",D),name));
 gamma_DD    := eval(convert(cat("gamma/",D),name));

 phi         := eval(convert(f,name));

 for x in f_params do
  phi := eval(phi(op(x)));
 od:

 for x in C_params do
  is_el_CC    := eval(is_el_CC(op(x)));
  is_equal_CC := eval(is_equal_CC(op(x)));
  gamma_CC    := eval(gamma_CC(op(x)));
  rand_CC     := eval(rand_CC(op(x)));
 od;

 for x in D_params do
  is_el_DD    := eval(is_el_DD(op(x)));
  is_equal_DD := eval(is_equal_DD(op(x)));
  gamma_DD    := eval(gamma_DD(op(x)));
 od:

 for i from 1 to num_steps do
  p := `random_element/epi`(A,B)();
  Fp := fibres(A,B)(p);
  U := rand_CC(B)();
  V := table({seq(b = rand_CC(Fp[b])(),b in B)});
  ok := `check_operad_morphism_axiom`(A,B,p,U,V,
      is_el_CC,is_equal_CC,gamma_CC,
      is_el_DD,is_equal_DD,gamma_DD,
      phi);
  if not ok then printf("FAIL\n");
   reason := ["operad morphism axiom failed",A,B,eval(p),eval(U),eval(V),reason];
   return false;
  fi;
 od:

 printf("OK\n");
end:

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

check_semioperad := proc(O::string,params,L)
 global reason;
 local is_element,is_equal,random_element,gamma,
       x,J,L_,i,k,jj,ii,H,U,V,W,ok,j0,k0;

 printf("Checking operad structure for %s: ",O);

 is_element     := eval(convert(cat("is_element/",O),name));
 is_equal       := eval(convert(cat("is_equal/",O),name));
 random_element := eval(convert(cat("random_element/",O),name));
 gamma          := eval(convert(cat("gamma/",O),name));

 for x in params do
  is_element     := eval(is_element(op(x)));
  is_equal       := eval(is_equal(op(x)));
  random_element := eval(random_element(op(x)));
  gamma          := eval(gamma(op(x)));
 od:

 J := map(nops,L);
 L_ := map(op,L);
 k := nops(J);
 jj := `+`(op(J));
 ii := `+`(op(L_));
 H := [seq(`+`(op(L[k0])),k0=1..k)];

 for i from 1 to num_steps do
  U := random_element(k)();
  V := [seq(random_element(J[k0])(),k0 = 1..k)];
  W := [seq([seq(random_element(L[k0][j0])(),j0=1..J[k0])],k0=1..k)];
  ok := `check_semi_gamma_axiom`(L,U,V,W,
   is_element,is_equal,gamma);
  if not ok then printf("FAIL\n");
   reason := ["gamma axiom failed",L,eval(U),eval(V),eval(W),reason];
   return false;
  fi;
 od:

 printf("OK\n");
end:

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

check_semi_circ := proc(O::string,params,l,m,n)
 global reason;
 local is_element,is_equal,random_element,circ,
       x,c,i,j,k,U,V,W,ok;

 printf("Checking operad structure for %s: ",O);

 is_element     := eval(convert(cat("is_element/",O),name));
 is_equal       := eval(convert(cat("is_equal/",O),name));
 random_element := eval(convert(cat("random_element/",O),name));
 circ           := eval(convert(cat("circ/",O),name));

 for x in params do
  is_element     := eval(is_element(op(x)));
  is_equal       := eval(is_equal(op(x)));
  random_element := eval(random_element(op(x)));
  circ           := eval(circ(op(x)));
 od:

 for c from 1 to num_steps do
  U := random_element(l)();
  V := random_element(m)();
  W := random_element(n)();
  i := rand(1..l)();
  j := rand(1..m)();
  ok := `check_semi_circ_axiom_nested`(i,j,l,m,n,U,V,W,
   is_element,is_equal,circ);
  if not ok then printf("FAIL\n");
   reason := ["nested circ axiom failed",i,j,l,m,n,eval(U),eval(V),eval(W),reason];
   return false;
  fi;

  i := rand(1..(l-1))();
  k := rand((i+1)..l)();
  ok := `check_semi_circ_axiom_disjoint`(i,k,l,m,n,U,V,W,
   is_element,is_equal,circ);
  if not ok then printf("FAIL\n");
   reason := ["disjoint circ axiom failed",i,j,l,m,n,eval(U),eval(V),eval(W),reason];
   return false;
  fi;
 od:

 printf("OK\n");
end:


#@ Not autoload

s_kochman_max := 10;  # max s in H_s(BP;\pi_t(S))
t_kochman_max := 11;  # max t in H_s(BP;\pi_t(S))
v_kochman_max := 10;  # work mostly mod this power of 2

E_kochman := table():


with(Threads:-Task):
randomize():
roll:=rand(10):
nTasks:=10:
TaskExec:=Array(1..nTasks):
fun:=proc()
    local x;
    global TaskExec;
    TaskExec[_passed]:=1;
    x:=roll();
    if x>5 then
        Return(x);
    end if;
    return x;
end proc:
Start(null,Tasks=[fun,seq([i],i=1..10)]);
print(convert(TaskExec,list));


program parseformalparameters;
procedure func(a,b : integer; c,d : char);
begin
    a := b;
    c := d;
end;
var x1,x2 : integer;
var y1,y2 : char;
begin
    call func(x1,x2,y1,y2);
end.


x:=1:y:=2:z:=3:w:=4:
fun:=proc()
    global x,y,z;
    print(x,y,z,w);
end proc:
Grid:-Launch(fun,imports=[':-x'=x,'y',"z"]);


#This module implements `Partition`---Hakaru's replacement for Maple's
#endogenous and unwieldy `piecewise`.

#The outer data structure for a Partition is a function, PARTITION(...), (just like it
#is for piecewise.
Partition:= module()
  option package;

  # Constructor for Partition pieces
  global Piece;

local
  Umap := proc(f,x,$)
    f(op(0,x))( map( p -> Piece(f(condOf(p)),f(valOf(p))), piecesOf(x) )
              , `if`(nops(x)>1,map(f,[op(2..-1,x)]),[])[] )
  end proc,

  isPartitionPieceOf := proc( p, elem_t := anything )
    type(p, 'Piece(PartitionCond, elem_t)');
  end proc,

  isPartitionOf := proc( e, elem_t := anything )
    type(e, 'PARTITION(list(PartitionPiece(elem_t)))' ) or
    type(e, 'PARTITION(list(PartitionPiece(Or(elem_t,PieceRef))),list(elem_t))' );
  end proc,

  ModuleLoad::static:= proc()
    ModuleUnload();
    :-`print/PARTITION`:= proc()
      local SetOfRecords, branch;
      SetOfRecords := piecesOf(PARTITION(args));
      `print/%piecewise`(
        seq([ condOf(eval(branch)), valOf(eval(branch))][], branch= SetOfRecords))
    end proc;

    TypeTools:-AddType(PieceRef, And(specfunc(nonnegint,PieceRef),satisfies(x->nops(x)>0)));
    TypeTools:-AddType(PartitionCond, {relation, boolean, `::`, specfunc({`And`,`Or`,`Not`}), `and`, `or`, `not`});
    TypeTools:-AddType(PartitionPiece, isPartitionPieceOf);
    TypeTools:-AddType(Partition, isPartitionOf);

    # global extensions to maple functionality
    :-`eval/PARTITION` :=
    proc(p, eqs, $)
      Partition:-Simpl(Umap(x->eval(x,eqs), p));
    end proc;

    # :-`depends/PARTITION` :=
    # proc(parts, nms, $)
    # local dp := (x -> depends(x, nms));
    #   # `or`(op ( map(p-> dp(condOf(p)) or dp(valOf(p)), parts) ), dp(x,);
    # end proc;

    :-`diff/PARTITION` := proc()
      local pw, wrt, dpw, r, r0, r1;
      wrt := args[-1];
      pw := PARTITION(args[1..-2]);
      pw  := PartitionToPW(pw);
      dpw := diff(pw, wrt);
      r   := PWToPartition(dpw, 'do_solve');
      r0 := Simpl:-singular_pts(r);

      # probably a better way to do this; we really only want to simplify
      # sums and products of integrals and summations
      r1 := subsindets(r0, algebraic, `simplify`);

      userinfo(10, 'disint_trace',
               printf("  input        : \n\t%a\n\n"
                      "  diff         : \n\t%a\n\n"
                      "  singular pts : \n\t%a\n\n"
                      "  simplified   : \n\t%a\n\n\n"
                      , parts, r, r0, r1 ));

      r1;
    end proc;

    :-`simplify/PARTITION` := Simpl;

    NULL
  end proc,

  ModuleUnload::static:= proc()
    map(proc(x::uneval) try eval(x) catch: NULL; end try end proc,
        ['TypeTools:-RemoveType(Partition)'
        ,'TypeTools:-RemoveType(PartitionPiece)'
        ]);
    NULL
  end proc,

  # abstract out all argument checking for map-like functions
  map_check := proc(p)
  local pos, err;
    if p::indexed then
      pos:= op(p);
      if not [pos]::[posint] then
        err := sprintf("Expected positive integer index; received %a", [pos]);
        return err;
      end if
    else
      pos:= 1
    end if;
    if nargs-1 <= pos then
      err := sprintf("Expected at least %d arguments; received %d", pos+1, nargs-1);
      return err;
    end if;
    if not args[pos+2]::Partition then
      err := sprintf("Expected a Partition; received %a", args[pos+2]);
      return err;
    end if;
    return pos;
  end proc,

  extr_conjs := proc(x,$)
    if x::{specfunc(`And`), `and`} then
      map(extr_conjs, [op(x)])[];
    else
      x
    end if
  end proc;
export
  piecesOf := proc(x, $)
    local ps, rs;
    ps := op(1,x);
    if nops(x)=2 then
      rs := op(2,x);
      ps := map(mapPiece(proc(c0,v0)
                  local c,c1,v,s; c,v := c0,v0; s := (x->x);
                  if v::PieceRef then
                    c1 := is_lhs(type,c,name);
                    if c1<>FAIL then s := x->subs(c1,x) end if;
                    c, s(op(op(1,v),rs))
                  else
                    c, v
                  end if; end proc), ps );
    elif has(x,PieceRef) then
      error "found piece references (%1) but no table of pieces: %2", indets(x,PieceRef), x
    end if;
    ps;
  end proc,

  condOf := proc(x::specfunc(`Piece`),$)
    op(1,x);
  end proc,

  valOf := proc(x::specfunc(`Piece`),$)
    op(2,x);
  end proc,

  mapPiece := proc(f,$) proc(x::PartitionPiece,$) Piece(f(condOf(x), valOf(x))) end proc; end proc,
  unPiece := mapPiece(ident),
  ident := proc() args end proc,
  is_lhs := proc(test,x0)
    local x := x0;
    if test(rhs(x),_rest) then x := op(0,x)(rhs(x),lhs(x)) end if;
    if test(lhs(x),_rest) then return x
    else                       return FAIL
    end if;
  end proc,

  # This is an alternate (to PARTITION) constructor for partition, which has the
  # same call convention as piecewise, except there are no implicit cases. if
  # there is an otherwise case, its condition is the conjunction of negations of
  # the other conditions.
  ModuleApply := proc()::Partition;
    local ps, as, ops_r;
    if nargs=0 then
      error "empty partition";
    end if;
    ps := [args]; ops_r := iquo(nops(ps),2);
    if nops(ps)::odd then
      ps := [op(1..-2,ps), Not(bool_And(seq(op(2*i-1,ps),i=1..ops_r))), op(-1,ps)];
      ops_r := ops_r+1;
    end if;
    ps := [seq(Piece(op(2*i-1,ps),op(2*i,ps)),i=1..ops_r)];
    PARTITION(ps);
  end proc,

  Pieces := proc(cs0,es0)::list(PartitionPiece);
    local es, cs;
    es := `if`(es0::{set,list},x->x,x->{x})(es0);
    cs := `if`(cs0::{set,list,specfunc(`And`),`and`},x->x,x->{x})(cs0);
    [seq(seq(Piece(c,e),c=cs),e=es)];
  end proc,

  #This is just `map` for Partitions.
  #Allow additional args, just like `map`
  Pmap::static:= proc(f)::Partition;
    local pair,pos,res;
    res := map_check(procname, args);
    if res::string then error res else pos := res; end if;
    PARTITION([seq(
      Piece(condOf(pair)
            ,f(args[2..pos], valOf(pair), args[pos+2..])
         ),pair= piecesOf(args[pos+1]))])
  end proc,

  # a more complex mapping combinator which works on all 3 parts
  # not fully general, but made to work with KB
  # also, does not handle extra arguments (on purpose!)
  Amap::static:= proc(
    funcs::[anything, anything, anything], #`appliable` not inclusive enough.
    part::Partition)::Partition;
    local pair,pos,f,g,h,doIt;
    (f,g,h) := op(funcs);
    #sigh, we don't have a decent 'let', need to use a local proc
    doIt := proc(pair)
    local kb0 := h(condOf(pair));
      Piece( f(condOf(pair), kb0),
             g(valOf(pair), kb0));
    end proc;
    PARTITION(map(doIt,piecesOf(part)));
  end proc,

  Foldr := proc( cons, nil, prt :: Partition, $ )
    foldr(proc(p, x) cons(condOf(p), valOf(p), x); end proc,nil,op(piecesOf(prt)));
  end proc,

  Case := proc(ty,f,g) proc(x) if x::ty then f(x) else g(x) end if end proc end proc,
  Foldr_mb := proc(cons,nil,prt) Case(Partition, x->Foldr(cons,nil,x), x->cons(true,x,nil)) end proc,
  PartitionToPW_mb := Case(Partition, PartitionToPW, x->x),
  PWToPartition_mb := Case(specfunc(piecewise), PWToPartition, x->x),

  PartitionToPW := module()
    export ModuleApply; local pw_cond_ctx;
    ModuleApply := proc(x::Partition, $)
      local parts := piecesOf(x);
        if nops(parts) = 1 and is(op([1,1],parts)) then return op([1,2], parts) end if;
        parts := foldl(pw_cond_ctx, [ [], {} ], op(parts) );
        parts := [seq([condOf(p), valOf(p)][], p=op(1,parts))];
        if op(-2, parts) :: identical(true) then
          parts := subsop(-2=NULL, parts);
      end if;
      piecewise(op(parts));
    end proc;

    pw_cond_ctx := proc(ctx_, p, $)
    local ps, ctx, ctxN, cond, ncond;
      ps, ctx := op(ctx_); cond := condOf(p);
      cond := {extr_conjs(cond)};
      cond := remove(x->x in ctx, cond);
      ncond := `if`(nops(cond)=1
                    , KB:-negate_rel(op(1,cond))
                    , `Not`(bool_And(op(cond))) );
      cond := bool_And(op(cond));
      ctx := ctx union { ncond };
      [ [ op(ps), Piece(cond, valOf(p)) ], ctx ]
    end proc;
  end module,

  isShape := kind ->
  module()
    option record;

    export MakeCtx := proc(p0,_rec)
      local p := p0, pw, p1, wps, ws, vs, cs, w, ps;
      if kind='piecewise' then
        p := Partition:-PWToPartition(p);
      end if;
      w, p1 := Partition:-Simpl:-single_nonzero_piece(p);
      if not w :: identical(true) or p1 <> p then
        [ w, p1 ]
      else
        ps := piecesOf(p);
        wps := map(_rec@valOf, ps);
        ws, vs, cs := map2(op, 1, wps), map2(op, 2, wps), map(condOf, ps);
        if nops(vs) > 0 and
          andmap(v->op(1,vs)=v, vs) and
          ormap(a->a<>{}, ws)
        then
          [ `bool_Or`( op( zip(`bool_And`, ws, cs) ) ) , op(1,vs) ];
        else
          [ true, p0 ];
        end if;
      end if;
    end proc;
    export MapleType := `if`(kind=`PARTITION`,'Partition','specfunc(piecewise)');
  end module,

  # convert a piecewise to a partition, which is straightforward except:
  # - if any of the branches are unreachable, they are removed
  # - if the last clause is (implicitly) `otherwise`, that clause is filled in
  #     appropriately
  # note that if the piecewise does not cover the entire domain,
  #   then this Partition will be 'invalid' (in the sense that it also
  #   will not cover the entire domain) - the 'correct' thing to do would
  #   probably be to add a new clause whose value is 'undefined'
  # the logic of this function is already essentially implemented, by KB
  # in fact, kb_piecewise does something extremely similar to this
  PWToPartition := proc(x::specfunc(piecewise))::Partition;
    # each clause evaluated under the context so far, which is the conjunction
    # of the negations of all clauses so far
    local ctx := true, n := nops(x), cls := [], cnd, ncnd, i, q, ctxC, cl;
    # handles all but the `otherwise` case if there is such a case
    for i in seq(q, q = 1 .. iquo(n, 2)) do
      cnd := op(2*i-1,x); # the clause as given
      # if this clause is unreachable, then every subsequent clause will be as well
      if ctx :: identical(false) then return PARTITION( cls );
      else
        ctxC := `And`(cnd, ctx);              # the condition, along with the context (which is implicit in pw)
        ctxC := Simpl:-condition(ctxC, _rest);

        if cnd :: `=` then ncnd := lhs(cnd) <> rhs(cnd);
        else               ncnd := Not(cnd) end if;

        ctx  := `And`(ncnd, ctx);             # the context for the next clause

        if ctx :: identical(false,[]) then    # this clause is actually unreachable
          return(PARTITION(cls));
        else
          cls := [ op(cls), op(Pieces(ctxC,[op(2*i,x)])) ];
        end if;
      end if;
    end do;

    # if there is an otherwise case, handle that.
    if n::odd then
      ctx := Simpl:-condition(ctx, _rest);
      if not ctx :: identical(false,[]) then
        cls := [ op(cls), op(Pieces(ctx,[op(n,x)])) ];
      end if;
    end if;

    if nops(cls) = 0 then
      WARNING("PWToPartition: the piecewise %1 produced an empty partition", x);
      return 0;
    end if;
    PARTITION( cls );
  end proc,

  # applies a function to the arg if arg::Partition,
  # and if arg::piecewise, then converts the piecewise to a partition,
  # applies the function, then converts back to piecewise
  # this mainly acts as a sanity check
  AppPartOrPw := proc(f,x::Or(Partition,specfunc(piecewise)))
    if x::Partition then f(x);
    else                 PartitionToPW(f(PWToPartition(x))) end if;
  end proc,

  #Check whether the conditions of a Partition depend on any of a set of names.
  ConditionsDepend:= proc(P::Partition, V::{name, list(name), set(name)}, $)
    local p;
    for p in piecesOf(P) do if depends(condOf(p), V) then return true end if end do;
    false
  end proc,

  # The cartesian product of two Partitions
  PProd := proc(p0::Partition,p1::Partition,{_add := `+`})::Partition;
  local ps0, ps1, cs, rs, rs0, rs1;
    ps0,ps1 := map(ps -> sort(piecesOf(ps), key=(z->condOf(z))), [p0,p1])[];
    cs := zip(proc(p0,p1)
                if condOf(p0)=condOf(p1) then
                  Piece(condOf(p0),_add(valOf(p0),valOf(p1))) ;
                else [p0,p1];
                end if;
              end proc, ps0,ps1);
    rs, cs := selectremove(c->type(c,list),cs);
    rs0, rs1 := map(k->map(r->op(k,r),rs),[1,2])[];
    rs := map(r0->map(r1-> Piece( bool_And(condOf(r0),condOf(r1)), _add(valOf(r0),valOf(r1)) )
                      ,rs1)[],rs0);
    PARTITION([op(cs),op(rs)]);
  end proc,

  Simpl := module()
    export ModuleApply := proc(p)
      local ps, qs, qs1, mk;
      if p :: Partition then
        reduce_branches(remove_false_pieces(flatten(p)));
      elif assigned(distrib_op_Partition[op(0,p)]) then
        mk := distrib_op_Partition[op(0,p)];
        ps := [op(p)];
        ps := map(x->Simpl(x,_rest), ps);
        ps, qs := selectremove(type, ps, Partition);
        if nops(ps)=0 then return p end if;
        mk(op(qs),foldr(((a,b)->Partition:-PProd(a,b,_add=mk)),op(ps)));
      else
        subsindets(p,{Partition,indices(distrib_op_Partition,nolist)},x->Simpl(x,_rest));
      end if;
    end proc;
    local distrib_op_Partition := table([`+`=`+`,`*`=`*`]);

    export flatten := module()
      export ModuleApply;
      local unpiece, unpart, unpartProd;

      ModuleApply := proc(pr0, { _with := [ 'Partition', unpart ] } )
        local ty, un_ty, pr1, pr2;
        ty, un_ty := op(_with);

        pr1 := subsindets(pr0, ty, un_ty);
        if pr0 <> pr1 then
          ModuleApply(pr1, _with=[ Or('Partiton',`*`), unpartProd ]);
        else
          pr0
        end if;
      end proc;

      # like Piece, but tries to not be a Piece
      unpiece := proc(c, pr, $)
        if pr :: Partition then
          map(q -> applyop(z->bool_And(z,c),1,q), piecesOf(pr))[]
        else Piece(c, pr) end if
      end proc;

      unpart := proc(pr, $)
        if pr :: Partition then
          PARTITION(map(q -> unpiece(condOf(q),valOf(q)), piecesOf(pr)))
        else pr end if
      end proc:

      unpartProd := proc(pr, $)
      local ps, ws;
        if pr :: `*` then
          ps, ws := selectremove(q->type(q,Partition), [op(pr)]);
          if nops(ps) = 1 then
            Pmap(x->`*`(op(ws),x), unpartProd(piecesOf(pr)));
          else pr end if;
        else unpart(pr) end if;
      end proc;
    end module;

    export single_nonzero_piece_cps := proc(k)
      local r,p; r, p := single_nonzero_piece(_rest);
      if r :: identical(true) then
        args[2]
      else
        k(r, p);
      end if;
    end proc;

    export single_nonzero_piece := proc(e, { _testzero := Testzero })
      local zs, nzs;
      if e :: Partition then
        zs, nzs := selectremove(p -> _testzero(valOf(p)), piecesOf(e));
        if nops(nzs) = 1 then
          return condOf(op(1,nzs)) , valOf(op(1,nzs))
        end if;
      end if;
      true, e
    end proc;

    export remove_false_pieces := proc(e::Partition, $)
      PARTITION(remove(p -> type(KB:-assert(condOf(p), KB:-empty), t_not_a_kb), piecesOf(e)));
    end proc;

   local `&on` := proc(f,k,$) proc(a,b,$) f(k(a),k(b)) end proc end proc;
   local condition_complexity := proc(x) nops(indets(x,PartitionCond)) end proc;

   export reduce_branches := proc(e::Partition, { _testequal := ((a,b) -> Testzero(a-b)) })
     local vs, ps1, ps; ps := piecesOf(e); vs := map(valOf,ps);
     userinfo(3, :-reduce_branches, printf("Input: %a\n", ps));

     if nops(ps)=1 then return op([1,2],ps); end if;
     ps1 := [ListTools:-Categorize(_testequal &on valOf, ps)];
     if nops(ps1) >= nops(ps) then return e; end if;
     userinfo(3, :-reduce_branches, printf("Categorize: %a\n", ps1));

     ps1 := map(p->Piece(bool_Or(condition(bool_Or(map(condOf,p)[]), 'do_solve', 'do_kb')[])
                        ,valOf(op(1,p)))
               ,ps1);
     userinfo(3, :-reduce_branches, printf("condition: %a\n", ps1));

     if nops(ps1)=2 then
       ps1 := sort(ps1, key=tree_size);
       ps1 := subsop([2,1]=Not(op([1,1],ps1)),ps1);
     end if;

     return PARTITION(ps1);
    end proc;

    # Removal of singular points from partitions
    export singular_pts := module()
      # we can simplify the pieces which are equalities and whose LHS or
      # RHS is a name.
      local canSimp := c -> condOf(c) :: `=` and (lhs(condOf(c)) :: name or rhs(condOf(c)) :: name);

      # determines if a given variable `t' has the given upper/lower `bnd'.
      local mentions_t_hi := t -> bnd -> cl -> has(cl, t<bnd) or has(cl, bnd>t);
      local mentions_t_lo := t -> bnd -> cl -> has(cl, bnd<t) or has(cl, t>bnd);

      # replace bounds with what we would get if the equality can be
      # integrated into other pieces
      local replace_with := t -> bnd -> x ->
        if   mentions_t_hi(t)(bnd)(x) then t <= bnd
        elif mentions_t_lo(t)(bnd)(x) then t >= bnd
        else x end if;

      local set_xor := ((a,b)->(a union b) intersect (a minus b));

      # this loops over the pieces to replace, keeping a state consisting of
      # the "rest" of the pieces
      local tryReplacePieces := proc(replPieces, otherPieces,cmp,$)
        local rpp := replPieces, otp := otherPieces, nm, val, rp, rpv;
        for rp in rpp do
          rp, rpv := op(rp);
          nm   := `if`(lhs(rp)::name, lhs(rp), rhs(rp));
          val  := `if`(lhs(rp)::name, rhs(rp), lhs(rp));
          otp := tryReplacePiece( nm, val, rpv, otp, cmp )
        end do;
        otp;
      end proc;

      local eval_IntSum := proc(r,ev,$)
        local q,vs,body,BODY,range,mk,mk_e;
        if r::specfunc({Int,Sum}) then
          mk,body,range := op([0..-1],r);
          mk_e := `if`(mk=Int,'int','sum');
          q := mk_e( BODY(body), eval(range,ev) );
          if not(q :: specfunc(mk_e)) and not has(q,BODY)
          then return q end if;
        end if;
        eval(r,ev);
      end proc;

      local do_eval_for_cmp := proc(eval_cmp, ev, x, $)
        local r;
        try
          r := eval_cmp(eval_IntSum(x,ev));
          userinfo(3, 'Partition', printf("evaluating\n\tsubs(%a,%a)\n\tproduced %a\n",x,ev,r)):
        catch "numeric exception: division by zero":
          r := eval_cmp(limit(x, ev));
          userinfo(3, 'Partition', printf("evaluating\n\tlimit(%a,%a)\n\tproduced %a\n",x,ev,r)):
        end try;
        subsindets(r,And(specfunc(NewSLO:-applyintegrand),anyfunc(anything, identical(0))),_->0);
      end proc;

      local tryReplacePiece := proc(vrNm, vrVal, pc0val, pcs, eval_cmp,$)
        local pcs0 := pcs, pcs1, qs0, qs1, qs2, vrEq := vrNm=vrVal, vs2, ret, q, q_i;
        ret := [ Piece(vrEq, pc0val), op(pcs0) ] ;
        # speculatively replace the conditions
        pcs1 := subsindets(pcs0, relation, replace_with(vrNm)(vrVal));
        # convert to sets and take the "set xor", which will contain
        # only those elements which are not common to both sets.
        qs0, qs1 := seq({op(qs)},qs=(pcs0,pcs1));
        qs2 := set_xor(qs1, qs0);
        # if we have updated precisely two pieces (an upper and lower bound)
        if nops(qs2) = 2 then
          # get the values of those pieces, and the value of the
          # piece to be replaced, if that isn't undefined
          vs2 := map(valOf, qs2);
          if not pc0val :: identical('undefined') then
            vs2 := { pc0val, op(vs2) };
          end if;
          # substitute the equality over the piece values
          vs2 := map(x->do_eval_for_cmp(eval_cmp,vrEq,x), vs2);
          # if they are identically equal, return the original
          # "guess"
          if nops(vs2) = 1 then
            # arbitrarily pick the first candidate to be the one to
            # be replaced
            q := op(1,qs2);
            q_i := seq(`if`(op(i,pcs1)=q,[i],[])[],i=1..nops(pcs1));
            ret := subsop(q_i=op(q_i,pcs0), pcs1);
          end if;
        end if;
        ret;
      end proc;

      export ModuleApply := proc(p_,{eval_cmp:='value'},$)
        local p := p_, r := p, uc, oc;
        # if the partition contains case of the form `x = t', where `t' is a
        # constant (or term??) and `x' is a variable, and the value of that
        # case is `undefined', then we may be able to eliminate it (if another
        # case includes that point)
        r := piecesOf(r);
        uc, oc := selectremove(canSimp, r);
        PARTITION(tryReplacePieces(uc, oc, eval_cmp));
      end proc;
    end module; # singular_pts

    export condition := module()
      local is_extra_sol := x -> (x :: `=` and rhs(x)=lhs(x) and lhs(x) :: name);
      local postproc_for_solve := proc(ctx, ctxSlv)
                               ::{identical(false), list({boolean,relation,specfunc(boolean,And),`and`(boolean)})};
        local ctxC := ctxSlv;
        if ctxC = [] then
          ctxC := [] ;
        elif nops(ctxC)> 1 then
          ctxC := map(x -> postproc_for_solve(ctx, [x], _rest)[], ctxC);
        elif nops(ctxC) = 1 then
          ctxC := op(1,ctxC);
          if ctxC :: set then
            if ctxC :: identical('{}') then
              ctxC := NULL;
            else
              ctxC := remove(is_extra_sol, ctxC);
              ctxC := bool_And(op(ctxC));
            end if ;
            ctxC := [ctxC];
          elif ctxC :: specfunc('piecewise') then
            ctxC := PWToPartition(ctxC, _rest);
            ctxC := [ seq( map( o -> condOf(c) and o
                                , postproc_for_solve(ctx, valOf(c), _rest))[]
                           , c=piecesOf(ctxC) )] ;
          else
            ctxC := FAIL;
          end if;
        else
          ctxC := FAIL;
        end if;
        if ctxC = FAIL then
          error "don't know what to do with %1", ctxSlv;
        else
          ctxC;
        end if;
      end proc;

      export ModuleApply := proc(ctx)::list(PartitionCond);
        local ctxC, ctxC1, ctxC_c, ctxC1_c;
        ctxC := ctx;
        if ctx :: identical(true) then
          error "Simpl:-condition: don't know what to do with %1", ctxC;
        elif condition_complexity(ctx)=1 then
          return [ctx];
        end if;
        if 'do_kb' in {_rest} then
          ctxC1 := KB:-assert( ctxC, KB:-empty );
          ctxC1 := KB:-kb_to_constraints(ctxC1);
          ctxC1 := bool_And(op(ctxC1));
          ctxC1_c, ctxC_c := map(condition_complexity, [ctxC1,ctxC])[];
          if ctxC1_c < ctxC_c then
            ctxC := ctxC1;
            if ctxC1_c = 1 then
              return [ctxC];
            end if;
          end if;
        end if;
        ctxC := KB:-chill(ctxC);

        if 'do_solve' in {_rest} and _Env_HakaruSolve<>false then
          ctxC := solve({ctxC}, 'useassumptions'=true);
          if ctxC = NULL and indets(ctx, specfunc(`exp`)) <> {} then
            ctxC := [ctx];
          else
            ctxC := postproc_for_solve(ctx, [ctxC], _rest);
          end if;
          if indets(ctxC, specfunc({`Or`, `or`})) <> {} then
            userinfo(10, 'Simpl:-condition',
                     printf("output: \n"
                            "  %a\n\n"
                            , ctxC ));
          end if;
        else
          ctxC := Domain:-simpl_relation(ctxC, norty='DNF');
          ctxC := eval(ctxC,`And`=bool_And);
          if ctxC :: specfunc(`Or`) then
            ctxC := [op(ctxC)]
          else
            ctxC := [ctxC];
          end if;
        end if;
        if 'no_split_disj' in {_rest} then
          ctxC := [ bool_Or(op(ctxC)) ];
        end if;
        KB:-warm(ctxC);
      end proc;
    end module; #Simpl:-condition
  end module, #Simpl

  SamePartition := proc(eqCond, eqPart, p0 :: Partition, p1 :: Partition, $)
    local ps0, ps1, pc0, the;
    ps0, ps1 := map(piecesOf,[p0,p1])[];
    if nops(ps0) <> nops(ps1) then return false end if;
    for pc0 in ps0 do
      the, ps1 :=
        selectremove(pc1 ->
          eqCond( condOf(pc1), condOf(pc0) ) and
          eqPart( valOf(pc1) , valOf(pc0)  )     ,ps1);
      if nops(the) <> 1 then
        return false;
      end if;
    end do;
    true;
  end proc
;
  uses Hakaru;
end module:


func $singlefoo(var %a i32) i32 {
  return (dread i32 %a)
}

func $fact(var %n i32) i32 {
  var %m i32
  var %r1 i32
  var  %r2 i32
  var  %r3 i32
  callassigned &singlefoo(dread i32 %n) {
    dassign %m 0
  }
  # Not correct, but for parse and dump test.
  callassigned &singlefoo(dread i32 %n) {
    dassign %r1 1
    dassign %r2 2
    dassign %r3 3
  }
  return (dread i32 %n)
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


 # a function returning unary(i + j) * -998
#type $SS <struct {@f1 f32}>
 func $foo (
  var %k <struct {@f1 f32}>,
  var %f f32,
  var %i i32,
   var %j i32)i64  {
   return (
       cvt i64 i32 (constval i32 12345))}

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


fun:=proc()
    uses Grid;
    printf("node %d / %d --- %a \n",MyNode(),NumNodes(),[_passed]);
    Barrier();
end proc:
Grid:-Launch(fun,1,2,3);
Grid:-Launch("rand();"):


with(Threads:-Mutex):
with(Threads:-Task):
m:=Create();
c:=1;
fun:=proc()
    global c,m;
    Lock(m);
    print(c);
    c:=c+1;
    Unlock(m);
end proc:
Start(null,Tasks=[fun,seq([],i=1..10)]);
Destroy(m);


type $RR <class {@e1 i32, @e2 f32, @e3 f64}>
type $SS <class <$RR> {@f1 i32, @f2 i8, @f3 i8}>
type $TT <class {@e1 i32, @e2 f32, @e3 f64}>
type $UU <class <$RR> {@f1 i32, @f2 i8, @f3 i8}>
func &foo ( var %x <$SS>) void {
  var %y <$UU>
  dassign %y 0 ( dread agg %x 0 )
  return () }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


type $atyp <[10] f32>
var $fff <i32> = 7789
func $foo ( var %i i32 )i32

func $fact (
 var %n i32, var %m f32) void {
  return () }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


#int fact (int n) {
#  if(n != 1)
#    return foo(n - 1);
#  else return 1;
#}

func $fact (
 var %n i32, var %p1 a64, var %p2 a64) i32 {
 if (ne i32 i32 (dread i32 %n, constval i32 1)) {
    intrinsiccall JSOP_ADD (
      dread a64 %p1, dread a64 %p2, dread i32 %n)
    return (regread i32 %%retval)}
   else {
     return (constval i32 1) } }


program parseformalparameters;
procedure func(a, b : integer;
    c, d : char);
    begin
        a := b;
        c := d;
    end;
var x1, x2 : integer;
var y1, y2 : char;
begin
    call func(x1, x2, y1, y2);
end.


program assignboolean;	{sample22}
var x y : boolean;
begin
 x := true;
 y := false;
end.


program sample34;
var num : integer;  ch : char;

begin
	writeln('input the number of data and data character (readln)');
	readln(num);  readln(ch);
	writeln;
	while num > 0 do begin
		write(ch);
		num := num - 1
	end;
	writeln;
	writeln('input the number of data and data character (read)');
	read(num);  read(ch);
	writeln;
	while num > 0 do begin
		write(ch);
		num := num - 1
	end;
	writeln
end.


type $RR <class {
  @e1 i32,
  @e2 f32,
  @classname "foo",
  @e3 f64}>
type $SS <class <$RR> { @accessflag 1234,
                        &method1(agg)agg,
                        &method2(void)void}>
func $foo (
	var %x <$SS>) i32 {
  dassign %x 2 ( constval i32 32 )
  return ( dread i32 %x 2 ) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


 func $retypef64toi64 (
  var %i f64
  ) i64 {
   return (
     retype i64 <i64> (dread f64 %i))}

 func $retypei64tof64 (
  var %i i64
  ) f64 {
   return (
     retype f64 <f64> (dread i64 %i))}

 func $retypef32toi32 (
  var %i f32
  ) i32 {
   return (
     retype i32 <i32> (dread f32 %i))}

 func $retypei32tof32 (
  var %i i32
  ) f32 {
   return (
     retype f32 <f32> (dread i32 %i))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


type $RR <class {@e1 i32, @e2 f32, @e3 f64}>
type $SS <classincomplete <$RR> {@f1 i32, @f2 i8, @f3 i8}>
javaclass $TT <$SS> public static
func &foo (
	var %x <$SS>) i32 {
  dassign %x 2 ( constval i32 32 )
  return ( dread i32 %x 2 ) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# This was originally the ggplot style from matplotlib
# from http://www.huyng.com/posts/sane-color-scheme-for-matplotlib/

# More options here
# https://matplotlib.org/users/customizing.html

patch.linewidth: 0.5
patch.facecolor: 348ABD  # blue
patch.edgecolor: EEEEEE
patch.antialiased: True
mathtext.default : regular

font.size: 6.0
font.family : sans-serif
font.sans-serif : DejaVu Sans #Arial also had a unicode problem
font.style : normal
#font.family: Arial # specifiying this because Bitstream doesnt show unicode

# Font Sizes
# xx-small, x-small, small, medium, large, x-large, xx-large, smaller, larger.
axes.facecolor: white #E5E5E5
#axes.edgecolor: white
axes.edgecolor: black
axes.spines.right : False
axes.spines.top : False
axes.linewidth: 0.5
axes.grid: False
axes.titlesize: large
axes.labelsize: medium
axes.labelcolor: 555555
axes.axisbelow: True       # grid/ticks are below elements (e.g., lines, text)

# matlab color cycle
axes.prop_cycle: cycler('color', ['0071BC', 'D85218', 'ECB01F', '7D2E8D', '76AB2F', '4CBDED', 'A1132E'])

#['E24A33', '348ABD', '988ED5', '777777', 'FBC15E', '8EBA42', 'FFB5B8'])
                   # E24A33 : red
                   # 348ABD : blue
                   # 988ED5 : purple
                   # 777777 : gray
                   # FBC15E : yellow
                   # 8EBA42 : green
                   # FFB5B8 : pink

xtick.color: 555555
xtick.major.width: 0.5
#xtick.direction: in
xtick.direction: out

ytick.color: 555555
ytick.major.width: 0.5
#ytick.direction: in
ytick.direction: out

#grid.color: white
grid.color: lightgray
grid.linestyle: :    # solid line

figure.facecolor: FFFFFF #white
figure.edgecolor: 0.50

figure.subplot.wspace  : 0.2

#legend.labelspacing
#legend.borderpad
legend.fontsize : small


# https://matplotlib.org/users/customizing.html

#figure.titlesize : small        # size of the figure title (Figure.suptitle())
figure.figsize   : 8, 5         # figure size in inches
#figure.dpi       : 200          # figure dots per inch
figure.facecolor : white
figure.edgecolor : white
figure.autolayout : True        # Automatically apply 'plt.tight_layout'

lines.linewidth : 3
lines.markersize : 10
legend.fontsize : 15
legend.handlelength : 1
axes.titlesize : 17
axes.labelsize : 15
axes.linewidth : 1
axes.grid : True
grid.linestyle : :
xtick.labelsize : 14 # font size of tick labels
xtick.direction : in
ytick.direction : in
ytick.labelsize : 14
xtick.major.size : 10      # major tick size in points
xtick.minor.size : 5     # minor tick size in points
ytick.major.size : 10
ytick.minor.size : 5

#xtick.major.size : 20
#xtick.major.width : 4
#xtick.minor.size : 10
#xtick.minor.width : 2

xtick.minor.visible  : True   # turn minor ticks on by default
ytick.minor.visible  : True

# --- I like this but most people don't have it
#font.family : Optima

# --- this one is still distinct but should be more widely usable
font.family : Courier New
font.weight : bold
axes.labelweight : bold


program assignboolean;	{sample22}
var
x,y
:
 boolean;

begin
x := true;
y := false;
end.


program IfstTC;	{sample25t}
var
 ch:char;int:integer;boolx,booly:boolean;
begin
boolx:=true;booly:=false;ch:='a';int:=66;
write(integer(ch));write(integer(int));write(integer(boolx),integer(booly));
writeln;
writeln(char(ch),char(int));writeln(boolean(ch),integer(int),integer(boolx),
integer(booly));end.


func &foo ( var %i i32 ) void {
   var %p ptr
   dassign %p ( malloc ptr ( constval i32 8 ))
   dassign %p ( alloca ptr ( constval i32 16 ))
   dassign %p ( gcmalloc ref i32 )
   dassign %p ( gcmallocjarray ref <[] i32> ( constval i32 5 ))
   free ( dread ref %p)
}

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


Launch:=proc (
    NumNodes::posint := "ALL_NODES",
    code := "",
    Printer::procedure := NULL,
    CheckAbort::procedure := NULL,
    Exports::{list, set} := NULL,
    Imports::{list, set} := NULL,
    {
        allexternal::truefalse := true,
        checkabort::procedure := CheckAbort,
        clear::truefalse := true,
        exports::{list, set} := Exports,
        imports::{list, set} := Imports,
        numnodes::{"ALL_NODES", posint} := NumNodes,
        printer::procedure := Printer
    })
    localGridInterface:-Launch(numnodes, code, gridcmdargs = _rest, _options);
end proc:


var $g ptr
var $h i32
func $multiwayfunc ( var %p ptr) ptr {
 multiway (dread ptr %p) @labdft {
   (dread ptr $g): goto @lab1
   (add ptr (dread i32 $g, dread i32 $h)): goto @lab0
   (conststr ptr "world"): goto @lab9 }
@lab0
 return (dread ptr $g)
@labdft
 return (conststr ptr "hello")
@lab9
 return (add ptr (conststr ptr "foo", dread i32 $h))
@lab1
 return (addrof ptr $h) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


x:=1:y:=2:z:=3:w:=4:
fun:=proc()
    uses Grid;
    global x,y,z;
    local w:=1;
    printf("%d --> %a \n",MyNode(),[x,y,z,w]);
    x:=233+MyNode();
    y:=666+MyNode();
    z:=888+MyNode();
    w:=999+MyNode();
    Barrier();
end proc:
Grid:-Launch(fun,imports={'x','y'},exports={'x','z','w'});
[x,y,z,w];


# ;, / and | are allowed name characters, but they cannot be the starting char
 func $foo (
  var %i; i32,
  var %j|/ i32
  ) i32 {
   return (
     add i32(dread i32 %i;, dread i32 %j|/))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


#This test case covers the following items:

#MapleIR Direct read/write
#Direct acfgrecesses are associated with scalar variables and fixed fields inside
#structures. Direct accesses can be mapped to pseudo-register if the variable
#or field has no alias.
#In MAPLE IR, dassign and dread are the opcodes for direct assignments and
#direct references;

#Syntax
#dread<prim-type><var-name><field-id>
#dassign<var-name><field-id>(<rhs-expression>)
#Type syntax
#type <id-name><derived-type>
func $strcpy ( var %dest <*i8>, var %src <*i8> ) <*i8>

type $People < struct{
     @name <[10] i8>,
     @age i8 }>

type $Info < struct{
     @number i32,
     @employee <$People> }>

var $p <$People>
var $temp<[6] i8>= [ 104, 117, 97, 119, 101, 105 ]

func $main ( )i32 {
     var %a i8
     dassign %a ( constval i8 120 )
     var %b i8
     dassign %b ( dread i32 %a )
     var %i i32
     dassign %i ( constval i32 5 )
     var %ii i32
     dassign %ii ( dread i32 %i )
     var %j f32
     dassign %j ( constval f32 12.9f )
     var %jj f32
     dassign %jj ( dread f32 %j )
     var %k f64
     dassign %k ( constval f64 20.5 )
     var %kk f64
     dassign %kk ( dread f64 %k )
     var %p < $People >
     var %pp < $People >
     dassign $p 2 ( constval i32 25)
     # dassign $p 1 ( constval i32 0 )
     #call <pu-name>(<opnd0>,...,<opndn>)
     call &strcpy ( addrof a64 %p, addrof a64 $temp)
     call &strcpy ( addrof a64 %pp, addrof a64 %p)
     var %info < $Info >
     var %info2 < $Info >
     dassign %info 2( dread agg %p )
     dassign %info2 2( dread agg %info 2)
     return ( constval i32 444 )
}

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


func $foo1 (var %p1 i8, var %p2 i16, var %p3 i32, var %p4 i64, ...)i32 {
   return (
       constval i32 33)}
func $foo2 (var %p1 u8, var %p2 u16, var %p3 u32, var %p4 u64,...) i32 {
   return (
       constval i32 33)}
func $foo4 (var %p1 f32, var %p2 f64, ... ) i32 {
   return (
       constval i32 33)}

func $foo5 (var %p1 a32, var %p2 a64,...) i32
func $foo6 (var %p1 c64, var %p2 c128, ...) i32

func $foo7 (var %p1 <* i8>, var %p2 <* i16>, var %p3 <* i32>, var %p4 <* i64>) i32 {
   return (
       constval i32 33)}
func $foo8 (var %p1 <* u8>, var %p2 <* u16>, var %p3 <* u32>, var %p4 <* u64>) i32 {
   return (
       constval i32 33)}
func $foo9 (var %p1 <* u1>) i32 {
   return (
       constval i32 33)}
func $foo10 (var %p1 <* f32>, var %p2 <* f64>) i32 {
   return (
       constval i32 33)}
func $foo11 (var %p1 <* void>)void

func $foo12 (var %p1 <[10] i8>) i32 {
   return (
       constval i32 33)}
func $foo13 (var %p1 <[10][32] i32>) i32 {
   return (
       constval i32 33)}
func $foo14 (var %p1 <[10][32][43] i32>) i32 {
   return (
       constval i32 33)}
func $foo15 (var %p1 <[10][32][43][54][56][78][90][122][223][334] i32>) i32 {
   return (
       constval i32 33)}

type $SS <struct {@f1 i32, @f2:3 i8, @f3:5 i8}>
func $foo16 (var %x <$SS>) i32 {
   return (
       constval i32 33)}

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


program assigninteger	{sample21}
var n: integer;
begin
 n := 1
end.


type $SS <class {@f1 i32, @f2 i8, @f3 i8, &fun(i32) i32}>
javaclass $TT <$SS> public static

func &bar (var %y i32) i32 {
  return (dread i32 %y)
}

func &foo (var %x <$SS>) i32 {
  var %ret i32
  polymorphiccallassigned <func(i32) i32> &bar (dread i32 %x 1) {dassign %ret 0}
  return (dread i32 %ret)
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# 基于Maple read 命令的代码读取包。
# 优点：
#     1. Maple原生支持，不需要额外的文件，直接被mla带走。
#     2. 不用产生临时文件。
# 缺点：
#     1. 预处理器必须在行首。
#     2. include的相对路径必须以 . 或 .. 开头。
#     3. 文档编码必须是UTF-8。
MapleCodeReader:=module()
    option package;
    export ReadCode;

    ReadCode:=proc(fname)
        local cd,p,f;
        p:=FileTools:-ParentDirectory(fname);
        f:=FileTools:-Filename(fname);
        cd:=currentdir();
        currentdir(p);
        read(f);
        currentdir(cd);
        return;
    end proc:
end module:


#var $const1 <[13] i8> [ 104, 101, 108, 108, 111, 32, 119, 111, 114, 108, 100, 10, 0 ]
var $fconst1 <[18] f64> = [ 1007, 707, -273, 75, 0113, 0x4b, 75u, 75l, 75ul, 75lu, 3.1425926, 6.02e23, 6.02e+23, 1.6e-19, 3.0, 3.14159, 6.02e23, .233 ]
func $printf (var %p1 <* i8>)void
func $main ( ) i32 {
   call &printf (addrof a32 $fconst1)
   call &printf (conststr ptr "\"hello maple\"", conststr a32 "\nworld\n")
   # 你好: E4 BD A0 E5 A5 BD  中国: E4 B8 AD E5 9B BD
   call &printf (conststr16 ptr "\xE4\xBD\xA0\xE5\xA5\xBD", conststr16 a32 "\xE4\xB8\xAD\xE5\x9B\xBD")
   return (constval i32 0) }

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


program typeconv;
var a : array[3] of integer;
var b : integer;
var c : char;
var d : boolean;
begin
    b := integer(a[0]);
    c := char(a[0]);
    d := boolean(a[0]);
end.


program IfstTC;
var ch : char;
    int : integer;
    boolx, booly : boolean;
begin
    boolx := true;
    booly := false;
    ch := 'a';
    int := 66;
    write(integer(ch));
    write(integer(int));
    write(integer(boolx), integer(booly));
    writeln;
    writeln(char(ch), char(int));
    writeln(boolean(ch), integer(int), integer(boolx), integer(booly));
end.


# 自定义生成包的工具。
# 基于LibraryTools。
# 增加了不存在包文件则直接创建文件的功能。
LibMaker:=module()
    option package;
    export MakeLib;

    (*
        将package保存到文件
        如果文件不存在则创建文件
        如果文件不含后缀名则补全后缀名
        默认文件名为 lib.mla
    *)
    MakeLib:=proc(mName,fName:="lib.mla")
        if not StringTools:-RegMatch(".*\\.mla",fName) then
            fName:=cat(fName,".mla");
        end if;
        if not FileTools:-Exists(fName) then
            LibraryTools:-Create(fName);
        end if;
        LibraryTools:-Save(mName,fNmae);
    end proc:
end module:


type $RR <class {@e1 i32, @e2 f32, @e3 f64}>
type $SS <class <$RR> { &method1(agg)agg,
                        &method2(void)void}>
func $foo (
	var %x <$SS>) i32 {
  dassign %x 2 ( constval i32 32 )
  virtualcall &method2(addrof ptr %x)
  superclasscall &method2(addrof ptr %x)
  interfacecall &method2(addrof ptr %x)
  return ( dread i32 %x 2 ) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


kernelopts(opaquemodules=false):
kernelopts(assertlevel=2):


var $test_var i32 public

func $test_extern_var ( var %i i32 ) i32 {
  return (dread i32 $test_var)
}

var $test_var i32 public = 0
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# Teach Maple (through depends and eval) about our new binding forms.
# forall bind from 1st arg to 2nd arg.
# Ints,Sums,ints,sums bind from 2nd arg to 1st arg, and also from each element
#   of the 4th arg to the other elements on the left and to the 3rd arg.

`depends/forall` := proc(bvar, pred, x, $)
  depends(pred, x minus convert(bvar, 'set'))
end proc:

`depends/Ints` := proc(body, bvar, rng, loops, x, y, $)
  local xx, i;
  if nargs = 5 then
    xx := x; # y is ununsed and x lists the variables to look for
  else
    xx := y; # x is some KB and y lists the variables to look for
    if depends(x, y) then return true end if;
  end if;
  # don't remove bvar from xx!
  if depends(body, xx minus {bvar}) then return true end if;
  for i from nops(loops) to 1 by -1 do
    if depends(op([i,2],loops), xx) then return true end if;
    xx := xx minus {op([i,1],loops)};
  end do;
  depends(rng, xx)
end proc:
`depends/Sums` := eval(`depends/Ints`):
`depends/ints` := eval(`depends/Ints`):
`depends/sums` := eval(`depends/Ints`):

`eval/forall` := proc(e, eqs, $)
  local bvar, pred;
  bvar, pred := op(e);
  eval(op(0,e), eqs)(BindingTools:-generic_evalat(bvar, pred, eqs))
end proc:

`eval/Ints` := proc(e, eqs, $)
  local body, bvar, rng, loops, n, i;
  body, bvar, rng, loops := op(1..4, e);
  bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
  eval(op(0,e), eqs)(body, bvar,
                     BindingTools:-generic_evalatstar(rng, loops, eqs),
                     op(5..-1,e))
end proc:
`eval/Sums` := eval(`eval/Ints`):
`eval/ints` := eval(`eval/Ints`):
`eval/sums` := eval(`eval/Ints`):

`eval/Int` := proc(e, eqs, $)
  local body, bound, bvar;
  body, bound := op(1..2, e);
  if bound :: name then
    bound, body := BindingTools:-generic_evalat(bound, body, eqs);
  elif bound :: `=` then
    bvar := lhs(bound);
    bvar, body := BindingTools:-generic_evalat(bvar, body, eqs);
    bound := bvar = eval(rhs(bound), eqs);
  else
    body, bound := BindingTools:-generic_evalatstar(body, bound, eqs);
  end if;
  eval(op(0,e), eqs)(body, bound, op(eval([op(3..-1,e)], eqs)))
end proc:
`eval/Sum`     := eval(`eval/Int`):
`eval/Product` := eval(`eval/Int`):
`eval/int`     := eval(`eval/Int`):
`eval/sum`     := eval(`eval/Int`):
`eval/product` := eval(`eval/Int`):

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

Loop := module ()
  option package;
  local intssums, enter_piecewise, wrap,
        t_peel, do_peel, do_split, do_graft, do_rebase_lower, do_rebase_upper,
        Binder, Stmt, t_binder, t_stmt, t_exp,
        ModuleLoad;
  export
     # These first few are smart constructors (for themselves):
         ints, sums,
     # while these are "proper functions"
         mk_HArray, genLoop, unproducts, unproduct,
         peel, split, graft, rebase_lower, rebase_upper, Print;
  # these names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global Ints, Sums, csgn, sum;
  uses Hakaru, KB;

  t_binder := 'Binder(identical(product, Product, sum, Sum), t_kb)';
  t_stmt   := 'Stmt(anything, list, list)';
  t_exp    := '{Stmt(identical(exp), [], []),
                Stmt(identical(`^`), [anything], [])}';

  ints := proc() intssums('ints', 'int', _passed) end proc;
  sums := proc() intssums('sums', 'sum', _passed) end proc;

  Print := proc(kind::identical(Ints,Sums,ints,sums),e,v::name,r0::range,rs::list(name=range),$)
    local k;
    k := StringTools[Capitalize](StringTools[Chop](convert(kind,string)));
    k := parse(cat("`print/",eval(k),"`"));
    eval(k)(e,v[op(rs)]=r0);
  end proc;

  intssums := proc(makes::name, make::name,
                   e::anything, x::name, rr::range, ll::list(name=range),
                   kb::t_kb:=empty, $)
    local t, r, l, kb2, w0, pp, i;
    t := `if`(make=int, HReal(open_bounds(rr)), HInt(closed_bounds(rr)));
    r, l, kb2 := genLoop(rr, ll, kb, 'Integrand'(x,e));
    w0, pp := unproducts(e, x, l, kb2);
    if depends(w0, x) then
      'makes(e, x, rr, ll)'
    else
      pp := 'make'(pp, x=r);
      for i in l do pp := 'product'(pp, i) end do;
      NewSLO:-simplify_factor_assuming(w0 * pp, kb);
    end if
  end proc;

  mk_HArray := proc(t::t_type, loops::list(name=range), $)
    local res, i;
    res := t;
    for i in loops do res := HArray(res) end do;
    res
  end proc;

  genLoop := proc(e, loops::list(name=range), kb::t_kb)
    local kb1, rng, ind, do_subst, i;
    kb1 := kb;
    rng := table();
    ind := table();
    do_subst := e -> foldl(((e,eq) -> eval(e, op([lhs(eq),1],loops)=rhs(eq))),
                           e, entries(ind, 'pairs'));
    for i from nops(loops) to 1 by -1 do
      rng[i] := do_subst(op([i,2],loops));
      ind[i], kb1 := genType(op([i,1],loops), HInt(closed_bounds(rng[i])),
                               kb1, _rest);
    end do;
    do_subst(e), zip(`=`, [entries(ind, 'nolist')],
                          [entries(rng, 'nolist')]), kb1
  end proc;

  unproducts := proc(w, x::name, loops::list(name=range), kb::t_kb, $)
    local w0, pp, j, w1, w2, loop;
    w0 := 1;
    pp := w;
    for j from nops(loops) to 1 by -1 do
      w1, pp := op(unproduct(pp, x, op(j,loops), [], `*`, kb, kb));
      # separate out each of the factors in w1, as they might have different
      # variable dependencies, which can be exploited by other routines
      w2 := convert(w1, 'list', '`*`');
      for loop in [op(j+1..-1, loops)] do
        w2 := map((w -> product(eval(w, x=idx(x,lhs(loop))), loop)), w2);
      end do;
      w0 := w0 * `*`(op(w2));
      # w0 := w0 * foldl(product, w1, op(j+1..-1, loops));
    end do;
    # Rewrite ... * piecewise(i<=kk-1, xs^2, 1)
    #      to ... * xs ^ (2*piecewise(i<=kk-1, 1))
    # because the latter is easier to integrate and recognize with respect to xs
    pp := for_poly(pp, # TODO: move this rewrite into eval_factor (then remove for_poly?)?
      proc (p)
        local n, s, r;
        if p :: 'And(specfunc(piecewise), anyfunc(freeof(x), anything, 1))' then
          n := indets(op(1,p),name);
          if op(2,p) :: {'exp(anything)', '`^`'('freeof'(n),'anything')} then
            s, r := selectremove(depends, convert(op([2,-1],p),'list','`*`'), n);
            subsop(-1 = `*`(piecewise(op(1,p), `*`(op(s))), op(r)), op(2,p))
          else
            s, r := selectremove(depends, convert(op(2,p),'list','`*`'), n);
            `*`(op(r)) ^ piecewise(op(1,p), 1)
              * `if`(nops(s) > 0, piecewise(op(1,p), `*`(op(s)), 1), 1)
          end if
        else
          p
        end if
      end proc);
    w0, pp
  end proc;

  # Find [w1,pp] so that
  #   wrap(heap,w,mode,kb1,kb0)
  #   = w1*product(eval(pp,var=idx(var,lhs(loop))),loop)
  # making w1 depend on var as little as possible.
  # The flag "mode" should be `+` if "heap" contains an entry of the form
  # t_exp, or `*` otherwise.
  unproduct := proc(w, var::name, loop::(name=range),
                    heap::list, mode::identical(`*`,`+`),
                    kb1::t_kb, kb0::t_kb, $)
    local ind, res, dummy, kb, kbThen, i, w1, pp, s, r, x;
    if not depends(w, var) then
      return [wrap(heap, w, mode, kb1, kb0), 1]
    end if;
    # The `..' (indices) of all occurences of `idx(var,..)'
    ind := map2(op, 2, indets(w, idx(identical(var), anything)));
    if nops(ind) = 1 then
      ind := op(ind);
      # Make sure ind contains no bound variables before lifting it!
      # So, check that "extract using indets" and "rename using eval" commute.
      s := indets(ind, 'name');
      s := map(proc(x,$) local y; `if`(depends(ind,x), x=y, NULL) end proc, s);
      if indets(eval(w, s), idx(identical(var), anything))
                = {idx(var, eval(ind, s))} then
        # use kb as a local context, and 'solve' for the innermost bound var
        #   used in ind.
        kb  := assert(lhs(loop)=ind, kb1); # BUG! bijectivity assumed!
        # if the assertion makes the KB false, it isn't needed(?)
        ASSERT(type(kb, t_kb),
          sprintf("assert(%a,%a) produced a false KB!\n", lhs(loop)=ind,kb1)):
        res := subs(idx(var,ind) = idx(var,lhs(loop)), w);
        res := wrap(heap, res, mode, kb, kb0);
        res := subs(idx(var,lhs(loop))=dummy, res);
        if not depends(res, var) then
          return [1, subs(dummy=var, res)]
        end if
      end if
    end if;
    # distribute the unproduct over each part
    if w :: mode then
      res := map(unproduct, `if`(mode=`*`, list_of_mul(w), [op(w)]),
                 var, loop, heap, mode, kb1, kb0);
      return [`*`(op(map2(op,1,res))), `*`(op(map2(op,2,res)))]
    end if;
    # for piecewise, just map right in (using KB for context tracking)
    if w :: 'specfunc(piecewise)' then
      kb := kb1;
      for i from 1 to nops(w) do
        if i :: even then
          kbThen := assert(    op(i-1,w) , kb);
          # accumulate the rest, regardless
          kb     := assert(Not(op(i-1,w)), kb);

          # if kbThen is invalid, deal appropriately
          if not type(kbThen,t_kb) then next end if;

          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kbThen,kb0));
          # if kb is inconsistent, we're done
          if not type(kb,t_kb) then break end if;
        elif i = nops(w) then
          if not type(kb,t_kb) then next end if;
          w1[i], pp[i] := op(unproduct(op(i,w),var,loop,heap,mode,kb    ,kb0))
        end if
      end do;
      return [`*`(entries(w1,'nolist')), `*`(entries(pp,'nolist'))]
    end if;
    if mode = `*` then
      if w :: (anything^freeof(var)) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(`^`, [], [op(2,w)])], `*`, kb1, kb0)
      elif w :: exp(anything) then
        return unproduct(op(1,w), var, loop,
                         [op(heap), Stmt(exp, [], [])], `+`, kb1, kb0)
      elif w :: (freeof(var)^anything) then
        return unproduct(op(2,w), var, loop,
                         [op(heap), Stmt(`^`, [op(1,w)], [])], `+`, kb1, kb0)
      end if
    end if;
    if mode = `+` and w :: `*` then
      s, r := selectremove(depends, w, var);
      if s :: `*` then
        # Nonlinear %1 (time to reread kiselyov-lifted?)
      else
        return unproduct(s, var, loop,
                         [op(heap), Stmt(`*`, [], [r])], `+`, kb1, kb0)
      end if
    end if;
    if w :: And(specfunc(`if`(mode = `*`, {product, Product}, {sum, Sum})),
                anyfunc(anything, name=range(freeof(var)))) then
      x, kb := genType(op([2,1],w), HInt(closed_bounds(op([2,2],w))), kb1,
                       w, var, loop, heap);
      return unproduct(eval(op(1,w), op([2,1],w)=x), var, loop,
                       [op(heap), Binder(op(0,w), kb1)], mode, kb, kb0)
    end if;
    if mode = `*` and w :: '{`+`, specfunc({sum, Sum})}' then
      # Maybe this w is one of those big sums involving products that are
      # always equal to 1, left behind by the density of Categorical
      w1 := graft(split(peel(w)));
      w1 := combine(rebase_upper(w1));
      w1 := combine(rebase_lower(w1));
      return [wrap(heap, w1, mode, kb1, kb0), 1]
    end if;
    return [wrap(heap, w, mode, kb1, kb0), 1]
  end proc;

  enter_piecewise := proc(ee, kb0::t_kb, mode::identical(`*`,`+`), $)
    local e, kb, mo;
    e  := ee;
    kb := kb0;
    mo := mode();
    while e :: 'specfunc(piecewise)' and nops(e) = 3 do
      if op(3,e) = mo then
        kb := assert(op(1,e), kb);
        e := op(2,e);
      elif op(2,e) = mo then
        kb := assert(Not(op(1,e)), kb);
        e := op(3,e);
      else
        break;
      end if;
    end do;
    ASSERT(type(kb,t_kb), "enter_piecewise: KB of piecewise conditions is not valid, so the input piecewise must not be valid.");
    e, kb
  end proc;

  # heap is a list of t_binder and t_stmt
  # one invariant to maintain:
  #  wrap(heap, mode(a,b)) = wrap(heap,a) * wrap(heap,b)

  # Also, a t_binder is a Product/product/Sum/sum.
  # And, a t_stmt is a 1-hole context of a (multiplicative) AST,
  #   used for [a ^ hole, hole ^ b, exp(hole), c * hole].

  wrap := proc(heap::list, e1, mode1::identical(`*`,`+`),
               kb1::t_kb, kb0::t_kb, $)
    local e, kb, mode, i, entry, rest, var, new_rng, make, logmake,
       dom_spec, w, wPow, wExp, arrrgs;
    e    := e1;
    kb   := kb1;
    mode := mode1;
    for i from nops(heap) to 1 by -1 do
      entry := op(i,heap);
      if entry :: t_binder then
        if not (op(1,entry) in `if`(mode=`+`, {sum,Sum},
                                              {product,Product})) then
          print("Warning: heap mode inconsistency", heap, mode1)
        end if;
        e, kb := enter_piecewise(e, kb, mode);
        rest := kb_subtract(kb, op(2,entry));
        new_rng, rest := selectremove(type, rest,
          {[identical(genType), name, specfunc(HInt)],
           [identical(genLet), name, anything]});
        if not (new_rng :: [list]) then
          error "kb_subtract should return exactly one gen*"
        end if;
        new_rng := op(new_rng);
        var     := op(2,new_rng);
        if op(1,new_rng) = genType then
          make    := op(1,entry);
          new_rng := range_of_HInt(op(3,new_rng));
        else # op(1,new_rng) = genLet
          make    := eval;
          new_rng := op(3,new_rng);
        end if;
        dom_spec, rest := selectremove(depends,
          map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest),
          var);

        # Like e := make(piecewise(And(op(dom_spec)), e, mode()), var=new_rng);
        # but try to simplify by pushing the make and the piecewise into e
        (e, w) := selectremove(depends, convert(e, 'list', `*`), var);
        w := `*`(op(w));
        if mode = `*` then
          (wPow, e) := selectremove(type, e, '`^`'('freeof'(var), 'anything'));
          (wExp, e) := selectremove(type, e, 'exp(anything)');
          wExp := `+`(op(map2(op, 1, wExp)));
          logmake := t -> `if`(make=eval,eval,Sum)
                              (piecewise_And(dom_spec,t,0), var=new_rng);
          w := `*`( `if`(w = 1, 1, w ^ logmake(1))
                  , op(map((f -> op(1,f) ^ logmake(op(2,f))), wPow))
                  , `if`(wExp = 0, 1, exp(logmake(wExp))) );
        end if;
        e := w * make(piecewise_And(dom_spec, `*`(op(e)), mode()), var=new_rng);

        # `rest' originally comes from `entry', and this reinserts it after some
        # processing. The original KB was valid, so this one should also be valid.
        kb := foldr(assert, op(2,entry), op(rest));
        ASSERT(type(kb,t_kb), "Loop/wrap{t_binder}: rebuilding kb produced contradiction");

      elif entry :: t_stmt then
        # We evaluate arrrgs first, in case op(1,stmt) is an operation (such as
        # piecewise) that looks ahead at how many arguments it is passed before
        # they are evaluated.
        arrrgs := op(op(2,entry)), e, op(op(3,entry));
        e      := op(1,entry)(arrrgs);
        if entry :: t_exp then
          if mode <> `+` then
            print("Warning: heap mode inconsistency?", heap, mode1)
          end if;
          mode := `*`;
        end if
      else error "Malformed heap entry %1", entry end if
    end do;
    if mode <> `*` then
      print("Warning: heap mode inconsistency??", heap, mode1)
    end if;
    e, kb := enter_piecewise(e, kb, mode);
    rest := kb_subtract(kb, kb0);
    rest := map(proc(a::[identical(assert),anything],$) op(2,a) end proc, rest);
    piecewise_And(rest,e,mode())
  end proc;

  # Rewrite product(...piecewise(i+42=lo+42,th,el)...,i=lo..hi)
  # to eval(...th...,i=lo)*product(...el...,i=lo+1..hi)
  t_peel := 'And(specfunc({sum,Sum,product,Product}),
                 anyfunc(anything, name=range))';
  peel := proc(e, $)
    subsindets(e, t_peel, do_peel);
  end proc;
  do_peel := proc(e, $)
    local make, body, x, r, cond, line, test, x0, r0, cond0, here, rest;
    if not (e :: t_peel) then return e end if;
    if   op(0,e) in '{sum    ,Sum    }' then make := `+`;
    elif op(0,e) in '{product,Product}' then make := `*`; end if;
    body, r := op(e);
    x, r    := op(r);
    for cond in indets(body, '{`=`(algebraic),`<`,`<=`}') do
      line := `-`(op(cond));
      if 1 <> degree(line, x) then next end if;
      if cond :: `=` then
        cond0 := true;
        if Testzero(eval(line, x=lhs(r))) then
          x0 := lhs(r); r0 := applyop(`+`, 1, r, 1);
        elif Testzero(eval(line, x=rhs(r))) then
          x0 := rhs(r); r0 := applyop(`-`, 2, r, 1);
        else next end if;
      else
        test := proc(x0, x1, $)
          local res;
          res := evalb(not op(0,cond)(eval(line, x=x1), 0));
          `if`(res in '{true,false}'
                 and evalb(op(0,cond)(eval(line, x=x0), 0)) = res,
               res,
               FAIL)
        end proc;
        cond0 := test(lhs(r), lhs(r)+1);
        if cond0 <> FAIL then
          x0 := lhs(r); r0 := applyop(`+`, 1, r, 1);
        else
          cond0 := test(rhs(r), rhs(r)-1);
          if cond0 <> FAIL then
            x0 := rhs(r); r0 := applyop(`-`, 2, r, 1);
          else next end if;
        end if;
      end if;
      here := subs(cond =           cond0 , body);
      rest := subs(cond = evalb(not cond0), body);
      return make(eval(here, x=x0), do_peel(eval(subsop(1=rest, [2,2]=r0, e))));
    end do;
    return e;
  end proc;

  # Expand sum(a*(b-c),q) to sum(a*b,q)-sum(a*c,q)
  split := proc(e, $)
    subsindets(e, 'And(specfunc({sum,Sum}),
                       anyfunc(And(`*`,Not(`*`(Not(`+`)))),name=anything))',
                  do_split);
  end proc;
  do_split := proc(e, $)
    local terms, x;
    terms := convert(expand(op(1,e), op(indets(op(1,e), function))),
                     'list', `+`);
    x := op([2,1],e);
    `+`(op(map(proc(term, $)
      local s, r;
      s, r := selectremove(depends, convert(term, 'list', `*`), x);
      `*`(op(r), subsop(1=`*`(op(s)),e))
    end proc, terms)))
  end proc;

  # Simplify f(lo-1)*product(f(i),i=lo..hi) to product(f(i),i=lo-1..hi)
  graft := proc(e, $)
    subsindets(e, 'Or(And(`*`,Not(`*`(Not(specfunc({product,Product}))))),
                      And(`+`,Not(`+`(Not(specfunc({sum    ,Sum    }))))))',
                  do_graft);
  end proc;
  do_graft := proc(e, $)
    local produce, factors, i, j;
    produce := `if`(e::`*`, '{product,Product}',
                            '{sum    ,Sum    }');
    factors := sort(convert(e,'list'),
                    key = (factor -> -numboccur(factor,produce)));
    for i from nops(factors) to 2 by -1 do
      for j from i-1 to 1 by -1 do
        if op(j,factors) :: 'And'('specfunc'(produce),
                                  'anyfunc(anything,name=range)') then
          if Testzero(op(i,factors) - eval(op([j,1],factors),
               op([j,2,1],factors)=op([j,2,2,1],factors)-1)) then
            factors := subsop(i=NULL,applyop(`-`,[j,2,2,1],factors,1));
            break
          elif Testzero(op(i,factors) - eval(op([j,1],factors),
                 op([j,2,1],factors)=op([j,2,2,2],factors)+1)) then
            factors := subsop(i=NULL,applyop(`+`,[j,2,2,2],factors,1));
            break
          end if
        end if
      end do
    end do;
    op(0,e)(op(factors))
  end proc;

  # Normalize sum(f(i),i=2..hi) to sum(f(i+2),i=0..hi-2)
  rebase_lower := proc(e, $)
    subsindets(e, 'And(specfunc({sum,Sum,product,Product}),
                       anyfunc(anything,
                         name=Not({0,SymbolicInfinity,undefined})..anything))',
                  do_rebase_lower);
  end proc;
  do_rebase_lower := proc(e, $)
    subsop([2,2,1]=0,
           applyop(`-`,
                   [2,2,2],
                   applyop(eval, 1, e, op([2,1],e)=op([2,1],e)+op([2,2,1],e)),
                   op([2,2,1],e)))
  end proc;

  # Normalize sum(f(i),i=lo..2) to sum(f(i+2),i=lo-2..0)
  rebase_upper := proc(e, $)
    subsindets(e, 'And(specfunc({sum,Sum,product,Product}),
                       anyfunc(anything,
                         name=anything..Not({0,SymbolicInfinity,undefined})))',
                  do_rebase_upper);
  end proc;
  do_rebase_upper := proc(e, $)
    subsop([2,2,2]=0,
           applyop(`-`,
                   [2,2,1],
                   applyop(eval, 1, e, op([2,1],e)=op([2,1],e)+op([2,2,2],e)),
                   op([2,2,2],e)))
  end proc;

  ModuleLoad := proc($)
    # Override csgn to work a little bit harder on piecewise and sum
    # (to get rid of csgn(1/2+1/2*sum(piecewise(...,1,0),...))
    #  produced by int on a Gaussian mixture model)
    unprotect(csgn);
    csgn := overload([
      # Handle if the csgn of a piecewise doesn't depend on which branch
      proc(a :: specfunc(piecewise), $)
        option overload;
        local r, i;
        r := {seq(`if`(i::even or i=nops(a), csgn(op(i,a)), NULL),
                  i=1..nops(a))};
        if nops(r)=1 then return op(r) end if;
        if not assigned(_Envsignum0) then
          r := r minus {0};
          if nops(r)=1 then return op(r) end if;
        end if;
        error "invalid input: cannot csgn %1", a;
      end proc,
      # Handle if the csgn of a sum doesn't depend on the bound variable
      proc(a :: And(specfunc({sum, Sum}), anyfunc(anything, name=range)), $)
        option overload;
        local r;
        r := csgn(op(1,a));
        if not depends(r,op([2,1],a)) then
          return signum(op([2,2,2],a)+1-op([2,2,1],a)) * r
        end if;
        error "invalid input: cannot csgn %1", a;
      end proc,
      csgn]);
    protect(csgn);

    # Override sum to fail faster
    unprotect(sum);
    sum := overload([
      proc(f :: Not({`+`,`+`^integer}),
           k :: name=And(range,Not(range(rational))), $)
        option overload;
        if not (`-`(op(rhs(k))) :: 'rational')
           and not (subsindets(f, 'anything^integer', f->op(1,f))
                    :: '{`+`,And(`*`,Not(`*`(Not(`+`))))}')
           and depends(indets(f, '{specfunc(idx), specindex(idx)}'), op(1,k))
        then
          'procname(_passed)'
        else
          error "invalid input: cannot fast-fail sum(%1, %2)", _passed
        end if
      end proc,
      sum]);
    protect(sum);

    :-`print/Ints` := curry(thismodule:-Print,Ints);
    :-`print/Sums` := curry(thismodule:-Print,Sums);
    :-`print/ints` := curry(thismodule:-Print,ints);
    :-`print/sums` := curry(thismodule:-Print,sums);

  end proc;
  ModuleLoad():
end module; # Loop


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

# make gensym global, so that it can be shared with other 'global' routines
gensym := module ()
  export ModuleApply;
  local gs_counter, utf8, blocks, radix, unicode;
  gs_counter := -1;
  utf8 := proc(n :: integer, $)
    local m;
    if n<128 then n
    elif n<2048 then 192+iquo(n,64,'m'), 128+m
    elif n<65536 then 224+iquo(n,4096,'m'), 128+iquo(m,64,'m'), 128+m
    elif n<2097152 then 240+iquo(n,262144,'m'), 128+iquo(m,4096,'m'), 128+iquo(m,64,'m'), 128+m
    elif n<67108864 then 248+iquo(n,16777216,'m'), 128+iquo(m,262144,'m'), 128+iquo(m,4096,'m'), 128+iquo(m,64,'m'), 128+m
    elif n<2147483648 then 248+iquo(n,1073741824,'m'), 128+iquo(m,16777216,'m'), 128+iquo(m,262144,'m'), 128+iquo(m,4096,'m'), 128+iquo(m,64,'m'), 128+m
    end if
  end proc;
  blocks := map((b -> block(convert(op(0,b), decimal, hex), op(1,b))),
                ["4e00"(20950)]);
  radix := `+`(op(map2(op, 2, blocks))) / 2;
  unicode := proc(nn, $)
    local n, b;
    n := nn;
    for b in blocks do
      if n < op(2,b) then return n + op(1,b) else n := n - op(2,b) end if
    end do
  end proc;
  ModuleApply := proc(x::name, $)
    gs_counter := gs_counter + 1;
    cat(x, op(map(StringTools:-Char, map(utf8 @ unicode, applyop(`+`, 1, map(`*`, convert(gs_counter, 'base', radix), 2), 1)))))
  end proc;
end module: # gensym

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

BindingTools := module ()
  option package;
  export generic_evalat, generic_evalatstar;

  generic_evalat := proc(vv::{name,list(name)}, mm, eqs, $)
    local v, m, eqsRemain, eq, rename, funs;
    funs := map2(op, 0, indets(mm, 'function'));
    eqsRemain := select(
      (eq -> op(1,eq) <> op(2,eq)
             and not has(op(1,eq), vv)
             and (not (op(1,eq) :: 'name')
                  or depends(mm, op(1,eq))
                  or member(op(1,eq), funs))),
      eqs);
    if nops(eqsRemain) = 0 then return vv, mm end if;
    m := mm;
    rename := proc(v::name, $)
      local vRename;
      if depends(eqsRemain, v) then
        vRename := gensym(v);
        m := subs(v=vRename, m);
        vRename
      else
        v
      end if
    end proc;
    if vv :: name then
      v := rename(vv)
    else
      v := map(rename, vv);
    end if;
    v, eval(m, eqsRemain);
  end proc:

  generic_evalatstar := proc(body, bound::list, eqs, $)
    local indefinite, e, n, b, j;
    e := foldl(((x,i) -> `if`(i::`=`,
                              lam(lhs(i), rhs(i), x),
                              lam(i, indefinite, x))),
               body, op(bound));
    e := eval(e, eqs); # Piggyback on `eval/lam`
    n := nops(bound);
    b := table();
    for j from n to 1 by -1 do
      b[j] := `if`(op(2,e)=indefinite, op(1,e), `=`(op(1..2,e)));
      e := op(3,e);
    end do;
    e, [entries(b, 'nolist', 'indexorder')]
  end proc:
end module: # BindingTools