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

`check_gamma_args` := proc(A,B,p,U,V,is_el_CC)
 local F,b;
 global reason;

 if not type(A,set) then
  reason := [convert(procname,string),"A is not a set",A];
  return false;
 fi;
 if not type(B,set) then
  reason := [convert(procname,string),"B is not a set",B];
  return false;
 fi;

 if not `is_element/maps`(A,B)(p) then
  reason := [convert(procname,string),"not a map from A to B",A,B,reason];
  return false;
 fi;

 F := fibres(A,B)(p);

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

 if not type(V,table) then
  reason := [convert(procname,string),"V is not a table",eval(V)];
  return false;
 fi;

 if map(op,{indices(V)}) <> B then
  reason := [convert(procname,string),"V is not indexed by B",eval(V),B];
  return false;
 fi;

 for b in B do
  if not is_el_CC(F[b])(V[b]) then
   reason := [convert(procname,string),"V[b] is not in C(F[b])",b,eval(V[b]),eval(F[b])];
   return false;
  fi;
 od;

 return true;
end;

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

`check_gamma_axiom` := proc(A,B,C,p,q,U,V,W,is_el_CC,is_equal_CC,gamma_CC)
# local a,b,c,qp,Fp,Fq,Fqp,UV,VW,UVW0,UVW1,W0,p0;
# global reason,check_gamma_axiom_args;
 local a,b,c,qp,Fp,Fq,Fqp,UV,VW,W0,p0;
 global UVW0,UVW1,reason,check_gamma_axiom_args;

 check_gamma_axiom_args := [args];

 if not type(A,set) then
  reason := [convert(procname,string),"A is not a set",eval(A)];
  return false;
 fi;
 if not type(B,set) then
  reason := [convert(procname,string),"B is not a set",eval(B)];
  return false;
 fi;
 if not type(C,set) then
  reason := [convert(procname,string),"C is not a set",eval(C)];
  return false;
 fi;

 if not `is_element/maps`(A,B)(p) then
  reason := [convert(procname,string),"p is not a map from A to B",eval(p),A,B,reason];
  return false;
 fi;

 if not `is_element/maps`(B,C)(q) then
  reason := [convert(procname,string),"q is not a map from B to C",eval(q),B,C,reason];
  return false;
 fi;

 qp := `compose/maps`(A,B,C)(p,q);

 Fp := fibres(A,B)(p);
 Fq := fibres(B,C)(q);
 Fqp := fibres(A,C)(qp);

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

 if not type(V,table) then
  reason := [convert(procname,string),"V is not a table",eval(V)];
  return false;
 fi;

 if map(op,{indices(V)}) <> C then
  reason := [convert(procname,string),"V is not indexed by C",eval(V),C];
  return false;
 fi;

 for c in C do
  if not is_el_CC(Fq[c])(V[c]) then
   reason := [convert(procname,string),"V[c] is not in O(Fq[c])",c,eval(V[c]),eval(Fq[c])];
   return false;
  fi;
 od;

 if not type(W,table) then
  reason := [convert(procname,string),"W is not a table",eval(W)];
  return false;
 fi;

 if map(op,{indices(W)}) <> B then
  reason := [convert(procname,string),"W is not indexed by B",eval(W),B];
  return false;
 fi;

 for b in B do
  if not is_el_CC(Fp[b])(W[b]) then
   reason := [convert(procname,string),"W[b] is not in O(Fp[b])",b,eval(W[b]),eval(Fp[b])];
   return false;
  fi;
 od;

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

 if not `check_gamma_args`(A,B,p,UV,W,is_el_CC) then
  reason := [convert(procname,string),"invalid arguments to gamma 1",reason];
  return false;
 fi;

 UVW0 := gamma_CC(A,B)(p)(UV,W);
 if not is_el_CC(A)(UVW0) then
  reason := [convert(procname,string),"UVW0 is not in C(A)",eval(UVW0),A];
  return false;
 fi;

 VW := table();
 for c in C do
  W0 := table();
  p0 := table();
  for b in Fq[c] do W0[b] := W[b]; od;
  for a in Fqp[c] do p0[a] := p[a]; od;
  if not `check_gamma_args`(Fqp[c],Fq[c],p0,V[c],W0,is_el_CC) then
   reason := [convert(procname,string),"invalid arguments to gamma 2",reason];
   return false;
  fi;
  VW[c] := gamma_CC(Fqp[c],Fq[c])(p0)(V[c],W0);
 od;

 if not `check_gamma_args`(A,C,qp,U,VW,is_el_CC) then
  reason := [convert(procname,string),"invalid arguments to gamma 3",reason];
  return false;
 fi;

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

 if not is_equal_CC(A)(UVW0,UVW1) then
  reason := [convert(procname,string),"UVW0 != UVW1",eval(UVW0),eval(UVW1)];
  return false;
 fi;

 return true;
