Simplify the logic of Domain:-Extract somewhat

# Extract a domain from an expression
export Extract := module ()
    export ModuleApply := proc(e, kb, $) :: [ HDomain, anything ];
        local b, eb, s, es;
        b, eb := op(Bound(e));
        s, es := op(Shape(eb, kb ));
        [ DOMAIN(b, s), es ];
    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 ];
            local arg, vars, kb;
            arg, vars := do_extract(e)[];
            vars := Domain:-Bound:-withVarsIxs(DBound(vars));
            [ vars , arg ];
        end proc;

        local do_extract_arg := proc(kind, arg_)
            local x0, x, vars, arg := 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 := do_extract(arg)[];
            [ arg, [ op(vars), x ] ];
        end proc;

        local do_extract := proc(arg, $)
            local sub, prod, svars;
            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(map2(op,1,prod)))
                    , op([1,2], svars) ];
                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) :: [ anything, anything ];
            local ixs, w, e1;
            ixs := [indices(ExtShape, 'nolist')];
            w, e1 := do_gets(ixs, true, e) [];
            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, $)
            local sub, inds, rest;
            if e::`*` then
              sub := map(x->do_get(f, f_ty,x), [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)) [] ;
              [ inds, subsop(1=rest, e) ]
            elif e:: f_ty then
              f(e)
            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, $)
            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) [] ;
                ts := `if`(is(w1), [ts], [ts, t0]);
                do_gets( ts, bool_And(w1, w), e1 );
            end if;
        end proc;

        # todo: simplify the shape
        local simpl_shape := proc(e0,$)
            local e := Domain:-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;

# Extract a domain from an expression
export Extract := module ()
    export ModuleApply := proc(e, kb, $) :: [ HDomain, anything ];
        local b, eb, s, es;
        b, eb := op(Bound(e));
        s, es := op(Shape(eb, kb ));
        [ DOMAIN(b, s), es ];
    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 ];
            local arg, vars, kb;
            arg, vars := do_extract(e)[];
            vars := Domain:-Bound:-withVarsIxs(DBound(vars));
            [ vars , arg ];
        end proc;

        local do_extract_arg := proc(kind, arg_)
            local x0, x, vars, arg := 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 := do_extract(arg)[];
            [ arg, [ op(vars), x ] ];
        end proc;

        local do_extract := proc(arg, $)
            local sub, prod, svars;
            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(map2(op,1,prod)))
                    , op([1,2], svars) ];
                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) :: [ anything, anything ];
            local ixs, w, e1;
            ixs := [indices(ExtShape, 'nolist')];
            w, e1 := do_gets(ixs, true, e) [];
            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, $)
            local sub, inds, rest;
            if e::`*` then
              sub := map(x->do_get(f, f_ty,x), [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)) [] ;
              [ inds, subsop(1=rest, e) ]
            elif e:: f_ty then
              f(e)
            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, $)
            local t0, ts, w1, e1;
            if nops(todo) = 0 then
                [ w, e ]
            else
                t0 := op(1, todo);
                ts := op(subsop(1=NULL, todo));
                if indets(e, specfunc(t0)) <> {} then
                    w1, e1 :=
                      do_get(ExtShape[t0]:-MakeCtx
                            ,ExtShape[t0]:-MapleType
                            ,e) [] ;
                    ts := `if`(is(w1), [ts], [ts, t0]);
                    do_gets( ts, And(w1, w), e1 );
                else
                    do_gets( [ ts ], w, e );
                end if;
            end if;
        end proc;

        # todo: simplify the shape
        local simpl_shape := proc(e0,$)
            local e := Domain:-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;


Change appliable to procedure; and handle more types of variables

export Improve := module ()
    export Simplifiers := table();
    export ModuleApply := proc(dom :: HDomain, $)::HDomain_mb;
        local es := map(si->Simplifiers[si]
                       , 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);
      ASSERT(lib_path<>NULL);
      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 := simp0(bnd, sh); simp0:-SimplName;
      if not sh1 :: DomNoSol then
          simp1(bnd, sh1);
      else
          combine_errs( sh1, simp1(bnd, sh) );
      end if;
    end proc;

    export classify_relation := proc(r0::relation, vars0, $)
      ::{identical(FAIL), [identical(B_LO,B_HI,B_EQ,B_NEQ), satisfies(q->q in {indices(flip_relation,nolist)}), name, algebraic]};
      local r_k, r_s, in_vars, vars := vars0, r := r0;
      if vars :: ({set,list})({name,list(name)}) then
        vars := map(x->`if`(x::list,op(1,x),x),vars);
        vars := {op(vars)}; in_vars := x->x in vars;
      elif vars :: DomBound then
        vars := DomBound:-Bound:-varsOf(vars,"set"); in_vars := x->x in vars;
      elif vars :: procedure then
        in_vars := vars;
      elif vars :: type then
        in_vars := x->type(x,vars);
      else error "unknown argument: %1 (expecting variables, variable membership check, "
                 "or domain bounds)", vars;
      end if;

      if r :: {`<=`,`<`, `=`, `<>`} then
        if in_vars(rhs(r)) then
          r_k := flip_relation[op(0,r)]; r_s := rhs(r), lhs(r);
        elif in_vars(lhs(r)) then
          r_k := op(0,r); r_s := op(r);
        else return FAIL end if;
        [ classify_relop[r_k], r_k, r_s ];
      else FAIL
      end if;
    end proc;
    local flip_relation := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);
    local classify_relop := table([`=`=B_EQ,`<>`=B_NEQ,`<=`=B_HI,`<`=B_HI,`>=`=B_LO,`>`=B_LO]);
end module;

export Improve := module ()
    export Simplifiers := table();
    export ModuleApply := proc(dom :: HDomain, $)::HDomain_mb;
        local es := map(si->Simplifiers[si]
                       , 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);
      ASSERT(lib_path<>NULL);
      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 := simp0(bnd, sh); simp0:-SimplName;
      if not sh1 :: DomNoSol then
          simp1(bnd, sh1);
      else
          combine_errs( sh1, simp1(bnd, sh) );
      end if;
    end proc;

    export classify_relation := proc(r0::relation, vars0, $)
      ::{identical(FAIL), [identical(B_LO,B_HI,B_EQ,B_NEQ), satisfies(q->q in {indices(flip_relation,nolist)}), name, algebraic]};
      local r_k, r_s, in_vars, vars := vars0, r := r0;
      if vars :: ({set,list})(name) then
        vars := {op(vars)}; in_vars := x->x in vars;
      elif vars :: DomBound then
        vars := DomBound:-Bound:-varsOf(vars,"set"); in_vars := x->x in vars;
      elif vars :: appliable then
        in_vars := vars;
      elif vars :: type then
        in_vars := x->type(x,vars);
      else error "unknown argument: %1 (expecting variables, variable membership check, "
                 "or domain bounds)", vars;
      end if;

      if r :: {`<=`,`<`, `=`, `<>`} then
        if in_vars(rhs(r)) then
          r_k := flip_relation[op(0,r)]; r_s := rhs(r), lhs(r);
        elif in_vars(lhs(r)) then
          r_k := op(0,r); r_s := op(r);
        else return FAIL end if;
        [ classify_relop[r_k], r_k, r_s ];
      else FAIL
      end if;
    end proc;
    local flip_relation := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);
    local classify_relop := table([`=`=B_EQ,`<>`=B_NEQ,`<=`=B_HI,`<`=B_HI,`>=`=B_LO,`>`=B_LO]);
end module;