program nwhilest;
var i, j, k : integer;
begin
    i := 1;
    while i < 10 do begin
        j := 1;
        while j < 10 do begin
            k := 1;
            while k < 10 do begin
                if (k div 2) * 2 = k then
                        k := k + 1
                    end
                else
                        k := k + 1
                    end
            end;
            j := j + 1;
        end;
        i := i + 1
    end;
    writeln('All End')
end.


export Improve := module ()
    uses Domain_Type;
    export Simplifiers := table();
    export ModuleApply := proc(dom :: HDomain, $)::HDomain_mb;
        local es := sort( [indices(Domain:-Improve:-Simplifiers,nolist) ]
                          , key=(si->Simplifiers[si]:-SimplOrder))
             , bnd, sh;
        bnd, sh := op([1..2], dom);
        sh := foldr(((f,q)->proc() cmp_simp_sh(f,q,args) end proc)
                   ,(proc(_,b,$) b end proc), op(es))(bnd, sh);
        DOMAIN(bnd, sh);
    end proc;

    local ModuleLoad := proc($)
      LoadSimplifiers();
      LoadSimplifiers := (proc() end proc);
    end proc;#ModuleLoad

    local LoadSimplifiers := proc($)
      local lib_path, drs, improve_path, simpls_paths, simpl_path, names0, names1, new_names, nm;
      unprotect(Simplifiers);
      lib_path := LibraryTools:-FindLibrary(Hakaru);
      if lib_path=NULL then error "Hakaru library not found"; end if;
      lib_path := FileTools:-ParentDirectory(lib_path);
      drs := kernelopts(dirsep);
      improve_path := `cat`(lib_path,drs,"Domain",drs,"Improve");

      simpls_paths := FileTools:-ListDirectory(improve_path);
      for simpl_path in simpls_paths do
        names0 := {anames(user)};
        read(`cat`(improve_path,drs,simpl_path));
        names1 := {anames(user)};
        new_names := names1 minus names0;
        for nm in new_names minus {entries(Simplifiers,nolist)} do
          if nm :: `module`(SimplName,SimplOrder) then
            if assigned(Simplifiers[nm:-SimplName])
            and not Simplifiers[nm:-SimplName] = nm then
              WARNING("overwriting old simplifier! (%1)", Simplifiers[nm:-SimplName]):
            end if;
            Simplifiers[nm:-SimplName] := eval(nm);
          else
            WARNING("not recognized as a simplifier: %1", nm);
          end if;
        end do;
      end do;
      protect(Simplifiers);
    end proc;#LoadSimplifiers

    local combine_errs := proc(err::DomNoSol, mb, $)
        if mb :: DomNoSol then
            DNoSol(op(err),op(mb));
        else
            mb
        end if;
    end proc;

    # compose two simplifiers, combining errors if both fail
    local cmp_simp_sh := proc(simp0, simp1, bnd, sh :: {DomShape,DomNoSol}, $)::{DomShape,DomNoSol};
      local res, sh1; sh1 := Simplifiers[simp0](bnd, sh);
      if not sh1 :: DomNoSol then
          simp1(bnd, sh1);
      else
          combine_errs( sh1, simp1(bnd, sh) );
      end if;
    end proc;
end module;


#include "utils.mpl" // you can include mpl files
$creepAmt:10 // just like normal CRPL
$addPerTime:1
$Delay:15
$maxAmt:1000
$incrementInterval:10

amt()inline, CRPL{<-creepAmt 1 add} // also you can create CRPL functions

main()inline{ // the function that calls every tick
	/*
	recommended to be inline.
	all inline function will be implaced to their calls.
	*/
	once{
		RemoveImages(Self());
		SetImage(Self(), "main", "CustomEmitter");
		SetTextSize(0.6);
		SetTimer1(incrementInterval + 1);
	}
	if(GetTimer1() == 0){
		SetText("Amt " $ creepAmt $ endl() $ "Interval: " $ round(Delay/30.0, 2));
		SetCreeper(CurrentCoords(), amt());
		SetTimer1(Delay);
	}
	if (GetTimer0()==1 && creepAmt < maxAmt){
		creepAmt = creepAmt + addPerTime;
		SetTimer0(incrementInterval + 1);
	}
	if (GetTimer2() == 0){
		f(RandCoords());
		SetTimer2(60);
	}
	else if(creepAmt > maxAmt) once creepAmt = maxAmt;
}