end;

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

check_operad_morphism_axiom :=
 proc(A,B,p,U,V,
      is_el_CC,is_equal_CC,gamma_CC,
      is_el_DD,is_equal_DD,gamma_DD,
      phi)

 local b,Fp,UV,U1,V1,UV1,UV2;

 global reason,check_operad_morphism_axiom_args;

 check_operad_morphism_axiom_args := [args];

 if not type(A,set) then
  reason := [convert(procname,string),"A is not a set",eval(A)];
  return false;
 fi;

 if not type(B,set) then
  reason := [convert(procname,string),"B is not a set",eval(B)];
  return false;
 fi;

 if not `is_element/maps`(A,B)(p) then
  reason := [convert(procname,string),"p is not a map from A to B",eval(p),A,B,reason];
  return false;
 fi;

 Fp := fibres(A,B)(p);

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

 if not type(V,table) then
  reason := [convert(procname,string),"V is not a table",eval(V)];
  return false;
 fi;

 if map(op,{indices(V)}) <> B then
  reason := [convert(procname,string),"V is not indexed by B",eval(V),B];
  return false;
 fi;

 for b in B do
  if not is_el_CC(Fp[b])(V[b]) then
   reason := [convert(procname,string),"V[b] is not in C(Fp[b])",b,eval(V[b]),eval(Fp[b])];
   return false;
  fi;
 od;

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

 U1 := phi(B)(U);
 if not is_el_DD(B)(U1) then
  reason := [convert(procname,string),"phi(U) is not in D(B)",eval(U1),B];
  return false;
 fi;

 V1 := table();
 for b in B do
  V1[b] := phi(Fp[b])(V[b]);
  if not is_el_DD(Fp[b])(V1[b]) then
   reason := [convert(procname,string),"phi(V[b]) is not in D(Fp[b])",eval(V1),b,eval(Fp[b])];
   return false;
  fi;
 od;

 UV1 := gamma_DD(A,B)(p)(U1,V1);
 if not is_el_DD(A)(UV1) then
  reason := [convert(procname,string),"UV1 is not in D(A)",eval(UV1),A];
  return false;
 fi;

 UV2 := phi(A)(UV);
 if not is_el_DD(A)(UV1) then
  reason := [convert(procname,string),"phi(UV) is not in D(A)",eval(UV2),A];
  return false;
 fi;

 if not(is_equal_DD(A)(UV1,UV2)) then
  reason := [convert(procname,string),"UV1 != UV2",eval(UV1),eval(UV2)];
  return false;
 fi;

 return true;
end:

check_operad_morphism_axiom_globalise := proc()
 global check_operad_morphism_axiom_args,
         A,B,p,U,V,
         is_el_CC,is_equal_CC,gamma_CC,
         is_el_DD,is_equal_DD,gamma_DD,
         phi;
 local ARGS;
 ARGS := check_operad_morphism_axiom_args;

 A               := eval(ARGS[ 1]);
 B		 := eval(ARGS[ 2]);
 p		 := eval(ARGS[ 3]);
 U		 := eval(ARGS[ 4]);
 V		 := eval(ARGS[ 5]);
 is_el_CC	 := eval(ARGS[ 6]);
 is_equal_CC	 := eval(ARGS[ 7]);
 gamma_CC	 := eval(ARGS[ 8]);
 is_el_DD	 := eval(ARGS[ 9]);
 is_equal_DD	 := eval(ARGS[10]);
 gamma_DD	 := eval(ARGS[11]);
 phi 		 := eval(ARGS[12]);
 NULL;
end:

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

# An operad E consists of sets E(A) for each finite set A, functorial
# for bijections of A.  We have formulated the definitions in such a
# way that this functoriality is determined by the rest of the
# structure.  The code here implements this.

`action/operad` := (gen_name,eta,gamma) -> (A::set,B::set) -> (f) -> proc(x)
 local f_inv,e,a;

 f_inv := table();
 e := table();
 for a in A do
  f_inv[f[a]] := a;
  e[a] := eta({f[a]});
 od;
 return gamma(B,A)(f_inv)(x,e);
end;

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

extend_gamma_linear := (g0) -> (A::set,B::set) -> (p) -> proc(y,x)
 local c,y1,F,BL,M,b,t,z,m,mt,u,i;

 if y = 0 then
  return 0;
 elif type(y,`+`) then
  return map(t -> extend_gamma_linear(g0)(A,B)(p)(t,x),y);
 fi;

 if type(y,`*`) then
  c,y1 := selectremove(type,y,integer);
 else
  c := 1;
  y1 := y;
 fi;

 F := fibres(A,B)(p);

 BL := sort([op(B)]);
 M := [[1]];
 for b in BL do
  t := map(coeff_split,sum_terms(x[b]));
  M := [seq(seq([m[1] * u[1],seq(m[i],i=2..nops(m)),u[2]],u in t),m in M)];
 od:

 z := 0;

 for m in M do
  mt := table([seq(BL[i]=m[i+1],i=1..nops(BL))]);
  z := z + c * m[1] * g0(A,B)(p)(y1,mt);
 od;

 return z;

end;


var $i i32 align(4) = 987
type $SS1 <struct {
  @f1 i32 volatile const,
  @f2 i32 align(8),
  @f3 i32 const } >
var $iconst1 <[4] [4] i32> const = [ [1007, 707, -273, 75], [0113, 0x4b, 75u, 75l], [75ul, 75lu, 31425926, 60223], [60223, 1619, 30, 314159]]
var $fconst1 <[4] [4] f64 > volatile = [ [1007.0, 707.0, -273.0, 75.0], [113.1, 4.0, 75.0, 75.1], [75.0, 75.1, 3.1425926, 6.02e23], [6.02e+23, 1.6e-19, 3.0, 3.14159]]
func &printf const static varargs (var %p1 <* i8 > volatile const, var %p2 <* i32> volatile)void
func &noarg varargs ( ... ) void
func $main static ( ) i32 {
   var %jj i32 volatile align(16)
   call &printf (addrof a32 $fconst1)
   return (constval i32 0) }

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


# Convert Domain to a KB. Very partial, mainly for backwards compatibility
# for parts of the code which still work with KB.
export Bound := module ()
    export toKB := proc(dom :: DomBound, kb0 :: t_kb, $)::[t_kb_mb, list(name=name)];
        local kb := kb0, vs := op(1, dom), rn := []
            , vn, vt, make, lo, hi, vn_rn, rn_t, v ;
        for v in vs do
            vn, vt, make := op(v);
            lo, hi := ExtBound[make]:-SplitRange(vt);
            vn_rn, kb := ExtBound[make]:-MakeKB( vn, lo, hi, kb );
            rn := [ vn=vn_rn, op(rn) ];
        end do;
        [ kb, rn ]
    end proc;

    export varsOf := proc(dom :: DomBound, output::identical("list","set","seq"):="list")
      local v := map(x->op(1,x), op(1, dom));
      op(table(["list"=[v],"set"=[{op(v)}],"seq"=v])[output]);
    end proc;

    export withVarsIxs := proc(dom :: DomBound, $) :: DomBound;
        DBound( op(1..2,dom), table([ seq(op([1,i,1],dom)=i,i=1..nops(op(1,dom))) ]) );
    end proc;

    export varIx := proc(dom0::DomBound, v::DomBoundVar, $)::nonnegint;
      local i := varIx_mb(dom0,v);
      if i = -1 then
        error "cannot find var %1 in %2", v, dom0;
      else i end if;
    end proc;

    export varIx_mb := proc(dom0::DomBound, v::DomBoundVar, $)::{nonnegint,identical(-1)};
      local dom := `if`(nops(dom0)>=3, (_->_), withVarsIxs)(dom0);
      if assigned(op(3,dom)[v]) then
        op(3,dom)[v]
      else
        -1
      end if;
    end proc;

    export isEmpty := proc(dom :: DomBound, $)::truefalse;
        evalb(nops(op(1,dom))=0);
    end proc;

    export get := proc(dom :: DomBound, var :: DomBoundVar, $)
        local th;
        th := select(x->op(1,x)=var, op(1,dom));
        if nops(th) = 1 then
            op([1,2], th), op([1,3], th)
        elif nops(th) = 0 then
            error "cannot find var %1 in %2", var, dom;
        else
            error "multiple references in %1", dom;
        end if;
    end proc;

    export upd := proc(dom0 :: DomBound, vr :: DomBoundVar, ty :: DomBoundRange, $)
        local dom := `if`(nops(dom0)>=3, (_->_), withVarsIxs)(dom0), i
            , old_lo,old_hi, lo,hi, old_ty, new_ty, _, vr_k;
        i := varIx(dom, vr);

        _, old_ty, vr_k := op(op([1,i], dom));
        old_lo,old_hi := Domain:-ExtBound[vr_k]:-SplitRange(old_ty);
        lo, hi        := Domain:-ExtBound[vr_k]:-SplitRange(ty);

        if lo :: realcons then
          lo := Domain:-ExtBound[vr_k]:-Max(old_lo, lo);
        end if;
        if hi :: realcons then
          hi := Domain:-ExtBound[vr_k]:-Min(old_hi, hi);
        end if;

        new_ty := Domain:-ExtBound[vr_k]:-MakeRange(lo,hi);

        subsop([1,i,2]=new_ty, dom);
    end proc;

    local constrain := proc( opts, vn::DomBoundVar, ty::DomBoundRange, mk :: DomBoundKind, $ )
                    :: set({relation, `::`});
        local lo, hi, noi, bt
            , noinf := evalb('no_infinity' in opts)
            , btys  := evalb('bound_types' in opts);
        lo,hi := Domain:-ExtBound[mk]:-SplitRange(ty);
        bt  := `if`(btys, { vn :: Domain:-ExtBound[mk]:-BoundType }, {});
        bt := { Domain:-ExtBound[mk]:-Constrain( lo, vn )
        , Domain:-ExtBound[mk]:-Constrain( vn, hi )
        , bt[]};
        `if`(noinf,x->remove(c->c::relation and ormap(s->s(c)::identical(infinity,-infinity),[lhs,rhs]), x),_->_)
            (bt);
    end proc;

    local toConstraints_opts := { 'no_infinity', 'bound_types' };
    export toConstraints := proc( bnd :: DomBound )
        local cs, opts, bad_opts, noinf;
        opts := { args[2..-1] } ;
        bad_opts := opts minus toConstraints_opts;
        if bad_opts <> {} then
            error "invalid arguments: %1", bad_opts;
        end if;
        {op(map(b->constrain(opts, op(b))[], op(1,bnd)))
        ,op( `if`(nops(bnd)>1,op(2,bnd),{}) ) };
    end proc;
end module;#Bound


N:=kernelopts(numcpus):
x:=Array(1..N):
fun:=proc()
    uses Grid;
    global x;
    local node,i,id,v;
    node:=MyNode();
    if node<>0 then
        Send(0,node,node^2);
    else
        for i from 1 to NumNodes()-1 do
            id,v:=Receive();
            x[id+1]:=v;
        end do;
        x[1]:=0;
    end if;
    return NULL;
end proc:
Grid:-Launch(fun,imports=["x"],exports=["x"]);
print(convert(x,list));


interface(screenwidth=9999):
if not (NewSLO :: `module`) then
  WARNING("loading NewSLO failed");
  `quit`(3);
end if;

with(Hakaru):
with(NewSLO):

#####################################################################
#
# Dirichlet conjugacy tests
#
#####################################################################

(dice_index, dice_index_t) := Concrete("examples/dice_index.hk"):
dice_index := value(eval(dice_index)):

# BUG: naming the var `lda' with a lowercase causes "Error: recursive
# assignment", but *not* inside Concrete (in the evaluation of the resulting
# expression!). `lda' doesn't seem to be a special name.
(LDA, LDA_t) := Concrete("examples/lda2.hk"):
LDA := value(eval(LDA)):

(gmm_gibbs, gmm_gibbs_t) := Concrete("examples/gmm_gibbs.hk"):
gmm_gibbs := value(eval(gmm_gibbs)):

(naive_bayes_gibbs, naive_bayes_gibbs_t) := Concrete("examples/naive_bayes_gibbs.hk"):
naive_bayes_gibbs := value(eval(naive_bayes_gibbs)):

#####################################################################
TestEfficient( dice_index, dice_index_t, KB:-empty, label="dice index" ):
TestEfficient( LDA, LDA_t, KB:-empty, label="LDA" ):
TestEfficient( gmm_gibbs, gmm_gibbs_t, KB:-empty, label="gmm gibbs" ):
TestEfficient( naive_bayes_gibbs, naive_bayes_gibbs_t, KB:-empty, label="naive bayes gibbs" ):


var $sconst1 <struct {
        @f11 i32,
        @f22:15 i32,
        @f33 i32,
        @f44 i32,
        @f55 f32,
        @f66 f32}> = [ 6=10.07f, 2=699, 3=-273, 4=75, 1=31425926, 5=6.02e+23f ]
func &printf (var %p1 <* i8>)void
func &main ( ) i32 {
   call &printf (addrof a32 $sconst1)
   return (constval i32 0) }

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


 func $foo (
  var %i i32
#var %i1 i32, var %j1 i32, var %k1 i32
  ) i32 {
   return (
     bnot i32(dread i32 %i))}

 func $foo1 (
  var %i i32, var %j i32, var %k i32,
  var %i1 i32, var %j1 i32, var %k1 i32
  ) i32 {
   return (
     bnot i32(dread i32 %i))}

 func $foo2 (
  var %i i32, var %j i32, var %k i32
  ) i32 {
   return (
     bnot i32(constval i32 0x111111111))}

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

 func $foo5 (
  var %i i64, var %j i64, var %k i32
  ) i64 {
   return (
     bnot i64(constval i64 0x11111))}

# todo float bnot
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl