/* ezunits: yet another units package for Maxima
 * This program copyright 2008 by Robert Dodier.
 * I release this program under the terms of the
 * GNU General Public License.
 */

qput (ezunits, "experimental, usable", version);

load ("ezunits.lisp");

infix ("`", 118, 118);
infix ("``", 117, 117);

declare (constvalue, evfun);

constvalue (e) :=
  if mapatom(e)
    then
     (if symbolp(e)
        then (get (e, 'constvalue), if %% # false then %% else e)
        else e)
    else map (constvalue, e);

declare_constvalue (a, x) ::= buildq ([a, x], put (a, x, 'constvalue));

/* Hold off on this display symbol business.
 * :lisp (put '$\` '(#\space #\space) 'dissym)
 */

declare (dimensional, feature);

declare_units (a%, u%) :=
  block (local (a%, u%), 
  if listp(a%)
    then map (lambda ([a1%], local(a1%), declare1_units (a1%, u%)), a%)
    else declare1_units (a%, u%), u%);

declare1_units (a%, u%) :=
  block (local (a%, u%),
  apply ('define_variable, [a%, a%, any_check]),
  put (a%, units_check (a%), value_check),
  put (a%, u%, units),
  if featurep (a%, 'dimensional) = false
    then apply (declare, [a%, 'dimensional]));

declare_qty (a%, q%) :=
  block (local (a%, q%),
  if listp(a%)
    then map (lambda ([a1%], local(a1%), declare1_qty (a1%, q%)), a%)
    else declare1_qty (a%, q%), q%);

/* Maybe we want to work with constvalue in declare1_qty
 * (instead of the indicator qty).
 */
declare1_qty (a%, q%) :=
  block (local (a%, q%),
  if featurep (a%, 'dimensional) = false
    then apply (declare, [a%, 'dimensional]), put (a%, q%, qty));

units_check (zz%) :=
  block (local (zz%),
  buildq ([zz%: zz%], lambda([yy%],
    if units('zz%) # 1 and units(yy%) # 1 and units(yy%) # units('zz%)
    then throw (oops ('zz%, yy%)))));

qty(e%) :=
  block (local (e%),
  if atom(e%) then
    if featurep (e%, 'dimensional) then
      if get (e%, qty) = false then 'qty(e%) else get (e%, qty)
    else e%
  else if unitop_p(e%) then first(e%)
  else if featurep (op(e%), 'dimensional) then 'qty(e%)
  else apply (op(e%), map (qty, args(e%))));

units(e%) :=
  block (local (e%),
  if atom(e%) then 
    if featurep (e%, 'dimensional) then
      if get (e%, units) = false then 'units(e%) else get (e%, units)
    elseif symbolp (e%) and get (e%, 'constvalue) # false
      then units (get (e%, 'constvalue))
      else 1
  else if mapatom (e%) then units (op (e%))  /* mapatom but not atom => subscripted */
  else if unitop_p(e%) then second(e%)
  else if featurep (op(e%), 'dimensional) then units(op(e%))
  else if op(e%) = "^" then units (first (e%)) ^ second (e%)
  else apply (op(e%), map (units, args(e%))));

d(e%) := dimension (units (e%));

matchdeclare
  ([aa%, bb%], true,
    cc%, constantp,
    ccn0%, constantp_not0,
    ccn1%, constantp_not1,
    mm%, mult_expr_nontrivialconstfactorsp,
    nd%, nondimensional,
    pp%, lambda ([e], not atom(e) and op(e) = "+"),
    uu%, unitp,
    xx%, nonconstantp);

simp: false$
tellsimp (uu% `` nd%, convert_units [units(uu%), nd%] (qty(uu%)) ` nd%);
tellsimp (pp% `` nd%, apply ("+", map (buildq ([nd%], lambda ([e], e `` nd%)), args (pp%))));
tellsimpafter (uu%^ccn1%, (qty(uu%)^ccn1%) ` simplify_units (units(uu%)^ccn1%));
tellsimpafter (nd% * uu%, multiply_with_units (nd%, uu%));
tellsimpafter (nd% + uu%, add_with_units (nd%, uu%));

/* The first ` rule here is a work-around for the behavior of the function 
 * automatically generated by tellsimpafter: in a pure simplification 
 * environment (i.e. no evaluation, e.g. expected result in test scripts)
 * the arguments are never simplified if they do not match any rule.
 * That is unlike simplification in general, in which the arguments are
 * simplified even if there is no rule for the operator and the arguments together.
 */
tellsimpafter (aa% ` bb%, ?resimplify (aa%) ` ?resimplify (bb%));

tellsimpafter (aa% ` (xx% + ccn0%), (aa% - ccn0%)`xx%);
tellsimpafter (aa% ` mm%, (constant_factors(mm%) * aa%) ` everything_else(mm%));
tellsimpafter (aa% ` cc%, aa%*cc%);
tellsimpafter (uu% ` nd%, qty (uu%) ` (units (uu%) * nd%));
tellsimpafter (abs (aa% ` bb%), abs (aa%) ` bb%);
tellsimpafter (aa% ` abs (bb%), aa% ` bb%);
simp: true$

unitop_p (e%) := not atom(e%) and atom (op(e%)) and is (nounify (op(e%)) = nounify ("`"));
unitp (e%) :=
  if atom(e%) then featurep (e%, 'dimensional)
  else if unitop_p (e%) then true
  else featurep (op(e%), 'dimensional);

constantp_not1 (x%) := constantp(x%) and x% # 1;
constantp_not0 (x%) := constantp(x%) and x% # 0;
nonconstantp (x%) := not constantp (x%);
mult_exprp (e%) := not atom(e%) and atom (op(e%)) and (nounify (op(e%)) = nounify ("*") or nounify (op(e%)) = nounify ("/"));
mult_expr_nontrivialconstfactorsp (e%) := mult_exprp (e%) and constant_factors (e%) # 1;
nondimensional (e%) := atom(e%) or (op(e%) # "`" and apply ("and", map (nondimensional, args(e%))));
nondimensional_not1 (e%) := e% # 1 and nondimensional (e%);
nondimensional_not0 (e%) := e% # 0 and nondimensional (e%);

add_with_units (x%, u%) :=
  if unitp (u%) then
    x% + u%
  else
    /* identify terms with like units and add them up. */
    block ([r%: [], a%: args(u%)],
    while a% # [] do
      block ([s%: qty(a%[1]), b%: []],
      for i%:2 thru length(a%) do
        if units (a%[i%]) = units (a%[1]) then
          s%: s% + qty (a%[i%])
        else
          b%: cons (a%[i%], b%),
      r%: cons (s%`units(a%[1]), r%),
      a%: b%),
    if length (r%) = 1 then
      x% + r%[1]
    else
      cons (x%, apply ("+", r%)));
      
multiply_with_units(x%, u%) :=
  if unitp (u%) then
    (x%*qty(u%))`units(u%)
  else
    (x%*apply ("*", map (qty, args (u%)))) ` simplify_units (apply ("*", map (units, args (u%))));

matchdeclare (a%, all);
defrule (runits1, 'units (a%), 1);

constant_factors (e%) := block ([L%, eqns%],
    e% : apply1 (e%, runits1),
    L%: listofvars(e%),
    eqns%: map ("=", L%, L%*0+1),
    subst (eqns%, e%));

everything_else(e%) := e%/constant_factors(e%);

simplify_units (e%) := block
  ([L% : listofvars (e%)],
    L% : makelist (x% > 0, x%, L%),
    apply (assume, L%),
    e% : expand (e%, 0, 0),
    apply (forget, L%),
    e%);

/* Compile matchdeclare predicate functions in hopes of greater speed */
compile (constantp_not0, constantp_not1, mult_expr_nontrivialconstfactorsp, nondimensional, unitp, nonconstantp);

/* A small database of elementary unit conversions */

/* Undefined and therefore treated as basic units:
 *
 * m kg s A K mol
 *
 */

conversions_derived_si :
   {

    km = 1000*m,
    cm = m/100,
    mm = m/1000,
    micron = m/1000000,

    g = kg/1000,

    l = m^3/1000,

    Hz = 1/s,           /* hertz:   Frequency            */
    N = kg*m/s^2,       /* newton:  Force                */
    Pa = N/m^2,         /* pascal:  Pressure             */
    J = N*m,            /* joule:   Work, energy         */
    W = J/s,            /* watt:    Power                */
    C = s*A,            /* coulomb: Electric charge      */
    V = J/C,            /* volt:    Electromotive force  */
    F = C^2/J,          /* farad:   Electric capacitance */
    Ohm = J*s/C^2,      /* ohm:     Electric resistance  */
    S = 1/Ohm,          /* siemens: Electric conductance */
    Wb = J/A,           /* weber:   Magnetic flux        */
    T = J/m^2/A,        /* tesla:   Magnetic flux density*/
    H = J/A^2           /* henry:   Inductance           */

   };

conversions_customary_si :
   {

    ft = 3048/10000 * m,
    lbm = kg/(2205/1000),
    min = 60*s,
    Btu = 1055*J,
    R = 5/9*K,
    gallon = (3785/1000)*l

   };
   
conversions_customary_customary :
   {

    in = ft/12,
    yd = 3*ft,
    mi = 5280*ft,
    /* slug = ???, */
    oz = lbm/16,
    /* grain = ???, */
    h = 60*min,
    d = 24*h,
    lbf = lbm*32*ft/s^2,
    acre = 55*88*yd^2,
    psi = lbf/in^2,
    cfm = ft^3/min

   };

known_unit_conversions :
    union
       (conversions_derived_si,
        conversions_customary_si,
        conversions_customary_customary);

declare_unit_conversion ([L]) :=
   (if not every (equationp, L)
        then error ("declare_unit_conversion: all arguments must be equations."),
    setify (ratsimp (L)),
    map (flatten_conversion_equation, %%),
    known_unit_conversions : union (known_unit_conversions, %%),
    done);

flatten_conversion_equation (e%) := block
  ([l% : lhs (e%), r% : rhs (e%)],
    if unitop_p (l%) and unitop_p (r%)
        then qty (l%) * units (l%) = qty (r%) * units (r%)
        else e%);

equationp (e) := not atom (e) and op (e) = "=";

compute_conversion_factor (u1%, u2%) := block ([e%],
  e% : cons (%%a = u1% / u2%, args (known_unit_conversions)),
  block ([logexpand : all], map (lambda ([e], map (log, e)), e%)),
  linsolve (%%, map (lhs, %%)),
  exp (rhs (first (%%))));
  
convert_units [u1%, u2%] := block ([a%],
  a% : compute_conversion_factor (u1%, u2%),
  if constantp (a%)
    then buildq ([a%], lambda ([x], a% * x))
    else buildq ([u1%], lambda ([x], x ` u1%)));

convert_units [degF, degC] : lambda ([x], 5/9*(x - 32));
convert_units [degC, degF] : lambda ([x], 32 + 9/5*x);
convert_units [degC, K] : lambda ([x], 27315/100 + x);
convert_units [degF, R] : lambda ([x], 45967/100 + x);
convert_units [K, degC] : lambda ([x], x - 27315/100);
convert_units [R, degF] : lambda ([x], x - 45967/100);

/* Dimensional analysis
 */

declare_dimensions ([L%]) :=
    if length (L%) > 2
        then (declare_dimensions1 (L%[1], L%[2]), apply (declare_dimensions, rest (rest (L%))))
        elseif length (L%) = 2
            then (declare_dimensions1 (L%[1], L%[2]), 'done)
            else error ("declare_dimensions: expected an even number of arguments.");
    
declare_dimensions1 (a%, b%) :=
    if listp (a%)
        then map (lambda ([a1%], declare_dimensions1 (a1%, b%)), a%)
        elseif listp (b%)
            then map (lambda ([b1%], declare_dimensions1 (a%, b1%)), b%)
            else put (a%, b%, 'dimension);

remove_dimensions ([L%]) := map (lambda ([a%], put (a%, false, 'dimension)), L%);

declare_fundamental_dimensions ([L]) :=
   (if not every (symbolp, L)
        then error ("declare_fundamental_dimensions: all arguments must be symbols."),
    if listp (fundamental_dimensions)
        then remove_fundamental_dimensions (),
    fundamental_dimensions : L,
    map (lambda ([s], assume (s > 0)), fundamental_dimensions));

remove_fundamental_dimensions () :=
    map (lambda ([s], forget (s > 0)), fundamental_dimensions);

declare_fundamental_units ([L]) :=
   (if length (L) # length (fundamental_dimensions)
        then error ("declare_fundamental_units: expected one argument per fundamental dimension."),
    if not every (symbolp, L)
        then error ("declare_fundamental_units: all arguments must be symbols."),
    if listp (%fundamental_units)
        then remove_fundamental_units (),
    %fundamental_units : L,
    map (lambda ([x, y], declare_dimensions (x, y)), %fundamental_units, fundamental_dimensions));

remove_fundamental_units () :=
   (apply (remove_dimensions, %fundamental_units),
    kill (%fundamental_units));

declare_fundamental_dimensions (length, mass, time, charge, temperature, quantity);

declare_fundamental_units (m, kg, s, A, K, mol);

/* I GUESS RULES FOR DIMENSIONS COULD RECOGNIZE EQUATIONS, DERIVATIVES, AND INTEGRALS
 */

matchdeclare
   (aa%, lambda ([e%], atom (e%) and not symbolp (e%)),
    bb%, lambda ([e%], symbolp (e%) and member (e%, fundamental_dimensions)),
    cc%, lambda ([e%], symbolp (e%) and get (e%, 'units) # false),
    dd%, lambda ([e%], symbolp (e%) and get (e%, 'constvalue) # false),
    ee%, lambda ([e%], symbolp (e%) and get (e%, 'dimension) # false),
    ee1%, lambda ([e%], symbolp (e%) and ?mget (e%, 'numer) # false),
    ff%, lambda ([e%], symbolp (e%)),
    gg%, lambda ([e%], not atom (e%) and op (e%) = "`"),
    hh%, lambda ([e%], not atom (e%) and op (e%) = "^"),
    ii%, lambda ([e%], not atom (e%) and member (op (e%), ["+", "-", "*", "/"])));

simp : false;
defrule (raa, 'dimensions (aa%), 1);
defrule (rbb, 'dimensions (bb%), bb%);
defrule (rcc, 'dimensions (cc%), dimensions (get (cc%, 'units)));
defrule (rdd, 'dimensions (dd%), dimensions (get (dd%, 'constvalue)));
defrule (ree, 'dimensions (ee%), get (ee%, 'dimension));
defrule (ree1, 'dimensions (ee1%), dimensions (?mget (ee1%, 'numer)));
defrule
   (rff,
    'dimensions (ff%), 
    block
      ([ff%2 : ev (ff%, args (known_unit_conversions), infeval)],
        if ff%2 # ff% then dimensions (ff%2) else 'dimensions (ff%)));
defrule (rgg, 'dimensions (gg%), (constvalue (first (gg%)), if unitp (%%) then dimensions (second (%%)) else 1) * dimensions (second (gg%)));
matchdeclare (aa%, all, bb%, constantp_not1);
defrule (rhh, 'dimensions (aa%^bb%), dimensions (aa%) ^ bb%);
defrule (rii, 'dimensions (ii%), map (dimensions, ii%));
/* ??? defrule (rjj, 'dimensions (sqrt (aa%)), sqrt (dimensions (aa%))); */
simp : true;

dimensions (expr) :=
    apply (apply1, ['dimensions (expr), raa, rbb, rcc, rdd, ree, ree1, rff, rgg, rhh, rii]);

/* Adapted from dimensions_as_list in share/physics/dimension.mac.
 * Thanks to Barton Willis.
 */
/* FOLLOWING DEFINITION HANDLES DIMENSION NOUNS INCORRECTLY
 * NEED TO REVISIT THIS
 */
dimensions_as_list (e) :=
    if listp (e)
        then map ('dimensions_as_list, e)
        else
           (e : dimensions (e),
            if polynomialp (e, fundamental_dimensions, lambda ([x], numberp (x)), lambda ([x], integerp (x)))
                then makelist (hipow (e, d), d, fundamental_dimensions)
                else 'dimensions_as_list (e));

fundamental_units (e) :=
    if listp (e)
        then map ('fundamental_units, e)
        else
           (dimensions_as_list (e),
            apply ("*", map ("^", %fundamental_units, %%)));

/* Adapted from dimensionless in share/physics/dimension.mac.
 * Thanks to Barton Willis.
 */

dimensionless (e) :=
    if not listp (e)
        then 'dimensionless (e)
        else
            args
               (map
                   (lambda ([s], xreduce ("*", map("^", e, first (transpose (s))))),
                    nullspace (transpose (funmake ('matrix, map ('dimensions_as_list, e))))));

/* Adapted from natural_unit in share/physics/dimension.mac.
 * Thanks to Barton Willis.
 */

natural_unit (d, e) :=
block
  ([vars, s],
 
    if not listp (e)
        then return ('natural_unit (d, e)),

    d : dimensions_as_list (d),
    s : map ('dimensions_as_list, e),
    vars : makelist (?gensym(), k, 1, length (e)),

    block
      ([linsolve_params : true,
        back_subst : true,
        globalsolve : false,
        solve_inconsistent_error : false],
        s : linsolve (s . vars - d, vars)),

    s : xreduce ("*", map ("^", e, map ('rhs, s))),
    s : subst (map ("=", %rnum_list, makelist (0, i, 1, length (%rnum_list))), s),
    map (lambda ([x], s * x), cons (1, dimensionless (e))));