var $g i32
var $h i32
func $multiwayfunc ( var %n i32) i32 {
 multiway (dread i32 %n) @labdft {
   (add i32 (dread i32 $g, dread i32 $h)): goto @lab0
   (dread i32 $h): goto @lab1
   (constval i32 888): goto @lab0
   (constval i32 'Y'): goto @lab0
   (neg i32 (dread i32 $h)) : goto @lab9 }
@lab0
 return (constval i32 -3)
@labdft
 return (constval i32 100)
@lab9
 return (constval i32 9)
@lab1
 return (constval i32 1) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


go := module ()
  local undoStack, sr;
  export here, where, up, child, fac, trm, silent, undo, ModuleApply;

  where := [];

  up := proc()
    here, where := op(1,where)(here),
                   [op(2..-1,where)];
  end proc;

  child := proc(i :: integer)
    local _;
    here, where := op(i,here),
                   [unapply(subsop(i=_,here), _), op(where)];
  end proc;

  sr := proc(operator, t :: type)
    local s, r, _;
    if here :: operator then
      s, r := selectremove(type, here, t);
      here, where := s, [unapply(operator(_,r), _), op(where)];
    elif type(here, t) then
      where := [(_->_), op(where)];
    else
      here, where := operator(), [unapply(operator(_,here), _), op(where)];
    end if
  end proc;

  silent := proc()
    local instr, _, j;
    for instr in _passed do
      if instr :: list then
        thisproc(op(instr))
      elif instr :: integer then
        child(instr)
      elif instr = up then
        up()
      elif instr :: all(anything) then
        here, where := op(1,instr),
                       [unapply(subsindets(here,identical(op(1,instr)),(x->_)),
                                _),
                        op(where)];
      elif instr :: fac(type) then
        sr(`*`, op(1,instr))
      elif instr :: trm(type) then
        sr(`+`, op(1,instr))
      elif instr :: type then
        j := [seq(`if`(op(j,here) :: instr, j, NULL), j=1..nops(here))];
        if nops(j) = 1 then
          child(op(1,j))
        else
          error "not unique: %%", op(map(op, j, here))
        end if
      elif instr :: procedure then
        here := instr(here)
      end if
    end do
  end proc;

  undoStack := [];

  undo := proc()
    here, where := op(op(1,undoStack));
    undoStack := [op(2..-1,undoStack)]:
    here, where;
  end proc;

  ModuleApply := proc()
    undoStack := [[here, where], op(undoStack)];
    try silent(_passed);
    finally print(here, where);
    end
  end proc;
end module:


# convert from Gonnet's FPAccuracy data sets to mpfr format
# http://www.inf.ethz.ch/personal/gonnet/FPAccuracy/all.tar.Z

# 1 - cut the lines from (say) C/acos.c, remove the 3rd (eps) field,
#     replace the commata ',' by spaces, and remove the final '};'
#     (hint: cut -d" " -f1,2,4,5 /tmp/acos.c > /tmp/acos2.c)
# 2 - edit the infile and outfile lines below, and run
#     maple -q < gonnet.mpl

infile := "/tmp/acos2.c":
outfile := "acos":

###################### don't edit below this line #############################

foo := proc(arg_m, val_m, arg_e, val_e, fp)
   fprintf (fp, "53 53 n ", 53);
   to_hex(arg_m, arg_e, fp);
   fprintf (fp, " ");
   # warning: Gonnet stores -val_e
   to_hex(val_m, -val_e, fp);
   fprintf (fp, "\n");
end:

to_hex := proc(m, e, fp)
   if m<0 then fprintf (fp, "-") fi;
   fprintf (fp, "0x%sp%d", convert(abs(m),hex), e);
end:

copyright := proc(fp)
   fprintf (fp, "# This file was generated from the FPAccuracy package\n# http://www.inf.ethz.ch/personal/gonnet/FPAccuracy/all.tar.Z:\n# Copyright (C) Gaston H. Gonnet\n# This program is free software; you can redistribute it and/or\n# modify it under the terms of the GNU General Public License\n# as published by the Free Software Foundation; either version 2\n# of the License, or (at your option) any later version.\n# This program is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n# GNU General Public License for more details.\n# You should have received a copy of the GNU General Public License\n# along with this program; if not, write to the Free Software\n# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.\n")
end:

fp := fopen (outfile, WRITE):

l := readdata(infile, integer, 4):
copyright(fp):
for e in l do foo(op(e), fp) od:

fclose (fp);

quit;


######################################################################
# Commutative operad

`is_element/comm` := (A::set) -> (z) -> type(z,identical(0));

`is_equal/comm` := (A::set) -> (x,y) -> true;

`is_leq/comm` := (A::set) -> (x,y) -> true;

`random_element/comm` := (A::set) -> () -> 0;

`list_elements/comm` := (A::set) -> [0];

`count_elements/comm` := (A::set) -> 1;

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

`gamma/comm` := (A::set,B::set) -> (p) -> (z,zz) -> 0;


# Checks if an expression has domain bounds/shape, and check for either one.
export Has := module ()
    export ModuleApply := proc(e, $)::truefalse;
        Bound(e) or Shape(e);
    end proc;

    export Bound := proc(e, $)::truefalse;
        assigned(Domain:-ExtBound[op(0,e)]) and
        evalb(e :: Domain:-ExtBound[op(0,e)]:-MapleType);
    end proc;

    export Shape := proc(e, $)::truefalse;
        assigned(Domain:-ExtShape[op(0,e)]) and
        evalb(e :: Domain:-ExtShape[op(0,e)]:-MapleType);
    end proc;
end module;


3 + 5 ~

5 - 4 ~

5 * 5 ~
2 / 3 ~

jedi ( 5 < 6 )
{ 2 + 3 }
sith
{ 1 + 6 } ~

x = 5

yell ( x < 6 )
{ 6 + 6 } ~
jedi ( 5 > 6 )
{ 2 + 3 }
sith
{ 1 + 6 } ~
x = 3 ~
yell ( x > 6 )
{ 6 + 6 } ~
quit


repeat process ACV_teleportation {
/scoreboard players reset @e ACV_TP_FROM
/scoreboard players reset @e ACV_TP_UNEVEN
/scoreboard players reset @e ACV_TP_TO

/execute @e[type=area_effect_cloud,name=ACV_PortalIn] ~ ~ ~ scoreboard players operation @e[tag=!ACV_TpProof,dy=0] ACV_TP_FROM = @e[type=area_effect_cloud,name=ACV_PortalIn,r=0,c=1] ACV_COLOR

// Calulate the target portal
/execute @e[score_ACV_TP_FROM_min=0] ~ ~ ~ scoreboard players operation @e[score_ACV_TP_FROM_min=0,r=0,c=1] ACV_TP_TO = @e[score_ACV_TP_FROM_min=0,r=0,c=1] ACV_TP_FROM
/execute @e[score_ACV_TP_FROM_min=0] ~ ~ ~ scoreboard players operation @e[score_ACV_TP_FROM_min=0,r=0,c=1] ACV_TP_UNEVEN = @e[score_ACV_TP_FROM_min=0,r=0,c=1] ACV_TP_FROM
/scoreboard players operation @e[score_ACV_TP_FROM_min=0] ACV_TP_UNEVEN %= 2 ACV_CONSTANT
/scoreboard players add @e[score_ACV_TP_UNEVEN_min=0,score_ACV_TP_UNEVEN=0] ACV_TP_TO 1
/scoreboard players remove @e[score_ACV_TP_UNEVEN_min=1,score_ACV_TP_UNEVEN=1] ACV_TP_TO 1

// Teleport the entity to the other portal
/tp @e[score_ACV_TP_TO_min=0,score_ACV_TP_TO=0] @e[type=area_effect_cloud,name=ACV_PortalOut,score_ACV_COLOR_min=0,score_ACV_COLOR=0]
/tp @e[score_ACV_TP_TO_min=1,score_ACV_TP_TO=1] @e[type=area_effect_cloud,name=ACV_PortalOut,score_ACV_COLOR_min=1,score_ACV_COLOR=1]
/tp @e[score_ACV_TP_TO_min=2,score_ACV_TP_TO=2] @e[type=area_effect_cloud,name=ACV_PortalOut,score_ACV_COLOR_min=2,score_ACV_COLOR=2]
/tp @e[score_ACV_TP_TO_min=3,score_ACV_TP_TO=3] @e[type=area_effect_cloud,name=ACV_PortalOut,score_ACV_COLOR_min=3,score_ACV_COLOR=3]
}


$ifndef _TSOLS_LIST_
$define _TSOLS_LIST_

$include "Utils.mpl"

TsolsList:=module()
    option object;
    export
            reps,
            teqs,
            torders,
            tsols,
            tcons,
            ModuleApply::static,
            sortTsolsList::static,
            printTsolsList::static;

    ModuleApply:=proc(ss::list(TeqSol))
        local s;
        s:=Object(TsolsList);
        s:-reps:=map(x->getRep(x)$getNSols(x),ss);
        s:-teqs:=map(x->x:-teq[x:-teqInd][],ss);
        s:-torders:=map(x->x:-teqInd[],ss);
        s:-tsols:=map(x->x:-tsols[],ss);
        s:-tcons:=map(x->x:-tcons[],ss);
        sortTsolsList(s);
        return s;
    end proc:

    sortTsolsList:=proc(s::TsolsList)
        local ind,n:=numelems(s:-reps);
        ind:=map(x->`if`(x=[],1,0),s:-tsols)*n^3 # 有解的排在无解的前面
            +numelems~(s:-tcons)*n^2             # 约束条件少的排在前面
            +sortByComplexity(s:-tcons,index)*n; # 约束条件简单的排在前面
        ind:=sort(ind,output=permutation);
        s:-reps:=s:-reps[ind];
        s:-teqs:=s:-teqs[ind];
        s:-torders:=s:-torders[ind];
        s:-tsols:=s:-tsols[ind];
        s:-tcons:=s:-tcons[ind];
    end proc:

    printTsolsList:=proc(s::TsolsList)
        local i,n:=numelems(s:-reps);
        printf("============================================\n");
        for i from 1 to n do
            printf(`if`(s:-torders[i]=1,"正向\n","逆向\n"));
            print(s:-reps[i]);
            # print(s:-teqs[i]);
            print(s:-tsols[i]);
            print(s:-tcons[i]);
        end do;
        printf("============================================\n");
        return;
    end proc:

end module:
$endif


(*
 * 保存不变量分类状态的对象
 *
 * 状态分为：
 *     1 线性偏微分方程组求解失败
 *     2 不变量方程组求解失败
 *     3 取特解失败
 *     4 变换方程求解失败
 *     5 变换方程求解成功，特解可能是代表元，是否是代表元留给人工判断
*)
$ifndef _INVSOL_
$define _INVSOL_

InvSol:=module()
    option object;
    export
        # 导出变量
        stateCode::{1,2,3,4,5},     # 状态代码
        oieq:={},                   # 导出新偏微分方程的不变量方程（如果存在的话）
        oisol,                      # 导出新偏微分方程的不变量方程的解（如果存在的话）
        oeq::set,                   # 导出不变量的偏微分方程
        Delta:=[],                  # 不变量
        orders:=[],                 # 不变量对应的阶数
        ieqCode,                    # 不变量方程的代码
        ieq::list,                  # 不变量方程
        isol,                       # 不变量方程的解（一个InvSol对象只含一个解）
        icon::set,                  # 不变量方程解的条件
        teq:=[[],[]],               # 变换方程（有两个）
        tsol:=[[],[]],              # 变换方程的解，每个方程都有可能有多个解
        tcon:=[[],[]],              # 变换方程的解对于的条件
        rep,                        # 代表元的表达式形式
        rvec,                       # 代表元的系数矩阵形式
        vars,                       # 偏微分方程中的剩余自由变量，初始时为a[1]..a[nvars]
        nvars,                      # 生成元的个数
        As::static,                 # 每个生成元的伴随矩阵
        A::static,                  # 总的伴随变换矩阵
        # 导出函数
        ## 输出相关
        getDisplayIeq::static,      # 简化显示的不变量方程，将不变量的实际表达式简写为Delta
        getDisplayDelta::static,    # 输出不变量
        getDesc::static,            # 获取对象的特征描述
        ModulePrint::static,        # 打印和显示对象的值
        printSol::static,           # 详细显示对象信息
        printTeq::static,           # 显示变换方程的结果
        ## 设置相关
        setRep::static,             # 重新取代表元
        setIsol::static,            # 重新对不变量方程取解
        getRep::static;             # 获取代表元，转化为global对象便于比较

    # 重新取代表元
    setRep:=proc(s::InvSol,rvec::list,{nocheck::boolean:=false})
        local v,r;
        if not nocheck then
            # 解的检验
            r:=eval(subs(seq(a[i]=rvec[i],i=1..numelems(rvec)),s:-ieq));
            if not andmap(evalb,r) then
                error "不是不变量方程的解，代入结果为%1",r;
            end if;
        end if;
        s:-stateCode:=4;
        s:-rvec:=Matrix(rvec);
        s:-rep:=add(rvec[i]*v[i],i=1..numelems(rvec));
        return;
    end proc:

    # 重新对不变量方程取解
    setIsol:=proc(s::InvSol,isol,{nocheck::boolean:=false})
        local r;
        if not nocheck then
            # 解的检验
            r:=RealDomain:-simplify(subs(isol[],s:-ieq));
            if not andmap(evalb,r) then
                error "不是不变量方程的解，代入结果为%1",r;
            end if;
        end if;
        s:-stateCode:=3;
        s:-isol:=isol;
        s:-icon:=findSolutionDomain(isol);
        return;
    end proc:

    # 获取代表元，转化为global对象便于比较
    getRep:=proc(s::InvSol)
        return convert(s:-rep,`global`);
    end proc:

    # 简化显示的不变量方程，将不变量的实际表达式简写为Delta
    getDisplayIeq:=proc(self::InvSol)
        local Delta;
        return {seq(Delta[i]=rhs(self:-ieq[i]),i=1..numelems(self:-Delta))};
    end proc:

    # 输出不变量
    getDisplayDelta:=proc(self::InvSol)
        local Delta;
        return [seq(Delta[i]=self:-Delta[i],i=1..numelems(self:-Delta))];
    end proc:

    # 获取对象的特征描述
    getDesc:=proc(s)
        if   (s:-stateCode=1) then
            return s:-oeq;
        elif (s:-stateCode=2) then
            return getDisplayIeq(s);
        elif (s:-stateCode=3) then
            return s:-isol;
        elif (s:-stateCode=4) then
            return s:-rep;
        elif (s:-stateCode=5) then
            return s:-rep;
        end if;
    end proc:

    # 打印和显示对象的值
    ModulePrint:=proc(s)
        return getDesc(s);
    end proc:

    # 输出解
    printSol:=proc(s::InvSol)
        printf("---------------------------------------------------------");
        if     (s:-stateCode=1) then
            printf("新的不变量求解失败，状态代码1");
            print(s:-oieq);
            printf("取解");
            print(s:-oisol);
            printf("求解失败的偏微分方程为");
            print(s:-oeq);
        elif    (s:-stateCode=2) then
            printf("不变量方程求解失败，状态代码2");
            print(getDisplayIeq(s));
        elif    (s:-stateCode=3) then
            printf("取代表元失败，状态代码3");
            print(getDisplayIeq(s));
            printf("取解");
            print(s:-isol);
        elif    (s:-stateCode=4) then
            printf("变换方程求解失败，状态代码4");
            print(getDisplayIeq(s));
            printf("取解");
            print(s:-isol);
            printf("具有约束");
            print(s:-icon);
            printf("取代表元");
            print(s:-rep);
            printf("求解失败的两个变换方程为");
            print~(s:-teq);
        elif    (s:-stateCode=5) then
            printf("变换方程求解成功，状态代码5");
            print(getDisplayIeq(s));
            printf("取解");
            print(s:-isol);
            printf("具有约束");
            print(s:-icon);
            printf("取代表元");
            print(s:-rep);
            printf("变换方程有解");
            printTeq(s,1);
            printTeq(s,2);
        end if;
        printf("---------------------------------------------------------");
        return;
    end proc:

    # 输出变换方程和解
    printTeq:=proc(sol,pos)
        if (sol:-tsol[pos]=[]) then
            printf("变换方程 %d 无解",pos);
            printf("方程为");
            print(sol:-teq[pos]);
        else
            printf("变换方程 %d 有解",pos);
            printf("方程为");
            print(sol:-teq[pos]);
            printf("有解");
            print(sol:-tsol[pos]);
            printf("具有条件");
            print(sol:-tcon[pos]);
        end if;
    end proc:
end module:

$endif


# Apply a domain to an expression.
# Apply will perform certain 'simplifications' to make sure the
# domain application is well-formed. e.g.,
#   DOMAIN( DBound( [x,y], [xt,yt] ), DConstrain(..) )
#      is the same as
#   DOMAIN(        ..               , DInto(x,xt,DInto(y,yt,DConstrain(..))) )
# basically, when we see an 'unbound' variable in the 'RHS' , we should bind
# it with the default 'DInto'.
export Apply := module ()
       export ModuleApply :=
         proc(dom :: HDomain_mb, kb0 :: t_kb
             ,f_into := "default"
             ,f_body := "default", $)
           local vs, sh, ctx;
           if dom :: DomNoSol then
               error "cannot apply %1", dom;
           end if;
           vs, sh := op(dom);
           vs := Domain:-Bound:-withVarsIxs(vs);
           ctx := [ kb0,
              `if`(f_into="default",`do_mk`,f_into),
              `if`(f_body="default",`do_body`,f_body) ];
           (e->do_apply({}, e, vs, sh, ctx));
       end proc;

       export Shape := proc(dsh :: DomShape, e, $) ModuleApply( DOMAIN( [], dsh ), e ) end proc;
       export Bound := proc(dbn :: DomBound, e, $) ModuleApply( DOMAIN( dbn, DConstrain() ), e ) end proc;

       # main loop of the apply function
       # done_  := variables already integrated
       # e      := expr
       # vs     := domain bounds
       # sh     := domain shape
       # ctx[0] := KB (context for f_into/f_body)
       # f_into := how to make a DomInto
       # f_body := how to make the expression body
       local do_apply := proc(done__, e, vs, sh_, ctx, $)
           local sh := sh_, done_ := done__
               , r, cond, cond_outer, vn, vt, shv, vars, deps, ctx1, rn;
           # If the solution is a constraint, and the constraint is true,
           # then just produce the expression. If it isn't necessarily true
           # (i.e. trivial) then produce a Partition with the constraint as a
           # guard.
           if sh :: DomConstrain then
               vars := Domain:-Bound:-varsOf(vs,"set") minus done_;
               cond, cond_outer := select_cond_outer(sh, vars);
               # if there are still integrals which have not been applied, apply
               # them now
               do_constrain(cond_outer)(do_mks(e, (r,kb1) -> do_constrain(cond)(op(3,ctx)(r, kb1)), vars, vs, ctx))
           # if the solution is a sum of solutions, produce the algebraic sum
           # of each summand of the solution applied to the expression.
           elif sh :: DomSum then
               `+`(seq(do_apply(done_, e, vs, s, ctx), s=sh))
           # if the solution is a split solution, just make `do_apply' over
           # the values of the Partition (the subsolutions)
           elif sh :: DomSplit then
               Partition:-Amap(
                 [ (c,_)->c
                 , (p,c)->do_apply(done_, e, vs, p, applyop(kb->KB:-assert(c,kb),1,ctx))
                 , c->c ], op(1, sh) );
           # performs the 'make' on the expression after recursively
           # applying the solution
           elif sh :: DomInto then
               # deconstruction
               vn, vt, shv := op(sh);
               # extract bounds which have not been applied upon which this
               # bound depends. Those are applied after this one, so are not
               # in 'scope' in the recursive call
               vars := Domain:-Bound:-varsOf(vs,"set");
               deps := (indets(vt, DomBoundVar) intersect vars) minus done_ ;
               deps := `union`(deps, {vn});
               done_ := `union`(done_, deps) ;

               shv, cond_outer := select_cond_outer(shv, done_);

               # build this integral, and the other this one depended on, then
               # recursively apply
               do_constrain(cond_outer)(
                 do_mks(e, (r,kb1) -> do_apply(done_, r, vs, shv, subsop(1=kb1,ctx)),
                      deps, Domain:-Bound:-upd(vs, vn, vt), ctx));
           else
               error "don't know how to apply %1", sh
           end if;
       end proc;

       export do_mk := proc(mk, e, vn, ty_, _kb)
           Domain:-ExtBound[mk]:-DoMk(e, vn, ty_);
       end proc;

       export do_body := proc(e, _kb) e end proc;

       local do_constrain := proc(cond0::{list,set,DomConstrain},$)
         local mk_cond, cond := cond0;
         if nops(cond)=0 then
           mk_cond := x->x;
         else
           cond := bool_And(op(cond));
           mk_cond := x->PARTITION([Piece(cond,x), Piece(Not(cond),0)]);
         end if;
         mk_cond;
       end proc;

       # A very cute way of pulling constraints out over other constructors
       # which relies on the fact that constraints are required to be innermost;
       # i.e. DomShape is a sum of products; i.e. this could also be called
       # 'factoring'.
       local select_cond_outer := proc(sh::DomShape, vars0::set({name,list(name)}), $)
         local csd, cs0, cs, ots, sh1, ins, vars := vars0;
         vars := map(v->`if`(v::list,v,[v])[],vars);
         csd := [op(indets(sh, And(DomConstrain,Not(satisfies(x->has(x,vars))))))];
         cs0 := map(x->{op(x)},csd);
         if cs0=[] then return sh, {}; end if;
         cs := map(x->[selectremove(z->andmap(c->z in c,cs0),x)], cs0);
         ots := op([1,1],cs); ins := map(curry(op,2), cs);
         sh1 := subs(zip(`=`, csd, map(DConstrain@op,ins)), sh);
         userinfo(3, Domain, printf("select_cond_outer(%a, %a) = %a, %a\n", sh, vars, sh1, ots));
         sh1, ots;
       end proc;

       # Move into an integral by augmenting the KB with the variables bound by
       # that integral.
       local into_mk := proc(dbnd::DomBound, vn, vt, ctx, $)
           local kb, v_i, v_k, vn_, kb1, rn;
           kb := op(1,ctx); if kb :: t_not_a_kb then return KB:-NotAKB() end if;

           v_i := Domain:-Bound:-varIx(dbnd, vn);
           v_k := op([1,v_i,3], dbnd);
           vn_, kb1 := Domain:-ExtBound[v_k]:-MakeKB(vn, Domain:-ExtBound[v_k]:-SplitRange(vt), kb);

           rn := `if`(evalb(vn=vn_), [], [vn=vn_]);
           subsop(1=kb1, ctx), rn;
       end proc;

       local do_mks := proc(e, kont, todo::({list,set})(DomBoundVar), dbnd :: DomBound, ctx, $)
           local vs, v_td, i, vt, kb0, v_mk, _, ctx1, rn, r := e;

           if todo :: set then
             vs := select(v->v in todo,Domain:-Bound:-varsOf(dbnd));
             vs := ListTools[Reverse](vs);
           else
             vs := todo;
           end if;

           if nops(vs)=0 then
             return kont(r,op(1,ctx));
           end if;

           v_td := op(1,vs);
           vs   := subsop(1=NULL,vs);
           i    := Domain:-Bound:-varIx(dbnd, v_td);
           _,vt,v_mk := op(op([1,i], dbnd));

           ctx1, rn := into_mk(dbnd, v_td, vt, ctx);
           if rn <> [] then
             r := subs(rn,r);
           end if;

           r := do_mks(r, kont, vs, dbnd, ctx1);
           op(2,ctx)(v_mk, r, v_td, vt, op(1,ctx));
       end proc;
end module;


type $atyp <[10] f32>
var $fff <i32> = 7789
func $foo ( var %i i32 )i32
type $i32ty <struct {
      @FF1 i32,
      @FF2 f64 }>

func $fact (
 var %n i32, var %m f32) i32 {
 var %alocal <$i32ty>
 dassign %alocal (constval i32 999)
 if (ne i32 i32 (dread i32 %n, constval i32 1)) {
    eval (dread i32 %n)
    call &foo(
      add i32 (dread i32 %n, constval i32 1))
    return (regread i32 %%retval)}
   else {
     return (constval i32 1) } }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# 字符串编码
str_encode:=s->sprintf("'%s'",HTTP:-URLEncode(s));

# 文件计数器
FileCounter:=module()
    local k:=0;
    export next_file,curr_file;

    curr_file:=proc()
        return sprintf("imgs/fig%03d",k);
    end proc:

    next_file:=proc()
        k:=k+1;
        return sprintf("imgs/fig%03d",k);
    end proc:
end module:

# 打开 MATLAB 并设置路径
Matlab:-openlink();
Matlab:-evalM(
    sprintf("cd(char(java.net.URLDecoder.decode(%s,'UTF8')))",str_encode(currentdir()))
);

# 处理坐标名称
label_str:=x->str_encode(`if`(type(x,string),x,latex(x,output=string)));

# 3D曲面绘图接口
plot3dm:=proc(_eq,{x::range:=0..1,y::range:=0..1,title::string:="",grid::list:=[100,100],labels::list:=[x,y,z],extcmd::string:="",
        view::{range,list(range)}:=[x,y,-infinity..infinity]})
    uses ImageTools;
    local eq,_view,plot3d_args;
    if type(view,range) then
        _view:=[x,y,view];
    else
        _view:=view;
    end if;
    eq:=simplify(_eq);
    plot3d_args:=remove(x->type(x,equation) and lhs(x)=:-extcmd,[_passed]);
    print(old_plot3d(plot3d_args[]));
    Matlab:-evalM(sprintf("plot3dm(%s,{%f,%f,%d},{%f,%f,%d},[%f,%f,%f,%f,%f,%f],%s,{%s,%s,%s},%s,%s)",
        str_encode( sprintf("%a",eq) ),
        op(1,x),op(2,x),grid[1],
        op(1,y),op(2,y),grid[2],
        map(t->(op(1,t),op(2,t)),_view)[],
        str_encode(title),
        label_str(labels[1]),label_str(labels[2]),label_str(labels[3]),
        str_encode(extcmd),
        str_encode(FileCounter:-next_file())
    ));
    Embed(Read(sprintf("%s.png",FileCounter:-curr_file())));
end proc:

# 重载plot3d函数
old_plot3d:=copy(plot3d,deep);
unprotect(plot3d);
plot3d:=plot3dm;


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

`eta/full_trees` := (A::set) -> `eta/trees`(A);

`gamma/full_trees` := (A::set,B::set) -> (p) -> (TT,UU) ->
  `gamma/trees`(A,B)(p)(TT,UU);


$include <binomsums.mpl>

$ifdef BUILD_MLA
savelib(BinomSums);
$endif


with(Threads:-Task):
fun:=proc()
    Continue(passed,x,Task=[`+`,1,2,3],y,Tasks=[`*`,[1,2],[2,3,3]],z);
end proc:
Start(passed,x,Task=[fun],Tasks=[`+`,[2,3,3],[6,6,6]]);


# This module forms part of NewSLO and is `$include`d there

RoundTrip := proc(e, t::t_type)
  local result;
  interface(screenwidth=9999, prettyprint=0, warnlevel=0,
    showassumed=0,quiet=true);
  kernelopts(assertlevel=0);
  result := eval(ToInert(Simplify(_passed)), _Inert_ATTRIBUTE=NULL);
  lprint(result)
end proc;

Simplify := proc(e, t::t_type, {ctx :: list := []}, $)
  subsindets(SimplifyKB(value(e), t, build_kb(ctx, "Simplify")),
             And({t_sum, t_product}, anyfunc(anything, anything=range)),
             e -> subsop(0 = `if`(e::t_sum, SumIE, ProductIE),
                         applyop(`+`, [2,2,2], e, 1)))
end proc;

SimplifyKB_ := proc(e, t::t_type, kb::t_kb, $)
  local patterns, x, kb1, ex;
  if t :: HMeasure(anything) then
    %fromLO(%improve(%toLO(e), _ctx=kb), _ctx=kb);
  elif t :: HFunction(anything, anything) then
    patterns := htype_patterns(op(1,t));
    if patterns :: Branches(Branch(PVar(name),anything)) then
      # Eta-expand the function type
      x := `if`(e::lam(name,anything,anything), op(1,e),
                op([1,1,1],patterns));
      x, kb1 := genType(x, op(1,t), kb, e);
      ex := app(e,x);
      lam(x, op(1,t), SimplifyKB_(ex, op(2,t), kb1))
    else
      # Eta-expand the function type and the sum-of-product argument-type
      x := `if`(e::lam(name,anything,anything), op(1,e), d);
      if depends([e,t,kb], x) then x := gensym(x) end if;
      ex := app(e,x);
      lam(x, op(1,t), 'case'(x,
        map(proc(branch)
            local eSubst, pSubst, p1, binds, y, kb1, i, pSubst1;
              eSubst, pSubst := pattern_match([x,e], x, op(1,branch));
              p1 := subs(pSubst, op(1,branch));
              binds := [pattern_binds(p1)];
              kb1 := kb;
              pSubst1 := table();
              for i from 1 to nops(binds) do
                y, kb1 := genType(op(i,binds), op([2,i],branch), kb1);
                pSubst1[op(i,binds)] := y;
              end do;
              pSubst1 := op(op(pSubst1));
              Branch(subs(pSubst1, p1),
                     SimplifyKB_(eval(eval(ex,eSubst),pSubst1), op(2,t), kb1))
            end proc,
            patterns)))
    end if
  else
    %simplify_assuming(e, kb)
  end if
end proc;

SimplifyKB := proc(e, t::t_type, kb::t_kb, $)
    eval(SimplifyKB_(args), [%fromLO=fromLO,%improve=improve,%toLO=toLO,%simplify_assuming=simplify_assuming]);
end proc;

# Testing

TestSimplify := proc(m, t, n::algebraic:=m, {verify:=simplify})
  local s, r;
  # How to pass keyword argument {ctx::list:=[]} on to Simplify?
  s, r := selectremove(type, [_rest], 'identical(ctx)=anything');
  CodeTools[Test](Simplify(m,t,op(s)), n, measure(verify), op(r))
end proc;

TestHakaru := proc(m, n::{set(algebraic),algebraic}:=m,
                   {simp:=improve, verify:=simplify, ctx::list:=[]})
  local kb := build_kb(ctx, "TestHakaru"), ver := measure(verify);
  ver := `if`(n::set, 'member'(ver), ver);

  CodeTools[Test](fromLO(simp(toLO(m), _ctx=kb), _ctx=kb), n,
    ver, _rest)
end proc;

TestDisint := module()
    export ModuleApply := proc(
      M::{t_Hakaru, list(anything)}, #args to disint, or just 1st arg
      n::set({t_Hakaru, identical(NULL)}), #desired return
      ctx::t_kb_atoms:= [], #context: assumptions, "knowledge"
      TLim::{positive, identical(-1)}:= 80 #timelimit
    )
      local disint_args, disint_var, expected := n;
      if M :: list then
        disint_args := [op(M),ctx];
      else
        disint_var := gensym('t');
        disint_args := [M,disint_var,ctx];
        expected := subs(:-`t`=disint_var,expected);
      end if;
      try
        do_test(disint_args, copy(expected), TLim, _rest);
      catch "time expired":
        error "Time expired while running: disint(%1)", disint_args;
      end try;
    end proc;

    # This is necessary because CodeTools seems to forgot the value
    # of our local variables (but only the `expected result' arg)
    # unless that arg is precisely a formal parameter, and we `copy' the
    # input to this function.
    local do_test := proc(disint_args, expected, tlim)
      timelimit( tlim, CodeTools[Test]
                 ( {disint(op(disint_args))}
                 , expected
                 , '`subset`(measure(simplify))'
                 , _rest));
    end proc;
end module;

TestEfficient := proc(e, t::t_type, t_kb := KB:-empty, {label::string := "Test" })
  local done_, result, todo;
  todo := SimplifyKB_(args[1..3]);
  done_ := eval(todo, [%fromLO=fromLO,%improve=improve,%toLO=toLO,%simplify_assuming=simplify_assuming]);

  _Env_TestTools_Try_printf := false;
  result := TestTools[Try](label, Efficient(done_),true);
  if result = NULL then
    printf("%s passed.\n", label);
  else
    error sprintf("%s FAILED.\n"
                  "The result of\n\t%a\n\tis not efficient.\n"
                 , label, todo );
  end if;
end proc;

# Test roughly for "efficient" Hakaru measure terms,
# i.e., those we want simplification to produce.
Efficient := proc(mm, $)
  local m, n;
  m := mm;
  if has(m, 'undefined') then
    return false;
  end if;
  while m :: '{lam(name, anything, anything),
               Context(anything, anything),
               case(anything, Branches(Branch(anything, anything))),
               And(specfunc(piecewise)
                  ,{anyfunc(anything, anything, Msum())
                   ,anyfunc(anything, anything, anything, Msum())})}' do
    m := op(`if`(op(0,m)='lam',3,`if`(op(0,m)='case',[2,1,2],2)),m);
  end do;
  if m :: 'Weight(anything, anything)' then m := op(2,m) end if;
  if has(m, '{infinity, Lebesgue, int, Int, Beta, GAMMA}') then
    return false;
  end if;
  for n in `if`(m :: 'specfunc(Msum)', m, [m]) do
    if n :: 'Weight(anything, anything)' then n := op(2,n) end if;
    if has(subsindets(n, 'specfunc(Weight(anything, anything), Msum)',
                      s -> `if`(Testzero(`+`(op(map2(op, 1, s))) - 1),
                                map2(op, 2, s), s)),
           '{Msum, Weight}') then
      return false;
    end if;
  end do;
  return true;
end proc;

# Load a file in concrete Hakaru syntax (using the "momiji" command)
# and return its term (in which Sum and Product are inert) and type.
Concrete := proc(path::string, $)
  local cmd, res, dangerous_chars;
  cmd := FileTools:-AbsolutePath(path,
    (FileTools:-ParentDirectory@@2)(LibraryTools:-FindLibrary(Hakaru)));
  dangerous_chars := [ " ", "'", """", `if`(kernelopts(platform)="windows", [], ["\\"])[] ];
  if ormap((c->StringTools:-Has(cmd,c)), dangerous_chars) then
    error "Dangerous characters in path: %1", cmd;
  end if;
  cmd := cat("momiji ", cmd);
  res := ssystem(cmd);
  if res :: [0, string] then
    parse(cat("use Hakaru in ", op(2,res), " end use"));
  else
    error "ssystem %1: %2", cmd, res;
  end if;
end proc;


 func $selecti32 (
  var %i i32,
   var %j i32,
   var %k i32) i32 {
   return (
     select i32 (
      dread i32 %i,
      dread i32 %j,
      dread i32 %k))}

 func $selecti64 (
  var %i i32,
   var %j i64,
   var %k i64) i64 {
   return (
     select i64 (
      dread i32 %i,
      dread i64 %j,
      dread i64 %k))}

 func $selectf32 (
  var %i i32,
   var %j f32,
   var %k f32) f32 {
   return (
     select f32 (
      dread i32 %i,
      dread f32 %j,
      dread f32 %k))}

 func $selectf64 (
  var %i i32,
   var %j f64,
   var %k f64) f64 {
   return (
     select f64 (
      dread i32 %i,
      dread f64 %j,
      dread f64 %k))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# Extract a domain from an expression
export Extract := module ()
  uses Domain_Type, Utilities;
  export ModuleApply := proc(e, kb, $) :: [ HDomain, anything, list(`=`) ];
    local b, eb, s, es, kb1, rn, ws;
    b, eb, ws := op(Bound(e));
    kb1, rn := Domain:-Bound:-toKB(b)[];
    b, eb, ws := subs(rn,[b,eb,ws])[];
    s, es := op(Shape(eb, kb1));
    [ DOMAIN(b, s), es, ws ];
  end proc;

  # Extract a domain bound from an expression
  # This pops off the integration constructors recursively, keeping
  # track of the bounds in a KB (which literally become the DBound).
  export Bound := module ()
    export ModuleApply := proc(e, $) :: [ DomBound, anything, list(`=`) ];
      local arg, vars, kb, ws, w0;
      arg, vars, ws := do_extract(e)[];
      vars := Domain:-Bound:-withVarsIxs(DBound(vars));
      ws := map(`*`@op,ws);
      w0 := op(1,ws); ws := subsop(1=NULL,ws);
      if not(nops(ws)=nops(op(1,vars))) then
        error "number of outer weights doesn't match number of vars: %1, %2",
              op(1,vars), ws;
      end if;
      [ vars , w0*arg, zip(`=`,map2(op,1,op(1,vars)),ws) ];
    end proc;

    local do_extract_arg := proc(kind, arg_)
      local x0, x, vars, ws,
            arg := op(1,arg_),
            rest := op(2..-1,arg_),
            rng;
      x0  := ExtBound[kind]:-ExtractVar(rest);   # variable name
      rng := ExtBound[kind]:-ExtractRange(rest); # variable range
      x   := DInto(x0, rng, kind);               # the variable spec
      arg, vars, ws := do_extract(arg)[];
      [ arg, [ op(vars), x ], [ op(ws), [] ]];
    end proc;

    local do_extract := proc(arg, $)
      local sub, prod, svars, vs, ssum, ws, wc;
      if arg :: `*` then
        sub := map(do_extract, [op(arg)]);
        prod, svars := selectremove(x->op(2,x)=[],sub);
        if nops(svars) = 1 then
          [   op([1,1],svars)
            , op([1,2],svars)
            , applyop(w-> [op(w),op(map2(op,1,prod))], -1,
                      op([1,3],svars)) ];
        else
          [ arg, [], [[]] ];
        end if;
      elif arg :: `+` then
        sub := map(do_extract, [op(arg)]);
        svars := map2(op,2,sub);
        if the(map(nops,svars)) then
          vs[0] := map(sv->map2(op,1,sv), svars);      # a list of lists of variables
          vs[1] := map2(op,1, op(1,svars));            # a list of 'fresh' variables
          vs[2] := map(v->zip(`=`,v,vs[1]), vs[0]);    # variable renamings
          svars := zip(subs,vs[2], svars);             # dombounds renamed
          if the(svars) then
            ssum := zip(subs,vs[2],map2(op,1,sub));    # sub-arg summands
            ws   := zip(subs,vs[2],map2(op,3,sub));    # sub-arg weights
            # factor out common weight
            ws   := map(x->{op(map(op,x))}, ws);
            wc   := `intersect`(op(ws));
            ws   := [op(map(w -> w minus wc, ws))];
            ws   := map(`[]`@op, ws);
            wc   := [op(wc)];
            # non-common weights are pushed down
            ssum := zip(((s,w)->`*`(s,op(w))), ssum, ws);
            [ `+`(op(ssum)),
              op(1, svars),
              [ wc$(nops(op(1,svars))), [] ] ];
          else
            [ arg, [], [[]] ]
          end if;
        else
          [ arg, [], [[]] ]
        end if;
      elif Domain:-Has:-Bound(arg) then
        do_extract_arg(op(0,arg), [op(arg)]);
      else
        [ arg, [], [[]] ]
      end if;
    end proc;
  end module;

  # Extract a domain shape from an expression
  # This extracts the domain shape from individual multiplicands of
  # expressions, and multiplies the subexpressions back together.
  # essentially this assumes a distributive law (of domain shapes over
  # products)
  export Shape := module ()
    export ModuleApply := proc(e, kb:=KB:-empty) :: [ anything, anything ];
      local ixs, w, e1;
      ixs := [indices(ExtShape, 'nolist')];
      w, e1 := do_gets(ixs, true, e, kb) [];
      if not ('no_simpl' in {_rest}) then
        w := simpl_shape(w);
      end if;
      [ w, e1 ];
    end proc;

    local do_get := proc(f, f_ty, e, kb, $)
      local sub, inds, rest;
      if e::`*` then
        sub := map(x->do_get(f, f_ty,x,kb), [op(e)]);
        [ `And`(op(map2(op,1,sub))), `*`(op(map2(op,2,sub))) ]
      elif e::`^` then
        inds, rest := do_get(f, f_ty, op(1,e), kb) [] ;
        [ inds, subsop(1=rest, e) ]
      elif e:: f_ty then
        f(e,((z,kb1)->ModuleApply(z,kb1,'no_simpl')),kb)
      else
        [ true, e ]
      end if
    end proc;

    # apply a list of extractors, in order, until all fail to produce
    # any output .
    local do_gets := proc(todo::list, w, e, kb, $)
      local t0, ts, w1, e1;
      if nops(todo) = 0 then
        [ w, e ]
      else
        t0 := op(1, todo);
        ts := op(subsop(1=NULL, todo));
        w1, e1 := do_get(ExtShape[t0]:-MakeCtx
                         ,ExtShape[t0]:-MapleType
                         ,e,kb) [] ;
        ts := `if`(is(w1), [ts], [ts, t0]);
        do_gets( ts, bool_And(w1, w), e1, kb );
      end if;
    end proc;

    # todo: simplify the shape
    local simpl_shape := proc(e0,$)
      local e := simpl_relation(e0);
      e := subsindets(e, specfunc(`Or`) , x->DSum(op(x)));
      e := subsindets(e, specfunc(`And`), x->DConstrain(op(x)));
      e;
    end proc;
  end module;
end module;


var $p <* i32>
func $Foo (var %i i32) void {
 iassign <* i32>(
    dread a64 $p,
    add i32(
     iread i32 <* i32> ( dread a64 $p ),
     dread i32 %i))
  return()
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


redundant_DIntos := module()
  export ModuleApply := proc(vs :: DomBound, sh :: DomShape, $)
    # This 'simplification' removes redundant information, but it is
    # entirely pointless as the result should be the same anyways. This
    # is mainly here as an assertion that Apply properly
    # re-applies integrals when the domain shape does not explicitly
    # state them.
    subsindets( sh, DomInto
              , proc (x, $)
                  local x_vn, x_t0, x_rest, x_t, x_mk;
                  x_vn, x_t0, x_rest := op(x);
                  x_t, x_mk := Domain:-Bound:-get(vs, x_vn);
                  if x_t = x_t0 then
                      x_rest
                  else
                      x
                  end if;
                end proc );
  end proc;

  export SimplName  := "Obviously redundant 'DInto's";
  export SimplOrder := 2;
end module;

empty_DIntos := module()
  uses Domain;

  export ModuleApply := proc(vs,sh,$)
    subsindets(sh, satisfies(is_empty), _->DSum());
  end proc;

  local is_empty := proc(e,$)
    evalb(e = DSum()) or (evalb(op(0,e) = DInto) and is_empty(op(3,e)));
  end proc;

  export SimplName  := "Empty DIntos";
  export SimplOrder := 15;
end module;


######################################################################
#
# General circle operad framework.

`check_semi_circ_args` := proc(i,m,n,U,V,is_el_CC)
 global reason;

 if not (type(i,posint) and
         type(m,nonnegint) and
	 type(n,nonnegint) and
	 i <= m) then
  reason := [convert(procname,string),
   "numbers (i,m,n) do not satisfy 0 < i <= m; 0 <= n",i,m,n];
  return false;
 fi;

 if not is_el_CC(m)(U) then
  reason := [convert(procname,string),"U is not in C(m)",eval(U),m];
  return false;
 fi;

 if not is_el_CC(n)(U) then
  reason := [convert(procname,string),"V is not in C(n)",eval(V),n];
  return false;
 fi;

 return true;
end;

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

`check_semi_circ_axiom_nested` :=
 proc(i,j,l,m,n,U,V,W,is_el_CC,is_equal_CC,circ_CC)
 local UV,VW,UVW0,UVW1;
 global reason;

 if not (type(i,posint) and
         type(j,posint) and
	 type(l,nonnegint) and
	 type(m,nonnegint) and
	 type(n,nonnegint) and
	 i <= l and
	 j <= m) then
  reason := [convert(procname,string),
   "numbers (i,j,l,m,n) do not satisfy 0 < i <= l; 0 < j <= m; 0 <= n",
   i,j,l,m,n];
  return false;
 fi;

 if not is_el_CC(l)(U) then
  reason := [convert(procname,string),"U is not in O(l)",l,eval(U)];
  return false;
 fi;

 if not is_el_CC(m)(V) then
  reason := [convert(procname,string),"V is not in O(m)",m,eval(V)];
  return false;
 fi;

 if not is_el_CC(n)(W) then
  reason := [convert(procname,string),"W is not in O(n)",n,eval(W)];
  return false;
 fi;

 UV := circ_CC(i,l,m)(U,V);

 if not is_el_CC(l+m-1)(UV) then
  reason := [convert(procname,string),"U o_i V is not in O(l+m-1)",i,l,m,eval(U),eval(V),eval(UV)];
  return false;
 fi;

 VW := circ_CC(j,m,n)(V,W);

 if not is_el_CC(m+n-1)(VW) then
  reason := [convert(procname,string),"V o_j W is not in O(m+n-1)",j,m,n,eval(VW)];
  return false;
 fi;

 UVW0 := circ_CC(i,l,m+n-1)(U,VW);

 if not is_el_CC(l+m+n-2)(UVW0) then
  reason := [convert(procname,string),"U o_i (V o_j W) is not in O(l+m+n-2)",i,j,l,m,n,eval(UVW0)];
  return false;
 fi;

 UVW1 := circ_CC(i+j-1,l+m-1,n)(UV,W);

 if not is_el_CC(l+m+n-2)(UVW1) then
  reason := [convert(procname,string),"(U o_i V) o_(i+j-1) W is not in O(l+m+n-2)",i,j,l,m,n,eval(UVW1)];
  return false;
 fi;

 if not is_equal_CC(l+m+n-2)(UVW0,UVW1) then
  reason := [convert(procname,string),"UVW0 != UVW1",eval(UVW0),eval(UVW1)];
  return false;
 fi;

 return true;
end;

`check_semi_circ_axiom_disjoint` :=
 proc(i,k,l,m,n,U,V,W,is_el_CC,is_equal_CC,circ_CC)
 local UV,UW,UVW,UWV;
 global reason;

 if not (type(i,posint) and
         type(k,posint) and
	 type(l,nonnegint) and
	 type(m,nonnegint) and
	 type(n,nonnegint) and
	 i < k and
	 k <= l) then
  reason := [convert(procname,string),
   "numbers (i,k,l,m,n) do not satisfy 0 < i < k <= l; 0 < j <= m; 0 <= n",
   i,k,l,m,n];
  return false;
 fi;

 if not is_el_CC(l)(U) then
  reason := [convert(procname,string),"U is not in O(l)",l,eval(U)];
  return false;
 fi;

 if not is_el_CC(m)(V) then
  reason := [convert(procname,string),"V is not in O(m)",m,eval(V)];
  return false;
 fi;

 if not is_el_CC(n)(W) then
  reason := [convert(procname,string),"W is not in O(n)",n,eval(W)];
  return false;
 fi;

 UV := circ_CC(i,l,m)(U,V);

 if not is_el_CC(l+m-1)(UV) then
  reason := [convert(procname,string),"U o_i V is not in O(l+m-1)",i,l,m,eval(U),eval(V),eval(UV)];
  return false;
 fi;

 UW := circ_CC(k,l,n)(U,W);

 if not is_el_CC(l+n-1)(UW) then
  reason := [convert(procname,string),"U o_k W is not in O(l+n-1)",k,l,n,eval(UW)];
  return false;
 fi;

 UVW := circ_CC(k+m-1,l+m-1,n)(UV,W);

 if not is_el_CC(l+m+n-2)(UVW) then
  reason := [convert(procname,string),"(U o_i V) o_(k+m-1) W is not in O(l+m+n-2)",i,k,l,m,n,eval(UVW)];
  return false;
 fi;

 UWV := circ_CC(i,l+n-1,m)(UW,V);

 if not is_el_CC(l+m+n-2)(UWV) then
  reason := [convert(procname,string),"(U o_k W) o_i V is not in O(l+m+n-2)",i,k,l,m,n,eval(UWV)];
  return false;
 fi;

 if not is_equal_CC(l+m+n-2)(UVW,UWV) then
  reason := [convert(procname,string),"UVW != UWV",eval(UVW),eval(UWV)];
  return false;
 fi;

 return true;
end;


standard_colour_list :=
 map(u -> ColorTools[Color](u /~ 255.),[
  [255,  0,  0], [229,122,  0], [ 76,115,  0], [ 64,255, 89],
  [ 38,145,153], [  0, 41,153], [213,128,255], [230,115,161],
  [ 89,  0,  0], [ 89, 58, 22], [204,197,102], [ 51,102, 58],
  [  0,204,255], [115,130,230], [ 96, 57,115], [242,  0, 65],
  [191, 67, 48], [178,137, 89], [255,238,  0], [ 45,179, 98],
  [  0, 68,128], [ 36,  0, 89], [204,  0,163], [127, 64, 72],
  [255,162,128], [102, 82,  0], [195,255,128], [128,255,246],
  [ 77,117,153], [136,  0,204], [102,  0, 54]
 ]):

standard_colour := proc(i)
 local n;
 n := nops(standard_colour_list);
 standard_colour_list[modp(i-1,n)+1];
end: