end of term commit

end of term commit

didn’t do anything this week - I have documented most TO-DOs and
problems. I will leave it as it is for next few weeks (unless you have
questions), until I have time to come back to it and have the energy to
push forward. Every step forward seems to require a bit more
investigation.

% This is not Rubi and Garnet is not as valuable as Ruby... but at least
% both are basically red...

lisp;
on backtrace, echo, comp; % set some useful (I hope) options

% The existing "rubi_red" package provides a way to access all the
% Rubi rules... But in fact I will set up my own short list...

load_package rubi_red;

% fluid '(rubi_rules);

% To start with I will have just ONE rule!

% (a + b*x^n)^p
% where n*(p+1)=-1
% eg let me try n=1, p=-2, so I get
% (a + b*x^1)^(-2)

%rubi_rules := '(

%(!/!;
%   (!:!=
%      (!Int
%         (expt (plus (!_ a) (times (!_!. b) (expt (!_ x) (!_ n)))) (!_ p))
%         (!_ x !Symbol))
%      (quotient (times x (expt (plus a (times b (expt x n))) (plus p 1))) a))
%   (and
%      (!Free!Q (bracelist a b n p) x)
%      (!Zero!Q (plus (times n (plus p 1)) 1))))

%)$

algebraic operator unsimplified_int;

symbolic procedure simpgarnet u;
  begin
    scalar a, x, r;
    if length u neq 2 then rederr "garnet requires two arguments";
    a := car u;
    x := cadr u;
    if posn() neq 0 then terpri();
    princ "Integrate "; prin a; princ " wrt "; print x;
% The arguments arrive here are totally unprocessed, and so for instance
% if you write "w := <something>; var := x; garnet(w, var);" what you
% receive will be "w" and "var" not sensible values. I have special code
% to deal with this!
    a := garnet!-simp a;
    x := garnet!-simp x;
    r := garnet_integrate(a, x);
% I hand back a list of length 2 - the first item is the result that
% garnet generates, the second is what the existing old Reduce integrator
% makes of the example.
    return simp list('list, r, list('int, a, x));
  end;

put('garnet, 'simpfn, 'simpgarnet);

% This takes a formula and "evaluates" it by evaluating all the variables
% present in it while trying to preserve the structure around the, So if you
% hand it (x-1)^10 where x has some messy value it will return the expression
% (<messy-value> - 1)^10 rather than multiplying things out. Just in case
% the varibles used had previously been simplified in a way that expanded
% them this does some factorization to try to return things to a "neat"
% form. If substituting values for variables would introduce cases of
% (expression + 0) or (expression^1) it does some minor tidying up to
% make things seem nicer.

symbolic procedure garnet!-simp u;
  if numberp u then u
  else if atom u then garnet!-simpatom u
  else begin
    scalar w;
    w := for each v in cdr u collect garnet!-simp v;
    if car u = 'plus then return garnet!-simp!-plus w
    else if car u = 'difference then return garnet!-simp!-difference w
    else if car u = 'times then return garnet!-simp!-times w
    else if car u = 'quotient then return garnet!-simp!-quotient w
    else if car u = 'expt then return garnet!-simp!-expt w
    else if car u = 'minus then return garnet!-simp!-minus w
    else return car u . w
  end;

% Following might be redundant - commented out for the moment

%symbolic procedure garnet!-simp!-plus l;
%  begin
%    scalar r;
%    for each x in l do if not zerop x then r := x . r;
%    if null r then return 0
%    else if nuill cdr r then return car r
%    else return 'plus . reverse r
%  end;

% The next few reconstruct prefix forms performing only the very simplest
% transformations such as (x + 0) => x and (x * 1) => x. They may even
% go as far as (2 + 2) => 4, but do not guarantee even that! Note that
% "simplifications" along the lines illustrated here are naive and not
% in general an effective way to tidy things up.

symbolic procedure garnet!-simp!-plus l;
  begin
    scalar r, n;
    n := 0;
    for each x in l do
       if numberp x then n := n + x
       else r := x . r;
% Puts any numeric constant as first item in result version.
    if not zerop n then r := n . reverse r
    else r := reverse r;
% If only one item left return it, otherwise return a sum.
    if null cdr r then return car r
    else return 'plus . r
  end;

symbolic procedure garnet!-simp!-times l;
  begin
    scalar r, n;
    n := 1;
    for each x in l do
       if numberp x then n := n * x
       else r := x . r;
    if zerop n then return 0
    else if not onep n then r := n . reverse r
    else r := reverse r;
    if null cdr r then return car r
    else return 'times . r
  end;

symbolic procedure garnet!-simp!-difference l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if numberp a and numberp b then return a-b
    else if zerop a then return garnet!-simp!-minus list b
    else if zerop b then return a
    else return list('difference, a, b)
  end;

symbolic procedure garnet!-simp!-quotient l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if zerop a then return 0
    else if onep b then return a
    else return list('quotient, a, b)
  end;

% Adding garnet!-simp!-expt l
% Sean-To-do: seems that we cannot just simplify expt component
symbolic procedure garnet!-simp!-expt l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    return list('expt, a, b)
%    if zerop b then return 1
%    else if onep b then return a
%    else if zerop a then return 0
%    else if onep a then return a
%    else return list('expt, a, b)
  end;

symbolic procedure garnet!-simp!-minus l;
  begin
    scalar a;
    a := car l;
    if numberp a then return -a
    else if eqcar(a, 'minus) then return cadr a
    else return list('minus, a)
  end;

symbolic procedure garnet!-simpatom x;
  begin
    scalar w, n, d;
% Start by "simplifying" to get a Standard Quotient
    w := simp x;
% Factorize the polynomials in numerator and denominator;
    n := prepfctr fctrf numr w;
    d := prepfctr fctrf denr w;
    if d = 1 then return n
% WARNING: FOLLOWING IS A HACK
% Simple quotient rewrite rule when numberator is one
    else if onep n then <<
      if eqcar(d, 'expt) and (numberp caddr d) then
        return list('expt, cadr d, -(caddr d));
      >>

    else return list('quotient, n, d)
  end;

% fctrf returns a numerical content on the front of a list of
% factors and multiplicities. If it is (c . (f1 . n1) (f2 . n2)) I will
% return (times c (expt f1 n1) (expt f2 n2)). But can omit bits if any
% multiplicity is 1, or if c=1, or if there is only one factor shown at
% all.

symbolic procedure prepfctr u;
  begin
    scalar r;
    r := for each f in cdr u collect
      if cdr f = 1 then prepf car f
      else list('expt, prepf car f, cdr f);
    if null r then return car u
    else if car u = 1 then <<
      if null cdr r then return car r
      else return 'times . r >>
    else return 'times . car u . r
  end;

% tr garnet!-simpatom;
% tr fctrf, prepfctr;

% going through all the rules one by one for pattern matching

symbolic procedure garnet_integrate(a, x);
  begin
    scalar rules, w;
    rules := rubi_rules;
top:
    if null rules then return list('unsimplified_int, a, x);
% apply_rules returns a non-nil answer if it finds an integral, or nil
% if the rules will not apply.
    if w := apply_rule(car rules, a, x) then
       return garnet_check_inside w;
    rules := cdr rules;
    go to top;
  end;

global '(trace_counter);
trace_counter := 0;

% The high-level pattern matcher, match a rule against an expression
% calls trymatch to create bindings
% returns nil if fail to match
%
symbolic procedure apply_rule(rule, a, x);
  begin
    scalar lhs, rhs, conditions, w, bindings, condition;
    if (trace_counter := trace_counter+1) < 5 then <<
        %Sean-To-do: look up posn()
        %Arthur: posn() tells you the current output column, so this
        % forces a new line unless you are already at the start of a line.
       if posn() neq 0 then terpri();
       prin trace_counter; princ ": ";
       princ "looking at "; prin a; princ " wrt "; print x;
       princ "Try rule "; prettyprint rule; terpri() >>;
    if not eqcar(rule, '!/!;) then <<
       % printc "Expecting /; at top of rule, rule is: "; % print rule;
       return nil >>;
    w := cadr rule;
    conditions := caddr rule;
    if not eqcar(w, '!:!=) then <<
       printc "Expecting := at top of rewrite";
       return nil >>;
    lhs := cadr w;
    rhs := caddr w;
% trymatch will return either a list of bindings or the special symbol
% 'fail to indicate that matching was not possible.
    bindings := trymatch(list('!Int, a, x), lhs, nil);

    if bindings = 'fail then return nil;

    % TO-DO: verify if binding is valid
    terpri(); princ "Bindings = "; print bindings;

    % WARNING: FOLLOWING IS A HACK THAT ONLY CHECK BINDING FOR X ONCE
    % There must be a better way of checking if binding occurs twice
    % and if bindings are coherent

    if assoc('x, bindings) and assoc('x, cdr bindings) and
      not (assoc('x, bindings) = assoc('x, cdr bindings)) then return nil;

    princ "Rule is: "; print rule;
    if eqcar(rhs, '!Module) or eqcar(rhs, '!Dist) then return nil;

    % following is a little test for check_fraction_q
    % condition := '(!Fraction!Q (bracelist n p));
    % single_condition_pass(subla(bindings, condition), rhs);

% Here I need to check conditions
% Sean: do subla before checking conditions??
% Sean: doing subla on conditions before checking conditions
% I see no incidence of using the original conditions

    if conditions_pass(subla(bindings, conditions), subla(bindings, rhs))
      then return subla(bindings, rhs) % redundant call to subla
    else return nil;
  end;

% ===================== Conditions Section ======================
symbolic procedure conditions_pass(c, r);
  begin
    scalar first_cond, second_cond;
    if eqcar(c, 'and) then <<
%      printc "AND: checking if both conditions are true";

      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>
      else return nil;
      >>
    else if eqcar(c, 'or) then <<
%      printc "OR: checking if one of the two conditions are true";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then return t
      else  <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>;
      >>
    else if eqcar(c, '!Not) then <<
%      printc "NOT: reverse logic";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else return not first_cond;
      >>
    else <<
      first_cond := single_condition_pass(c, r);
      if first_cond = 'fail then return nil
      else if first_cond then return t
      else <<
        princ "Condition failed: "; print c;
        return nil;
        >>
      >>
  end;

%*****************List of Conditions*************
% Ones without a * are not implemented
% Listed in the order of appearance
% After some inspection, some conditions seem not captured here
% TO-DO: find out why

% *!Free!Q
% *!Fraction!Q
% *lessp -> most imporant one, needs a lot more testing
% *!Positive!Q
% *!Pos!Q
% *!Neg!Q
% !Not - this is bizarre, as it shouldn't appear
% *!Zero!Q
% *greaterp
% *!Nonzero!Q
% !Rational!Q -> incorrectly implemented, see notes later
% *!Integer!Q
% *!Integers!Q
% *leq
% !Match!Q
% *equal
% *!Negative!Q
% *geq
% nil
% !Polynomial!Q
% !Negative!Coefficient!Q
% !Linear!Q
% !If
% *neq
% !Algebraic!Function!Q
% *!Even!Q
% *!Odd!Q
% !Function!Of!Hyperbolic!Q
% !Function!Of!Q
% !Nonsum!Q
% !Try!Pure!Tanh!Subst
% !Independent!Q
% !Half!Integer!Q
% !Inverse!Function!Free!Q
% !False!Q
% !Coprime!Q
% !Expand!Integrand!Q
% !One!Q
% !Recognized!Function!Of!Trig!Q
% !Member!Q
% !Try!Pure!Tan!Subst

%****************************************************

symbolic procedure single_condition_pass(c, r);
  begin
% Passing (cdr c) for now to preserve structural integrity for various cases
% TO-DO: reorder according to the number of occurence
% TO-DO: remove the parenthesis around (cdr c) if necessary
    if eqcar(c, '!Free!Q) then return check_free_q(cdr c, r)
    else if eqcar(c, '!Zero!Q) then return check_zero_q(cdr c)
    else if eqcar(c, '!Nonzero!Q) then return check_non_zero_q(cdr c)
    else if eqcar(c, 'equal) then return check_equal(cdr c)
    else if eqcar(c, 'neq) then return check_not_equal(cdr c)
    else if eqcar(c, '!Odd!Q) then return check_odd_q(cdr c)
    else if eqcar(c, '!Even!Q) then return check_even_q(cdr c)
    else if eqcar(c, '!Positive!Q) then return check_positive_q(cdr c)
    else if eqcar(c, '!Negative!Q) then return check_negative_q(cdr c)
    else if eqcar(c, '!Pos!Q) then return check_pos_q(cdr c)
    else if eqcar(c, '!Neg!Q) then return check_neg_q(cdr c)
    else if eqcar(c, 'lessp) then return check_lessp(cdr c)
    else if eqcar(c, '!greaterp) then return check_greaterp(cdr c)
    else if eqcar(c, 'leq) then return check_less_equal(cdr c)
    else if eqcar(c, 'geq) then return check_greater_equal(cdr c)
    else if eqcar(c, 'nil) then return check_nil(cdr c)
    else if eqcar(c, '!Independent!Q) then return check_independent_q(cdr c, r)
    else if eqcar(c, '!Match!Q) then return check_match_q(cdr c)
    else if eqcar(c, '!Integer!Q) then return check_integer_q(cdr c)
    else if eqcar(c, '!Integers!Q) then return check_integers_q(cdr c)
    else if eqcar(c, '!Rational!Q) then return check_rational_q(cdr c)
    else if eqcar(c, '!Fraction!Q) then return check_fraction_q(cdr c)
    else if eqcar(c, '!Polynomial!Q) then return check_polynomial_q(cdr c)
    else if eqcar(c, '!Linear!Q) then return check_linear_q(cdr c)
    else if eqcar(c, '!Function!Of!Q) then return check_function_of_q(cdr c)

    else if eqcar(c, '!Fraction!Or!Negative!Q) then
      return check_fraction_or_negative_q(cdr c)

    else if eqcar(c, '!Negative!Coefficient!Q) then
      return check_negative_coefficient_q(cdr c)

    else if eqcar(c, '!Algebraic!Function!Q) then
      return check_algebraic_function_q(cdr c)

    else if eqcar(c, '!Function!Of!Hyperbolic!Q) then
      return check_function_of_hyperbolic_q(cdr c)

    else if eqcar(c, '!Inverse!Function!Free!Q) then
      return check_inverse_function_free_q(cdr c)

    else if eqcar(c, '!Recognized!Function!Of!Trig!Q) then
      return check_recognized_function_of_trig_q(cdr c)

    else <<
      princ "Condition not recognised, need to add to current list: ";
      print c;
      return 'fail;
      >>;
    return nil;
  end;

% To-do: test it thoroughly - most frequent condition
% c: condition, in the form of ((bracelist a b c ...) x) or (a x)
% r: right hand side
symbolic procedure check_free_q(c, r);
  begin
    mark_constants(r, car cdr c);
    if eqcar(car c, 'bracelist) then
      return check_free_q_list cdr car c
    else return print gethash(car c, garnet_hash);
  end;

symbolic procedure check_free_q_list l;
  if null l then t
  else if gethash(car l, garnet_hash) then check_free_q_list cdr l
  else nil;

% tr check_free_q_list, check_free_q;

symbolic procedure check_zero_q(c);
  zerop reval(car c);

symbolic procedure check_non_zero_q(c);
  not check_zero_q(c);

% still a little puzzled by different equality test
symbolic procedure check_equal(c);
  reval car c = reval cadr c;

symbolic procedure check_not_equal(c);
  not check_equal(c);

symbolic procedure check_odd_q(c);
  oddp reval car c;

symbolic procedure check_even_q(c);
  evenp reval car c;

symbolic procedure check_positive_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_negative_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_pos_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_neg_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_lessp(c);
  lessp_quotient(car c, cadr c);

% The (perculiar) behavior of reval:
% w := '(quotient 1 -2);
% reval w; => (quotient (minus 1) 2)
% reval cadr w; => 1;
% reval cadr reval w; => -1;

% lessp than compares quotient as well
% To-do: might not work well with irrational and complex numbers
symbolic procedure lessp_quotient(l, r);
  begin
    l := reval l;
    r := reval r;
    if numberp l and numberp r then return l < r
    else if eqcar(l, 'quotient) and numberp r then <<
      if zerop r then return eqcar(cadr l, 'minus)
      else if r > 0 then <<
        if eqcar(cadr l, 'minus) then return t % neg fraction < positive int
        else return lessp_quotient(list('times, cadr l, r), caddr l);
        >>
      else <<
        if eqcar(cadr l, 'minus) then % make both positive
          return lessp_quotient(list('minus, r), list('minus, l))
        else return nil;
        >>;
      >>
    else if numberp l and eqcar(r, 'quotient) then
      return not lessp_quotient(r, l)
    else if eqcar(l, 'quotient) and eqcar(r, 'quotient) then <<
% This part needs a bit more scrutinisation:
% we assume if we found a number at numerator, then the quotient
% is positive
      if eqcar(cadr l, 'minus) and eqcar(cadr r, 'minus) then
        return lessp_quotient(list('minus, r), list('minus, l))
      else if eqcar(cadr l, 'minus) and numberp cadr r then return t
      else if numberp cadr l and eqcar(cadr r, 'minus) then return nil
      else if numberp cadr l and numberp cadr r then
        return lessp_quotient(list('times,cadr l, caddr r),
          list('times, cadr r, caddr l))
      else
        rederr "Error comparing two quotients";
      >>
    % Sean: not really sure the best error-handling practice here
    else rederr "lessp_quotient cannot recognise the format";
  end;

symbolic procedure check_greaterp(c);
  not check_lessp(c);

symbolic procedure check_less_equal(c);
  check_equal(c) and check_lessp(c);

symbolic procedure check_greater_equal(c);
  check_equal(c) and not check_lessp(c);

symbolic procedure check_nil(c);
  'fail;

% Two cases for !Independent!Q, one followed by !Cancel, the other is not
% !Cancel not implemented
symbolic procedure check_independent_q(c, r);
  if not eqcar(car c, 'Cancel) then check_free_q(c, r);

symbolic procedure check_match_q(c);
  'fail;

symbolic procedure check_integer_q(c);
  fixp reval car c;

symbolic procedure check_integers_q(c);
  if null c then t
  else if check_integer_q(c) then check_integers_q(cdr c)
  else nil;

symbolic procedure check_rational_q(c);
  if eqcar(c, 'bracelist) then check_rational_q_list (cdr car c)
  else check_rational_q_atom (car c);

symbolic procedure check_rational_q_list l;
  if null l then t
  else if check_rational_q_atom car l then check_rational_q_list cdr l
  else nil;

% WARNING: THIS ONE WILL FAIL!!
% It is implemented incorrectly so as to move on with testing
% If we do a reval PI, it gives back a quotient of two integers,
% thus making it a rational number as well. BUT WE KNOW IT IS NOT.
% We need to in some way evaluate c (the expression) first, because
% the goal is to see if any irrational terms cancels out, since many test
% begin with (!Rationa!Q (!Rt ...) ..).
symbolic procedure check_rational_q_atom c;
  if fixp reval c then t
  else if eqcar(reval c, 'quotient) then fixp cadr c and fixp caddr c
  else nil;

reval pi;

symbolic procedure check_fraction_q(c);
% !Fraction!Q can be either called on a single atom or a bracelist
% for eg. (!Fraction!Q n) and (!Fraction!Q (bracelist n p))
  if eqcar(c, 'bracelist) then check_fraction_q_list (cdr car c)
  else check_fraction_q_atom (car c);

symbolic procedure check_fraction_q_atom c;
% do a reval to force 'quotient to come to car of the list
% seems generally work but can't guarantee
  if atom reval c then nil
  else car reval c = 'quotient;

symbolic procedure check_fraction_q_list l;
  begin
    if null l then return t
    else if check_fraction_q_atom (car l) then <<
      l := cdr l;
      return check_fraction_q_list l;
      >>
    else return nil;
  end;

% tr check_fraction_q, check_fraction_q_atom, check_fraction_q_list;

symbolic procedure check_polynomial_q(c);
  'fail;
symbolic procedure check_linear_q(c);
  'fail;
symbolic procedure check_function_of_q(c);
  'fail;
symbolic procedure check_fraction_or_negative_q(c);
  'fail;
symbolic procedure check_negative_coefficient_q(c);
  'fail;
symbolic procedure check_algebraic_function_q(c);
  'fail;
symbolic procedure check_function_of_hyperbolic_q(c);
  'fail;
symbolic procedure check_inverse_function_free_q(c);
  'fail;
symbolic procedure check_recognized_function_of_trig_q(c);
  'fail;

% ===================== Conditions Section End ======================

% the low-level recursive pattern matcher that generates bindings
% returns binding if succeed, 'fail otherwise
% bindings in the following format:
% (( rule_variable_name . expression_variable_name) (...) ...)

% TO-DO: seems there might be double binding, meaning if we do
% garnet((1+z)^(-1/12), z), x is bind to both z and (1+z)
% thus we get 12*z^(11/12)/11 as a result, instead of
% 12*(1+z)^(11/12)/11.

symbolic procedure trymatch(u, pattern, env);
  begin
%    princ "u = "; print u;
%    princ "pattern = "; print pattern;
%    princ "env = "; print env;
% Sean-To-do: what happens when there is '!_ or '!_!.??
    if eqcar(pattern, '!_) then
       return (cadr pattern . u) . env
    else if eqcar(pattern, '!_!.) then
       return (cadr pattern . u) . env
    else if u = pattern then return env
    else if atom pattern or atom u then return 'fail
    else if not (car u = car pattern) then return 'fail
    else return trymatchlist(cdr u, cdr pattern, env)
  end;

symbolic procedure trymatchlist(lu, lpattern, env);
  if null lu and null lpattern then env
  else if null lu or null lpattern then 'fail
  else begin
    scalar w;
    w := trymatch(car lu, car lpattern, env);

    % If using original expression fails to match, try rewriting our
    % expression to match the the pattern
    if w = 'fail then <<
      if eqcar(car lpattern, 'expt) then <<
        w := trymatch_expt(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'times) then <<
        w := trymatch_times(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'plus) then <<
        w := trymatch_plus(lu, lpattern, env);
        >>
      else return 'fail;
      >>;
    if w = 'fail then return 'fail
    else return trymatchlist(cdr lu, cdr lpattern, w);
    end;

%======================Try Match with Options====================

% To-do: not fully implemented yet
% To-do: some redundant logic, will fix it when I have a clear mind
% To-do: distinguish between !_ and !_!.

symbolic procedure trymatch_expt(lu, lpattern, env);
% princ "Attempting to add exponent 1.";
    if eqcar(caddr car lpattern, '!_ ) or eqcar(caddr car lpattern, '!_!. ) then
      trymatch(list('expt, car lu, 1), car lpattern, env)
    else 'fail;

symbolic procedure trymatch_times(lu, lpattern, env);
% princ "Attempting to add coefficient/times 1.";
  if eqcar(cadr car lpattern, '!_ ) or eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('times, 1, car lu), car lpattern, env)
  else 'fail;

symbolic procedure trymatch_plus(lu, lpattern, env);
% princ "Attempting to add plus 0.";
  if eqcar(cadr car lpattern, '!_ ) or eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('plus, 0, car lu), car lpattern, env)
  else 'fail;

%======================Try Match with Options End================

% A rule may transform an integral into something where there is an
% integral sign left within what is generated. Scan to spot such cases and
% call garnet again to process that.

symbolic procedure garnet_check_inside u;
  if atom u then u
  else if eqcar(u, 'int) then garnet_integrate(cadr u, caddr u)
  else car u . for each a in cdr u collect garnet_check_inside a;

% A possibly useful function for noting constants. NOT TESTED AT ALL YET.

%Sean-To-do: will try to incorporate this at later stage

fluid '(garnet_hash);
garnet_hash := mkhash(15, 0, 2.0);

symbolic procedure mark_constants(u, x);
  begin
    clrhash garnet_hash;
    mark_constants_1(u, x)
  end;

% The idea is that this will enter data into the hash table for every
% part of the input that is "constant" in u (with respect to x). So complex
% formulae like sin(pi/sqrt(a^2+b^2)) are constant with respect to x, in that
% the given formula has no x in it. However exactly the same formula would not
% be independent of a or b.
% The functio also returns true it its argument u is independent of x,
% This is to implement the InvolvesQ predicate.

symbolic procedure mark_constants_1(u, x);
  if u = x then nil
  else if atom u then << puthash(u, garnet_hash, t); t >>
  else begin
    scalar overall;
    overall := t;
% overall is going to tell if this whole expression seems constant.
    for each s in cdr u do
       if not mark_constants_1(s, x) then overall := nil;
    if overall then puthash(u, garnet_hash, t);
    return overall
  end;

% check by using "gethash(u, garnet_hash)"

% Small test/demo of above

symbolic procedure test_constants(u, x);
  begin
    mark_constants(u, x);
    testconst u
  end;

symbolic procedure testconst u;
  begin
    prin u;
    if posn() > 49 then terpri();
    ttab 50;
    print gethash(u, garnet_hash);
    if atom u then return nil;
    for each s in cdr u do testconst s
  end;

test_constants('(plus (times 2 x)
                 (sin (quotient pi (sqrt (plus (expt a 2) (expt b 2)))))),
               'x);

algebraic;

% I now have some cases - where SOME of them should match the rule that
% I have got.

% tr trymatch, trymatchlist;

% TO-DO: doesn't seem to work with sin z, log etc.

garnet((u + v*z^1)^(-1/3), z); % doesn't work
garnet((u + z^1)^(-2), z);
garnet((u + v*z)^(-2), z);
garnet((u + z)^(-2), z);

% Now the same four but with a level of indirection...
w := (u + v*z^1)^(-1/3); garnet(w, z); % doesn't work either
w := (u + z^1)^(-2); garnet(w, z); % This one in the test
w := (u + v*z)^(-2); garnet(w, z);
w := (u + z)^(-2); garnet(w, z);

end;

% This is not Rubi and Garnet is not as valuable as Ruby... but at least
% both are basically red...

lisp;
on backtrace, echo, comp; % set some useful (I hope) options

% The existing "rubi_red" package provides a way to access all the
% Rubi rules... But in fact I will set up my own short list...

% load_package rubi_red;

fluid '(rubi_rules);

% To start with I will have just ONE rule!

% (a + b*x^n)^p
% where n*(p+1)=-1
% eg let me try n=1, p=-2, so I get
% (a + b*x^1)^(-2)

rubi_rules := '(

(!/!;
   (!:!=
      (!Int
         (expt (plus (!_ a) (times (!_!. b) (expt (!_ x) (!_ n)))) (!_ p))
         (!_ x !Symbol))
      (quotient (times x (expt (plus a (times b (expt x n))) (plus p 1))) a))
   (and
      (!Free!Q (bracelist a b n p) x)
      (!Zero!Q (plus (times n (plus p 1)) 1))))

)$

algebraic operator unsimplified_int;

symbolic procedure simpgarnet u;
  begin
    scalar a, x, r;
    if length u neq 2 then rederr "garnet requires two arguments";
    a := car u;
    x := cadr u;
    if posn() neq 0 then terpri();
    princ "Integrate "; prin a; princ " wrt "; print x;
% The arguments arrive here are totally unprocessed, and so for instance
% if you write "w := <something>; var := x; garnet(w, var);" what you
% receive will be "w" and "var" not sensible values. I have special code
% to deal with this!
    a := garnet!-simp a;
    x := garnet!-simp x;
    r := garnet_integrate(a, x);
% I hand back a list of length 2 - the first item is the result that
% garnet generates, the second is what the existing old Reduce integrator
% makes of the example.
    return simp list('list, r, list('int, a, x));
  end;

put('garnet, 'simpfn, 'simpgarnet);

% This takes a formula and "evaluates" it by evaluating all the variables
% present in it while trying to preserve the structure around the, So if you
% hand it (x-1)^10 where x has some messy value it will return the expression
% (<messy-value> - 1)^10 rather than multiplying things out. Just in case
% the varibles used had previously been simplified in a way that expanded
% them this does some factorization to try to return things to a "neat"
% form. If substituting values for variables would introduce cases of
% (expression + 0) or (expression^1) it does some minor tidying up to
% make things seem nicer.

symbolic procedure garnet!-simp u;
  if numberp u then u
  else if atom u then garnet!-simpatom u
  else begin
    scalar w;
    w := for each v in cdr u collect garnet!-simp v;
    if car u = 'plus then return garnet!-simp!-plus w
    else if car u = 'difference then return garnet!-simp!-difference w
    else if car u = 'times then return garnet!-simp!-times w
    else if car u = 'quotient then return garnet!-simp!-quotient w
    else if car u = 'expt then return garnet!-simp!-expt w
    else if car u = 'minus then return garnet!-simp!-minus w
    else return car u . w
  end;

% Following might be redundant - commented out for the moment

%symbolic procedure garnet!-simp!-plus l;
%  begin
%    scalar r;
%    for each x in l do if not zerop x then r := x . r;
%    if null r then return 0
%    else if nuill cdr r then return car r
%    else return 'plus . reverse r
%  end;

% The next few reconstruct prefix forms performing only the very simplest
% transformations such as (x + 0) => x and (x * 1) => x. They may even
% go as far as (2 + 2) => 4, but do not guarantee even that! Note that
% "simplifications" along the lines illustrated here are naive and not
% in general an effective way to tidy things up.

symbolic procedure garnet!-simp!-plus l;
  begin
    scalar r, n;
    n := 0;
    for each x in l do
       if numberp x then n := n + x
       else r := x . r;
% Puts any numeric constant as first item in result version.
    if not zerop n then r := n . reverse r
    else r := reverse r;
% If only one item left return it, otherwise return a sum.
    if null cdr r then return car r
    else return 'plus . r
  end;

symbolic procedure garnet!-simp!-times l;
  begin
    scalar r, n;
    n := 1;
    for each x in l do
       if numberp x then n := n * x
       else r := x . r;
    if zerop n then return 0
    else if not onep n then r := n . reverse r
    else r := reverse r;
    if null cdr r then return car r
    else return 'times . r
  end;

symbolic procedure garnet!-simp!-difference l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if numberp a and numberp b then return a-b
    else if zerop a then return garnet!-simp!-minus list b
    else if zerop b then return a
    else return list('difference, a, b)
  end;

symbolic procedure garnet!-simp!-quotient l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if zerop a then return 0
    else if onep b then return a
    else return list('quotient, a, b)
  end;

% Adding garnet!-simp!-expt l
% Sean-To-do: seems that we cannot just simplify expt component
symbolic procedure garnet!-simp!-expt l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    return list('expt, a, b)
%    if zerop b then return 1
%    else if onep b then return a
%    else if zerop a then return 0
%    else if onep a then return a
%    else return list('expt, a, b)
  end;

symbolic procedure garnet!-simp!-minus l;
  begin
    scalar a;
    a := car l;
    if numberp a then return -a
    else if eqcar(a, 'minus) then return cadr a
    else return list('minus, a)
  end;

symbolic procedure garnet!-simpatom x;
  begin
    scalar w, n, d;
% Start by "simplifying" to get a Standard Quotient
    w := simp x;
% Factorize the polynomials in numerator and denominator;
    n := prepfctr fctrf numr w;
    d := prepfctr fctrf denr w;
    if d = 1 then return n
% WARNING: FOLLOWING IS A HACK
% Simple quotient rewrite rule when numberator is one
    else if onep n then <<
      if eqcar(d, 'expt) and (numberp caddr d) then
        return list('expt, cadr d, -(caddr d));
      >>

    else return list('quotient, n, d)
  end;

% fctrf returns a numerical content on the front of a list of
% factors and multiplicities. If it is (c . (f1 . n1) (f2 . n2)) I will
% return (times c (expt f1 n1) (expt f2 n2)). But can omit bits if any
% multiplicity is 1, or if c=1, or if there is only one factor shown at
% all.

symbolic procedure prepfctr u;
  begin
    scalar r;
    r := for each f in cdr u collect
      if cdr f = 1 then prepf car f
      else list('expt, prepf car f, cdr f);
    if null r then return car u
    else if car u = 1 then <<
      if null cdr r then return car r
      else return 'times . r >>
    else return 'times . car u . r
  end;

% tr garnet!-simpatom;
% tr fctrf, prepfctr;

% going through all the rules one by one for pattern matching

symbolic procedure garnet_integrate(a, x);
  begin
    scalar rules, w;
    rules := rubi_rules;
top:
    if null rules then return list('unsimplified_int, a, x);
% apply_rules returns a non-nil answer if it finds an integral, or nil
% if the rules will not apply.
    if w := apply_rule(car rules, a, x) then
       return garnet_check_inside w;
    rules := cdr rules;
    go to top;
  end;

global '(trace_counter);
trace_counter := 0;

% The high-level pattern matcher, match a rule against an expression
% calls trymatch to create bindings
% returns nil if fail to match
%
symbolic procedure apply_rule(rule, a, x);
  begin
    scalar lhs, rhs, conditions, w, bindings, condition;
    if (trace_counter := trace_counter+1) < 5 then <<
        %Sean-To-do: look up posn()
        %Arthur: posn() tells you the current output column, so this
        % forces a new line unless you are already at the start of a line.
       if posn() neq 0 then terpri();
       prin trace_counter; princ ": ";
       princ "looking at "; prin a; princ " wrt "; print x;
       princ "Try rule "; prettyprint rule; terpri() >>;
    if not eqcar(rule, '!/!;) then <<
       printc "Expecting /; at top of rule, rule is: "; % print rule;
       return nil >>;
    w := cadr rule;
    conditions := caddr rule;
    if not eqcar(w, '!:!=) then <<
       printc "Expecting := at top of rewrite";
       return nil >>;
    lhs := cadr w;
    rhs := caddr w;
% trymatch will return either a list of bindings or the special symbol
% 'fail to indicate that matching was not possible.
    bindings := trymatch(list('!Int, a, x), lhs, nil);
    princ "Bindings = "; print bindings;
    if bindings = 'fail then return nil;

    % following is a little test for check_fraction_q
    condition := '(!Fraction!Q (bracelist n p));
    single_condition_pass(condition, bindings, rhs);

% Here I need to check conditions
% Sean: do subla before checking conditions??
% Sean: doing subla on conditions before checking conditions
% I see no incidence of using the original conditions

    if conditions_pass(subla(bindings, conditions), subla(bindings, rhs))
      then return subla(bindings, rhs) % redundant call to subla
    else return nil;
  end;

% ===================== Conditions Section ======================
symbolic procedure conditions_pass(c, r);
  begin
    scalar first_cond, second_cond;
    if eqcar(c, 'and) then <<
%      printc "AND: checking if both conditions are true";

      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>
      else return nil;
      >>
    else if eqcar(c, 'or) then <<
%      printc "OR: checking if one of the two conditions are true";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then return t
      else  <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>;
      >>
    else if eqcar(c, '!Not) then <<
%      printc "NOT: reverse logic";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else return not first_cond;
      >>
    else return single_condition_pass(c, r);
  end;

%*****************List of All Conditions*************
% Ones without a * are not implemented
% Listed in the order of appearance

% *!Free!Q
% *!Fraction!Q
% *lessp
% *!Positive!Q
% *!Pos!Q
% *!Neg!Q
% !Not
% *!Zero!Q
% *greaterp
% *!Nonzero!Q
% !Rational!Q
% *!Integer!Q
% *!Integers!Q
% *leq
% !Match!Q
% *equal
% *!Negative!Q
% *geq
% nil
% !Polynomial!Q
% !Negative!Coefficient!Q
% !Linear!Q
% !If
% *neq
% !Algebraic!Function!Q
% *!Even!Q
% *!Odd!Q
% !Function!Of!Hyperbolic!Q
% !Function!Of!Q
% !Nonsum!Q
% !Try!Pure!Tanh!Subst
% !Independent!Q
% !Half!Integer!Q
% !Inverse!Function!Free!Q
% !False!Q
% !Coprime!Q
% !Expand!Integrand!Q
% !One!Q
% !Recognized!Function!Of!Trig!Q
% !Member!Q
% !Try!Pure!Tan!Subst

%****************************************************

symbolic procedure single_condition_pass(c, r);
  begin
% Passing (cdr c) for now to preserve structural integrity for various cases
% TO-DO: reorder according to the number of occurence
    if eqcar(c, '!Free!Q) then return check_free_q(cdr c, r)
    else if eqcar(c, '!Zero!Q) then return check_zero_q(cdr c)
    else if eqcar(c, '!Nonzero!Q) then return check_non_zero_q(cdr c)
    else if eqcar(c, 'equal) then return check_equal(cdr c)
    else if eqcar(c, 'neq) then return check_not_equal(cdr c)
    else if eqcar(c, '!Odd!Q) then return check_odd_q(cdr c)
    else if eqcar(c, '!Even!Q) then return check_even_q(cdr c)
    else if eqcar(c, '!Positive!Q) then return check_positive_q(cdr c)
    else if eqcar(c, '!Negative!Q) then return check_negative_q(cdr c)
    else if eqcar(c, '!Pos!Q) then return check_pos_q(cdr c)
    else if eqcar(c, '!Neg!Q) then return check_neg_q(cdr c)
    else if eqcar(c, 'lessp) then return check_lessp(cdr c)
    else if eqcar(c, '!greaterp) then return check_greaterp(cdr c)
    else if eqcar(c, 'leq) then return check_less_equal(cdr c)
    else if eqcar(c, 'geq) then return check_greater_equal(cdr c)
    else if eqcar(c, 'nil) then return check_nil(cdr c)
    else if eqcar(c, '!Independent!Q) then return check_independent_q(cdr c)
    else if eqcar(c, '!Match!Q) then return check_match_q(cdr c)
    else if eqcar(c, '!Integer!Q) then return check_integer_q(cdr c)
    else if eqcar(c, '!Integers!Q) then return check_integers_q(cdr c)
    else if eqcar(c, '!Rational!Q) then return check_rational_q(cdr c)
    else if eqcar(c, '!Fraction!Q) then return check_fraction_q(cdr c)
    else if eqcar(c, '!Polynomial!Q) then return check_polynomial_q(cdr c)
    else if eqcar(c, '!Linear!Q) then return check_linear_q(cdr c)
    else if eqcar(c, '!Function!Of!Q) then return check_function_of_q(cdr c)

    else if eqcar(c, '!Fraction!Or!Negative!Q) then
      return check_fraction_or_negative_q(cdr c)

    else if eqcar(c, '!Negative!Coefficient!Q) then
      return check_negative_coefficient_q(cdr c)

    else if eqcar(c, '!Algebraic!Function!Q) then
      return check_algebraic_function_q(cdr c)

    else if eqcar(c, '!Function!Of!Hyperbolic!Q) then
      return check_function_of_hyperbolic_q(cdr c)

    else if eqcar(c, '!Inverse!Function!Free!Q) then
      return check_inverse_function_free_q(cdr c)

    else if eqcar(c, '!Recognized!Function!Of!Trig!Q) then
      return check_recognized_function_of_trig_q(cdr c)

    else <<
      princ "Condition not recognised, need to add to current list: ";
      print c;
      return 'fail;
      >>;
    return nil;
  end;

% To-do: test it thoroughly - most frequent condition
% c: condition, in the form of ((bracelist a b c ...) x)
% r: right hand side
symbolic procedure check_free_q(c, r);
  begin
    mark_constants(r, car cdr c);
    for each h in (cdr car c) do
      if not gethash(h, garnet_hash) then go to top_free;
    return t;
top_free:
    return nil;
  end;

symbolic procedure check_zero_q(c);
  zerop reval(car c);

symbolic procedure check_non_zero_q(c);
  not check_zero_q(c);

% still a little puzzled by different equality test
symbolic procedure check_equal(c);
  reval car c = reval cadr c;

symbolic procedure check_not_equal(c);
  not check_equal(c);

symbolic procedure check_odd_q(c);
  oddp reval car c;

symbolic procedure check_even_q(c);
  evenp reval car c;

symbolic procedure check_positive_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_negative_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_pos_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_neg_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_lessp(c);
% need to check if they are rational first - rational_q not yet implemented
% if check_rational_q(car c) and check_rational_q(cadr c) then
  lessp_rubi(car c, cadr c);

% The (perculiar) behavior of reval:
% w := '(quotient 1 -2);
% reval w; => (quotient (minus 1) 2)
% reval cadr w; => 1;
% reval cadr reval w; => -1;

% lessp than compares quotient as well
symbolic procedure lessp_quotient(l, r);
  begin
    l := reval l;
    r := reval r;
    if numberp l and numberp r then return l < r
    else if eqcar(l, 'quotient) and numberp r then <<
      if zerop r then return eqcar(cadr l, 'minus)
      else if r > 0 then <<
        if eqcar(cadr l, 'minus) then return t % neg fraction < positive int
        else return lessp_quotient(list('times, cadr l, r), caddr l);
        >>
      else <<
        if eqcar(cadr l, 'minus) then % make both positive
          return lessp_quotient(list('minus, r), list('minus, l))
        else return nil;
        >>;
      >>
    else if numberp l and eqcar(r, 'quotient) then
      return not lessp_quotient(r, l)
    else if eqcar(l, 'quotient) and eqcar(r, 'quotient) then <<
% This part needs a bit more scrutinisation:
% we assume if we found a number at numerator, then the quotient
% is positive
      if eqcar(cadr l, 'minus) and eqcar(cadr r, 'minus) then
        return lessp_quotient(list('minus, r), list('minus, l))
      else if eqcar(cadr l, 'minus) and numberp cadr r then return t
      else if numberp cadr l and eqcar(cadr r, 'minus) then return nil
      else if numberp cadr l and numberp cadr r then
        return lessp_quotient(list('times,cadr l, caddr r),
          list('times, cadr r, caddr l))
      else rederr "Error comparing two quotients";
      >>
    else rederr "lessp_quotient cannot recognise the format";
  end;

symbolic procedure check_greaterp(c);
  not check_lessp(c);

symbolic procedure check_less_equal(c);
  check_equal(c) and check_lessp(c);

symbolic procedure check_greater_equal(c);
  check_equal(c) and not check_lessp(c);

symbolic procedure check_nil(c);
  'fail;
% Two cases for !Independent!Q, one followed by !Cancel, the other is not
symbolic procedure check_independent_q(c);
  'fail;
symbolic procedure check_match_q(c);
  'fail;

symbolic procedure check_integer_q(c);
  fixp reval car c;

symbolic procedure check_integers_q(c);
  if null c then t
  else <<
    if check_integer_q(car c) then check_integers_q(cdr c)
    else nil;
    >>;

symbolic procedure check_rational_q(c);
  'fail;

symbolic procedure check_fraction_q(c);
% !Fraction!Q can be either called on a single atom or a bracelist
% for eg. (!Fraction!Q n) and (!Fraction!Q (bracelist n p))
  if eqcar(c, 'bracelist) then check_fraction_q_list (cdr car c)
  else check_fraction_q_atom (car c);

symbolic procedure check_fraction_q_atom c;
% do a reval to force 'quotient to come to car of the list
% seems generally work but can't guarantee
  if atom reval c then nil
  else car reval c = 'quotient;

symbolic procedure check_fraction_q_list l;
  begin
    if null l then return t
    else if check_fraction_q_atom (car l) then <<
      l := cdr l;
      return check_fraction_q_list l;
      >>
    else return nil;
  end;

tr check_fraction_q, check_fraction_q_atom, check_fraction_q_list;

symbolic procedure check_polynomial_q(c);
  'fail;
symbolic procedure check_linear_q(c);
  'fail;
symbolic procedure check_function_of_q(c);
  'fail;
symbolic procedure check_fraction_or_negative_q(c);
  'fail;
symbolic procedure check_negative_coefficient_q(c);
  'fail;
symbolic procedure check_algebraic_function_q(c);
  'fail;
symbolic procedure check_function_of_hyperbolic_q(c);
  'fail;
symbolic procedure check_inverse_function_free_q(c);
  'fail;
symbolic procedure check_recognized_function_of_trig_q(c);
  'fail;

% ===================== Conditions Section End ======================

% the low-level recursive pattern matcher that generates bindings
% returns binding if succeed, 'fail otherwise
% bindings in the following format:
% (( rule_variable_name . expression_variable_name) (...) ...)
symbolic procedure trymatch(u, pattern, env);
  begin
%    princ "u = "; print u;
%    princ "pattern = "; print pattern;
%    princ "env = "; print env;
% Sean-To-do: what happens when there is '!_ or '!_!.??
    if eqcar(pattern, '!_) then
       return (cadr pattern . u) . env
    else if eqcar(pattern, '!_!.) then
       return (cadr pattern . u) . env
    else if u = pattern then return env
    else if atom pattern or atom u then return 'fail
    else if not (car u = car pattern) then return 'fail
    else return trymatchlist(cdr u, cdr pattern, env)
  end;

symbolic procedure trymatchlist(lu, lpattern, env);
  if null lu and null lpattern then env
  else if null lu or null lpattern then 'fail
  else begin
    scalar w;
    w := trymatch(car lu, car lpattern, env);

    % If using original expression fails to match, try rewriting our
    % expression to match the the pattern
    if w = 'fail then <<
      if eqcar(car lpattern, 'expt) then <<
        w := trymatch_expt(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'times) then <<
        w := trymatch_times(lu, lpattern, env);
        >>
      else return 'fail;
      >>;
    if w = 'fail then return 'fail
    else return trymatchlist(cdr lu, cdr lpattern, w);
    end;

%======================Try Match with Options====================

% To-do: not fully implemented yet
% To-do: some redundant logic, will fix it when I have a clear mind

symbolic procedure trymatch_expt(lu, lpattern, env);
% princ "Attempting to add exponent 1.";
    if eqcar(caddr car lpattern, '!_ ) then
      trymatch(list('expt, car lu, 1), car lpattern, env)
    else 'fail;

symbolic procedure trymatch_times(lu, lpattern, env);
% princ "Attempting to add coefficient/times 1.";
  if eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('times, 1, car lu), car lpattern, env)
  else 'fail;

%======================Try Match with Options End================

% A rule may transform an integral into something where there is an
% integral sign left within what is generated. Scan to spot such cases and
% call garnet again to process that.

symbolic procedure garnet_check_inside u;
  if atom u then u
  else if eqcar(u, 'int) then garnet_integrate(cadr u, caddr u)
  else car u . for each a in cdr u collect garnet_check_inside a;

% A possibly useful function for noting constants. NOT TESTED AT ALL YET.

%Sean-To-do: will try to incorporate this at later stage

fluid '(garnet_hash);
garnet_hash := mkhash(15, 0, 2.0);

symbolic procedure mark_constants(u, x);
  begin
    clrhash garnet_hash;
    mark_constants_1(u, x)
  end;

% The idea is that this will enter data into the hash table for every
% part of the input that is "constant" in u (with respect to x). So complex
% formulae like sin(pi/sqrt(a^2+b^2)) are constant with respect to x, in that
% the given formula has no x in it. However exactly the same formula would not
% be independent of a or b.
% The functio also returns true it its argument u is independent of x,
% This is to implement the InvolvesQ predicate.

symbolic procedure mark_constants_1(u, x);
  if u = x then nil
  else if atom u then << puthash(u, garnet_hash, t); t >>
  else begin
    scalar overall;
    overall := t;
% overall is going to tell if this whole expression seems constant.
    for each s in cdr u do
       if not mark_constants_1(s, x) then overall := nil;
    if overall then puthash(u, garnet_hash, t);
    return overall
  end;

% check by using "gethash(u, garnet_hash)"

% Small test/demo of above

symbolic procedure test_constants(u, x);
  begin
    mark_constants(u, x);
    testconst u
  end;

symbolic procedure testconst u;
  begin
    prin u;
    if posn() > 49 then terpri();
    ttab 50;
    print gethash(u, garnet_hash);
    if atom u then return nil;
    for each s in cdr u do testconst s
  end;

test_constants('(plus (times 2 x)
                 (sin (quotient pi (sqrt (plus (expt a 2) (expt b 2)))))),
               'x);

algebraic;

% I now have some cases - where SOME of them should match the rule that
% I have got.

% tr trymatch, trymatchlist;

%garnet((u + v*z^(1/2))^(-1/2), z);
%garnet((u + z^1)^(-2), z);
%garnet((u + v*z)^(-2), z);
%garnet((u + z)^(-2), z);

% Now the same four but with a level of indirection...
% w := (u + v*z^1)^(-1/3); garnet(w, z);
%w := (u + z^1)^(-2); garnet(w, z);
%w := (u + v*z)^(-2); garnet(w, z);
%w := (u + z)^(-2); garnet(w, z);

end;


TESTS: Further append tests in series-test.red

Red [
	Title:   "Red case series test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %series-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012, 2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

;; counters
qt-run-tests: 0
qt-run-asserts: 0
qt-run-passes: 0
qt-run-failures: 0
qt-file-tests: 0
qt-file-asserts: 0
qt-file-passes: 0
qt-file-failures: 0

;; group switches
qt-group-name-not-printed: true
qt-group?: false

_qt-init-group: func [] [
  qt-group-name-not-printed: true
  qt-group?: false
  qt-group-name: ""
]

qt-init-run: func [] [
  qt-run-tests: 0
  qt-run-asserts: 0
  qt-run-passes: 0
  qt-run-failures: 0
  _qt-init-group
]

qt-init-file: func [] [
  qt-file-tests: 0
  qt-file-asserts: 0
  qt-file-passes: 0
  qt-file-failures: 0
  _qt-init-group
]

***start-run***: func[
    title [string!]
][
  qt-init-run
  qt-run-name: title
  prin "***Starting*** "
  print title
]

~~~start-file~~~: func [
  title [string!]
][
  qt-init-file
  prin "~~~started test~~~ "
  print title
  qt-file-name: title
  qt-group?: false
]

===start-group===: func [
  title [string!]
][
  qt-group-name: title
  qt-group?: true
]

--test--: func [
  title [string!]
][
  qt-test-name: title
  qt-file-tests: qt-file-tests + 1
]

--assert: func [
  assertion [logic!]
][

  qt-file-asserts: qt-file-asserts + 1

  either assertion [
     qt-file-passes: qt-file-passes + 1
  ][
    qt-file-failures: qt-file-failures + 1
    if qt-group? [
      if qt-group-name-not-printed [
        prin "===group=== "
        print qt-group-name
        qt-group-name-not-printed: false
      ]
    ]
    prin "--test-- "
    prin qt-test-name
    print " FAILED**************"
  ]
]

===end-group===: func [] [
  _qt-init-group
]

qt-print-totals: func [
  tests     [integer!]
  asserts   [integer!]
  passes    [integer!]
  failures  [integer!]
][
  prin  "  Number of Tests Performed:      "
  print tests
  prin  "  Number of Assertions Performed: "
  print asserts
  prin  "  Number of Assertions Passed:    "
  print passes
  prin  "  Number of Assertions Failed:    "
  print failures
  if failures <> 0 [
    print "****************TEST FAILURES****************"
  ]
]

~~~end-file~~~: func [] [
  print ""
  prin "~~~finished test~~~ "
  print qt-file-name
  qt-print-totals qt-file-tests qt-file-asserts qt-file-passes qt-file-failures
  print ""

  ;; update run totals
  qt-run-passes: qt-run-passes + qt-file-passes
  qt-run-asserts: qt-run-asserts + qt-file-asserts
  qt-run-failures: qt-run-failures + qt-file-failures
  qt-run-tests: qt-run-tests + qt-file-tests
]

***end-run***: func [][
  prin "***Finished*** "
  print qt-run-name
  qt-print-totals qt-run-tests
                  qt-run-asserts
                  qt-run-passes
                  qt-run-failures
]

~~~start-file~~~ "series"

===start-group=== "first, second, third, fourth, fifth"

	--test-- "series-fstff-1"
	  sf1-ser:  [1 2 3 4 5]
	--assert 1 = first sf1-ser
	--assert 2 = second sf1-ser
	--assert 3 = third sf1-ser
	--assert 4 = fourth sf1-ser
	--assert 5 = fifth sf1-ser
	--assert 5 = last sf1-ser

	--test-- "series-fstff-2"
	  sf2-ser:  [1 2 3 4 5]
	--assert 2 = first next sf2-ser

	--test-- "series-fstff-3"
	  sf3-ser:  "12345"
	--assert 49 = first sf3-ser
	--assert 53 = last sf3-ser

	--test-- "series-fstff-4"
	  sf4-ser:  [1 2 3 4 5]
	--assert none = fifth next sf4-ser

	--test-- "series-fstff-5"
	  sf5-ser:  "12345"
	--assert 53 = fifth sf5-ser

	--test-- "series-fstff-6"
	  stf6-ser: #{000102}
	;;--assert 0 = first stf6-ser

	--test-- "series-fstff-7"
	;--assert 'a = first [a b c d]

===end-group===

===start-group=== "pick"

  --test-- "series-pick-1"
  --assert none = pick "" 1

  --test-- "series-pick-2"
  --assert none = pick "" 0

  --test-- "series-pick-3"
  --assert none = pick "" 2

  --test-- "series-pick-4"
  --assert 49 = pick "12345" 1

  --test-- "series-pick-5"
  --assert 53 = pick "12345" 5

  --test-- "series-pick-6"
  --assert 1 = pick [1 2 3 4 5] 1

  --test-- "series-pick-7"
  --assert 2 = pick [1 2 3 4 5] 2

  --test-- "series-pick-8"
  --assert 4 = pick [1 2 3 4 5] 4

  --test-- "series-pick-9"
  --assert 5 = pick [1 2 3 4 5] 5

  --test-- "series-pick-10"
  --assert 2 = pick next next next [1 2 3 4 5] -2

  --test-- "series-pick-11"
  --assert 3 = pick next next next [1 2 3 4 5] -1

  --test-- "series-pick-12"
  --assert none = pick next next next [1 2 3 4 5] 0

===end-group===

===start-group=== "select"
  --test-- "series-select-1"
  ;--assert 2 = select [1 2 3 4 5] 1
===end-group===

===start-group=== "next"
  --test-- "series-next-1"
  --assert 2 = first next [1 2 3 4 5]
  --test-- "series-next-2"
  --assert 3 = first next next [1 2 3 4 5]
  --test-- "series-next-3"
  --assert 4 = first next next next [1 2 3 4 5]
  --test-- "series-next-4"
  --assert 5 = first next next next next [1 2 3 4 5]
  --test-- "series-next-5"
  --assert none = first next next next next next [1 2 3 4 5]
  --test-- "series-next-6"
  --assert 50 = first next "12345"
  --test-- "series-next-7"
  --assert 51 = first next next "12345"
  --test-- "series-next-8"
  --assert 52 = first next next next "12345"
  --test-- "series-next-9"
  --assert 53 = first next next next next "12345"
  --test-- "series-next-10"
  --assert none = first next next next next next "12345"
===end-group===

===start-group=== "back"
--test-- "series-back-1"
  --assert 1 = first back next [1 2 3 4 5]
  --test-- "series-back-2"
  --assert 1 = first back back next next [1 2 3 4 5]
  --test-- "series-back-3"
  --assert 1 = first back back back next next next [1 2 3 4 5]
  --test-- "series-back-4"
  --assert 1 = first back back back back next next next next [1 2 3 4 5]
  --test-- "series-back-5"
  --assert 1 = first back back back back back next next next next next [1 2 3 4 5]
  --test-- "series-back-6"
  --assert 49 = first back next "12345"
  --test-- "series-back-7"
  --assert 50 = first back next next "12345"
  --test-- "series-back-8"
  --assert 51 = first back next next next "12345"
  --test-- "series-back-9"
  --assert 52 = first back next next next next "12345"
  --test-- "series-back-10"
  --assert 53 = first back next next next next next "12345"
  --test-- "series-back-11"
  --assert 49 = first back "12345"
===end-group===

===start-group=== "tail"
  --test-- "series-tail-1"
  --assert 5 = first back tail [1 2 3 4 5]
  --test-- "seried-tail-2"
  --assert none = pick tail [1 2 3 4 5] 1
===end-group===

===start-group=== "append"
  --test-- "series-append-1"
  --assert 6 = last append [1 2 3 4 5] 6
  --test-- "series-append-2"
  --assert 6 = last append [1 2 3 4] [5 6]
  --assert 4 = fourth append [1 2 3 4] [5 6]
  --assert 5 = fifth append [1 2 3 4] [5 6]
  --test-- "series-append-3"
  --assert 55 = last append "12345" "67"
  --test-- "series-append-4"
  --assert 233 = last append "abcde" "é" ;; utf-8 C3 A9
  --test-- "series-append-5"
  --assert 49 = last append "abcdeé" "1" ;; utf-8 C3 A9
  --test-- "series-append-6"
  --assert 10000 = last append "abcde" "^(E2)^(9C)^(90)"
  --test-- "series-append-7"
  --assert 48 = last append "abcde^(E2)^(9C)^(90)" "0"
  --test-- "series-append-8"
  --assert 10000 = last append "abcdeé" "^(E2)^(9C)^(90)"
  --test-- "series-append-9"
  --assert 233 = last append "abcde^(E2)^(9C)^(90)" "é"
  --test-- "series-append-10"
  --assert 65536 = last append "abcde" "^(F0)^(90)^(80)^(80)"
  --test-- "series-append-11"
  --assert 48 = last append "abcde^(F0)^(90)^(80)^(80)" "0"
  --test-- "series=append-12"
  --assert 65536 = last append "abcde^(E2)^(9C)^(90)é" "^(F0)^(90)^(80)^(80)"

===end-group===

~~~end-file~~~

Red [
	Title:   "Red case series test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %series-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012, 2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

;; counters
qt-run-tests: 0
qt-run-asserts: 0
qt-run-passes: 0
qt-run-failures: 0
qt-file-tests: 0
qt-file-asserts: 0
qt-file-passes: 0
qt-file-failures: 0

;; group switches
qt-group-name-not-printed: true
qt-group?: false

_qt-init-group: func [] [
  qt-group-name-not-printed: true
  qt-group?: false
  qt-group-name: ""
]

qt-init-run: func [] [
  qt-run-tests: 0
  qt-run-asserts: 0
  qt-run-passes: 0
  qt-run-failures: 0
  _qt-init-group
]

qt-init-file: func [] [
  qt-file-tests: 0
  qt-file-asserts: 0
  qt-file-passes: 0
  qt-file-failures: 0
  _qt-init-group
]

***start-run***: func[
    title [string!]
][
  qt-init-run
  qt-run-name: title
  prin "***Starting*** "
  print title
]

~~~start-file~~~: func [
  title [string!]
][
  qt-init-file
  prin "~~~started test~~~ "
  print title
  qt-file-name: title
  qt-group?: false
]

===start-group===: func [
  title [string!]
][
  qt-group-name: title
  qt-group?: true
]

--test--: func [
  title [string!]
][
  qt-test-name: title
  qt-file-tests: qt-file-tests + 1
]

--assert: func [
  assertion [logic!]
][

  qt-file-asserts: qt-file-asserts + 1

  either assertion [
     qt-file-passes: qt-file-passes + 1
  ][
    qt-file-failures: qt-file-failures + 1
    if qt-group? [
      if qt-group-name-not-printed [
        prin "===group=== "
        print qt-group-name
        qt-group-name-not-printed: false
      ]
    ]
    prin "--test-- "
    prin qt-test-name
    print " FAILED**************"
  ]
]

===end-group===: func [] [
  _qt-init-group
]

qt-print-totals: func [
  tests     [integer!]
  asserts   [integer!]
  passes    [integer!]
  failures  [integer!]
][
  prin  "  Number of Tests Performed:      "
  print tests
  prin  "  Number of Assertions Performed: "
  print asserts
  prin  "  Number of Assertions Passed:    "
  print passes
  prin  "  Number of Assertions Failed:    "
  print failures
  if failures <> 0 [
    print "****************TEST FAILURES****************"
  ]
]

~~~end-file~~~: func [] [
  print ""
  prin "~~~finished test~~~ "
  print qt-file-name
  qt-print-totals qt-file-tests qt-file-asserts qt-file-passes qt-file-failures
  print ""

  ;; update run totals
  qt-run-passes: qt-run-passes + qt-file-passes
  qt-run-asserts: qt-run-asserts + qt-file-asserts
  qt-run-failures: qt-run-failures + qt-file-failures
  qt-run-tests: qt-run-tests + qt-file-tests
]

***end-run***: func [][
  prin "***Finished*** "
  print qt-run-name
  qt-print-totals qt-run-tests
                  qt-run-asserts
                  qt-run-passes
                  qt-run-failures
]

~~~start-file~~~ "series"

===start-group=== "first, second, third, fourth, fifth"

	--test-- "series-fstff-1"
	  sf1-ser:  [1 2 3 4 5]
	--assert 1 = first sf1-ser
	--assert 2 = second sf1-ser
	--assert 3 = third sf1-ser
	--assert 4 = fourth sf1-ser
	--assert 5 = fifth sf1-ser
	--assert 5 = last sf1-ser

	--test-- "series-fstff-2"
	  sf2-ser:  [1 2 3 4 5]
	--assert 2 = first next sf2-ser

	--test-- "series-fstff-3"
	  sf3-ser:  "12345"
	--assert 49 = first sf3-ser
	--assert 53 = last sf3-ser

	--test-- "series-fstff-4"
	  sf4-ser:  [1 2 3 4 5]
	--assert none = fifth next sf4-ser

	--test-- "series-fstff-5"
	  sf5-ser:  "12345"
	--assert 53 = fifth sf5-ser

	--test-- "series-fstff-6"
	  stf6-ser: #{000102}
	;;--assert 0 = first stf6-ser

	--test-- "series-fstff-7"
	;--assert 'a = first [a b c d]

===end-group===

===start-group=== "pick"

  --test-- "series-pick-1"
  --assert none = pick "" 1

  --test-- "series-pick-2"
  --assert none = pick "" 0

  --test-- "series-pick-3"
  --assert none = pick "" 2

  --test-- "series-pick-4"
  --assert 49 = pick "12345" 1

  --test-- "series-pick-5"
  --assert 53 = pick "12345" 5

  --test-- "series-pick-6"
  --assert 1 = pick [1 2 3 4 5] 1

  --test-- "series-pick-7"
  --assert 2 = pick [1 2 3 4 5] 2

  --test-- "series-pick-8"
  --assert 4 = pick [1 2 3 4 5] 4

  --test-- "series-pick-9"
  --assert 5 = pick [1 2 3 4 5] 5

  --test-- "series-pick-10"
  --assert 2 = pick next next next [1 2 3 4 5] -2

  --test-- "series-pick-11"
  --assert 3 = pick next next next [1 2 3 4 5] -1

  --test-- "series-pick-12"
  --assert none = pick next next next [1 2 3 4 5] 0

===end-group===

===start-group=== "select"
  --test-- "series-select-1"
  ;--assert 2 = select [1 2 3 4 5] 1
===end-group===

===start-group=== "next"
  --test-- "series-next-1"
  --assert 2 = first next [1 2 3 4 5]
  --test-- "series-next-2"
  --assert 3 = first next next [1 2 3 4 5]
  --test-- "series-next-3"
  --assert 4 = first next next next [1 2 3 4 5]
  --test-- "series-next-4"
  --assert 5 = first next next next next [1 2 3 4 5]
  --test-- "series-next-5"
  --assert none = first next next next next next [1 2 3 4 5]
  --test-- "series-next-6"
  --assert 50 = first next "12345"
  --test-- "series-next-7"
  --assert 51 = first next next "12345"
  --test-- "series-next-8"
  --assert 52 = first next next next "12345"
  --test-- "series-next-9"
  --assert 53 = first next next next next "12345"
  --test-- "series-next-10"
  --assert none = first next next next next next "12345"
===end-group===

===start-group=== "back"
--test-- "series-back-1"
  --assert 1 = first back next [1 2 3 4 5]
  --test-- "series-back-2"
  --assert 1 = first back back next next [1 2 3 4 5]
  --test-- "series-back-3"
  --assert 1 = first back back back next next next [1 2 3 4 5]
  --test-- "series-back-4"
  --assert 1 = first back back back back next next next next [1 2 3 4 5]
  --test-- "series-back-5"
  --assert 1 = first back back back back back next next next next next [1 2 3 4 5]
  --test-- "series-back-6"
  --assert 49 = first back next "12345"
  --test-- "series-back-7"
  --assert 50 = first back next next "12345"
  --test-- "series-back-8"
  --assert 51 = first back next next next "12345"
  --test-- "series-back-9"
  --assert 52 = first back next next next next "12345"
  --test-- "series-back-10"
  --assert 53 = first back next next next next next "12345"
  --test-- "series-back-11"
  --assert 49 = first back "12345"
===end-group===

===start-group=== "tail"
  --test-- "series-tail-1"
  --assert 5 = first back tail [1 2 3 4 5]
  --test-- "seried-tail-2"
  --assert none = pick tail [1 2 3 4 5] 1
===end-group===

===start-group=== "append"
  --test-- "series-append-1"
  --assert 6 = last append [1 2 3 4 5] 6
  --test-- "series-append-2"
  --assert 6 = last append [1 2 3 4] [5 6]
  --assert 4 = fourth append [1 2 3 4] [5 6]
  --assert 5 = fifth append [1 2 3 4] [5 6]
  --test-- "series-append-3"
  --assert 55 = last append "12345" "67"
  --test-- "series-append-4"
  --assert 233 = last append "abcde" "é" ;; utf-8 C3 A9
  --test-- "series-append-5"
  --assert 49 = last append "abcdeé" "1" ;; utf-8 C3 A9
  --test-- "series-append-6"
  --assert 10000 = last append "abcde" "^(E2)^(9C)^(90)^(0A)"
  --test-- "series-append-7"
  --assert 48 = last append "abcde^(E2)^(9C)^(90)^(0A)" "0"
  --test-- "series-append-8"
  --assert 10000 = last append "abcdeé" "^(E2)^(9C)^(90)^(0A)"
  --test-- "series-append-7"
  --assert 233 = last append "abcde^(E2)^(9C)^(90)^(0A)" "é"

===end-group===

~~~end-file~~~


FIX: function bodies were not copied before rebinding.

Red/System [
	Title:   "Object! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %object.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

object: context [
	verbose: 0

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	extend: func [
		ctx	  [red-context!]
		spec  [red-context!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			unless null? value [
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value ctx
					]
					default [0]
				]
			]
			syms: syms + 1
			vals: vals + 1
		]
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: COPY stuck on missing function's body block"
			halt
		]
		blk: block/clone as red-block! more yes
		copy-cell as red-value! blk s/offset
		blk: as red-block! s/offset

		_context/bind blk ctx yes
		_context/bind blk GET_CTX(fun) no

		more: more + 2
		more/header: TYPE_UNSET			;-- invalidate compiled body
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx: _context/create slots no yes
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx  [red-context!]
			blk  [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				extend ctx GET_CTX(obj2)
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx yes
				interpreter/eval blk
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					value: block/rs-append blk syms
					value/header: TYPE_SET_WORD
					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

	form: func [
		obj		[red-object!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/form"]]

		serialize obj buffer no no no arg part no 0
	]

	mold: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/mold"]]

		string/concatenate-literal buffer "make object! [^/"
		part: serialize obj buffer only? all? flat? arg part - 15 yes indent + 1
		if indent > 0 [part: do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol
			word/ctx: parent/ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new:  make-at new slots
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					default [0]
				]
				value: value + 1
			]
		]

		new
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			null			;compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

Red/System [
	Title:   "Object! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %object.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

object: context [
	verbose: 0

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	extend: func [
		ctx	  [red-context!]
		spec  [red-context!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			unless null? value [
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value ctx
					]
					default [0]
				]
			]
			syms: syms + 1
			vals: vals + 1
		]
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			print-line "*** Error: COPY stuck on missing function's body block"
			halt
		]
		_context/bind as red-block! more ctx yes
		_context/bind as red-block! more GET_CTX(fun) no

		more: more + 2
		more/header: TYPE_UNSET			;-- invalidate compiled body
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx: _context/create slots no yes
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx  [red-context!]
			blk  [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				extend ctx GET_CTX(obj2)
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx yes
				interpreter/eval blk
			]
			default [
				print-line "*** Error: invalid spec value for object construction"
				halt
			]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					value: block/rs-append blk syms
					value/header: TYPE_SET_WORD
					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

	form: func [
		obj		[red-object!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/form"]]

		serialize obj buffer no no no arg part no 0
	]

	mold: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/mold"]]

		string/concatenate-literal buffer "make object! [^/"
		part: serialize obj buffer only? all? flat? arg part - 15 yes indent + 1
		if indent > 0 [part: do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		set?	[logic!]
		return:	[red-value!]
		/local
			word [red-word!]
			ctx  [red-context!]
	][
		word: as red-word! element
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol
			word/ctx: parent/ctx
		]
		either set? [
			_context/set-in word stack/arguments ctx
			stack/arguments
		][
			_context/get-in word ctx
		]
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			print-line "***Error: copy/part is not supported on objects"
			halt
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		new:  make-at new slots
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		if deep? [
			value: dst/offset
			tail:  dst/tail

			while [value < tail][
				switch TYPE_OF(value) [					;@@ replace it with ANY_SERIES?()
					TYPE_BLOCK
					TYPE_PAREN
					TYPE_PATH
					TYPE_SET_PATH
					TYPE_GET_PATH
					TYPE_LIT_PATH
					TYPE_STRING
					TYPE_FILE [
						actions/copy value value null yes null ;-- overwrite the value
					]
					TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					default [0]
				]
				value: value + 1
			]
		]

		new
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			null			;compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


FIX: issue #395 (SWITCH does not match word! values)

Red/System [
	Title:   "Integer! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %integer.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

integer: context [
	verbose: 0

	get*: func [										;-- unboxing integer value from stack
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		assert TYPE_OF(int) = TYPE_INTEGER
		int/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-integer!]
		/local
			left  [red-integer!]
			right [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]

		left: as red-integer! stack/arguments
		right: left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_CHAR
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
		]
		left
	]

	load-in: func [
		value 	[integer!]
		blk	  	[red-block!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/load-in"]]

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

	push: func [
		value	[integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/push"]]

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/make"]]

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				as red-integer! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-integer! spec					;@@ just for making it compilable
			]
		]
	]

	form: func [
		int		   [red-integer!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/form"]]

		formed: form-signed int/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		int		   [red-integer!]
		buffer	   [red-string!]
		only?	   [logic!]
		all?	   [logic!]
		flat?	   [logic!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/mold"]]

		form int buffer arg part
	]

	compare: func [
		value1    [red-integer!]						;-- first operand
		value2    [red-integer!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [logic!]
		/local
			char  [red-char!]
			left  [integer!]
			right [integer!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: left = right]
			COMP_NOT_EQUAL 		[res: left <> right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_INTEGER left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/subtract"]]
		as red-value! do-math OP_SUB
	]

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	datatype/register [
		TYPE_INTEGER
		TYPE_VALUE
		"integer!"
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		:form
		:mold
		null			;get-path
		null			;set-path
		:compare
		;-- Scalar actions --
		null			;absolute
		:add
		:divide
		:multiply
		:negate
		null			;power
		null			;remainder
		null			;round
		:subtract
		null			;even?
		null			;odd?
		;-- Bitwise actions --
		null			;and~
		null			;complement
		null			;or~
		null			;xor~
		;-- Series actions --
		null			;append
		null			;at
		null			;back
		null			;change
		null			;clear
		null			;copy
		null			;find
		null			;head
		null			;head?
		null			;index?
		null			;insert
		null			;length?
		null			;next
		null			;pick
		null			;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		null			;skip
		null			;swap
		null			;tail
		null			;tail?
		null			;take
		null			;trim
		;-- I/O actions --
		null			;create
		null			;close
		null			;delete
		null			;modify
		null			;open
		null			;open?
		null			;query
		null			;read
		null			;rename
		null			;update
		null			;write
	]
]

Red/System [
	Title:   "Integer! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %integer.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

integer: context [
	verbose: 0

	get*: func [										;-- unboxing integer value from stack
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments			;@@ stack/top
		assert TYPE_OF(int) = TYPE_INTEGER
		int/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/top
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

	do-math: func [
		type	  [integer!]
		return:	  [red-integer!]
		/local
			left  [red-integer!]
			right [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]

		left: as red-integer! stack/arguments
		right: left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_CHAR
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
		]

		left/value: switch type [
			OP_ADD [left/value + right/value]
			OP_SUB [left/value - right/value]
			OP_MUL [left/value * right/value]
			OP_DIV [left/value / right/value]
		]
		left
	]

	load-in: func [
		value 	[integer!]
		blk	  	[red-block!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/load-in"]]

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

	push: func [
		value	[integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/push"]]

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/make"]]

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				as red-integer! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-integer! spec					;@@ just for making it compilable
			]
		]
	]

	form: func [
		int		   [red-integer!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/form"]]

		formed: form-signed int/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		int		   [red-integer!]
		buffer	   [red-string!]
		only?	   [logic!]
		all?	   [logic!]
		flat?	   [logic!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/mold"]]

		form int buffer arg part
	]

	compare: func [
		value1    [red-integer!]						;-- first operand
		value2    [red-integer!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [logic!]
		/local
			char  [red-char!]
			left  [integer!]
			right [integer!]
			res	  [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/compare"]]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			default [RETURN_COMPARE_OTHER]
		]
		switch op [
			COMP_EQUAL 			[res: left = right]
			COMP_NOT_EQUAL 		[res: left <> right]
			COMP_STRICT_EQUAL	[res: all [TYPE_OF(value2) = TYPE_INTEGER left = right]]
			COMP_LESSER			[res: left <  right]
			COMP_LESSER_EQUAL	[res: left <= right]
			COMP_GREATER		[res: left >  right]
			COMP_GREATER_EQUAL	[res: left >= right]
		]
		res
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/subtract"]]
		as red-value! do-math OP_SUB
	]

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	datatype/register [
		TYPE_INTEGER
		TYPE_VALUE
		"integer!"
		;-- General actions --
		:make
		null			;random
		null			;reflect
		null			;to
		:form
		:mold
		null			;get-path
		null			;set-path
		:compare
		;-- Scalar actions --
		null			;absolute
		:add
		:divide
		:multiply
		:negate
		null			;power
		null			;remainder
		null			;round
		:subtract
		null			;even?
		null			;odd?
		;-- Bitwise actions --
		null			;and~
		null			;complement
		null			;or~
		null			;xor~
		;-- Series actions --
		null			;append
		null			;at
		null			;back
		null			;change
		null			;clear
		null			;copy
		null			;find
		null			;head
		null			;head?
		null			;index?
		null			;insert
		null			;length?
		null			;next
		null			;pick
		null			;poke
		null			;remove
		null			;reverse
		null			;select
		null			;sort
		null			;skip
		null			;swap
		null			;tail
		null			;tail?
		null			;take
		null			;trim
		;-- I/O actions --
		null			;create
		null			;close
		null			;delete
		null			;modify
		null			;open
		null			;open?
		null			;query
		null			;read
		null			;rename
		null			;update
		null			;write
	]
]