share/trigonometry/trgsmp.mac

   1 /*-*-MACSYMA-*-*/
   2 /*Code added 7/5/80 by ELL for mapping all trig and hyper trig functions
   3 into sin and cos (in lower case)*/
   4 /* 4:00pm  Tuesday, 11 August 1981 -GJC
   5    Added more eval_when conditionals to complement the improvement
   6    in Defrule translation and to invoke TRANSCOMPILE.
   7 11/20/83 11:08:42
   8   reformatting and some streamlining for translation. -asb
   9 */
  10
  11 eval_when([translate],
  12           tr_bound_function_applyp:false,
  13           mode_declare(function(expnlength,argslength),fixnum))$
  14
  15 /* Variable definitions */
  16
  17 define_variable(bestlength,0,fixnum)$
  18 define_variable(trylength,0,fixnum)$
  19
  20 /* Properties */
  21
  22 /* The following properties are used to implement the four identities:
  23
  24      FOO^2=GET(FOO,'UNITCOF)
  25            +GET(FOO,'COMPLEMENT_COF)*GET(FOO,'COMPLEMENT_FUNCTION)^2*/
  26
  27 put('sin,'cos,'complement_function)$
  28 put('cos,'sin,'complement_function)$
  29 put('sinh,'cosh,'complement_function)$
  30 put('cosh,'sinh,'complement_function)$
  31 put('cos,1,'unitcof)$
  32 put('sin,1,'unitcof)$
  33 put('cosh,1,'unitcof)$
  34 put('sinh,-1,'unitcof)$
  35 put('cos,-1,'complement_cof)$
  36 put('sin,-1,'complement_cof)$
  37 put('cosh,1,'complement_cof)$
  38 put('sinh,1,'complement_cof)$
  39
  40 put('sin,'trigonometric,'type)$
  41 put('cos,'trigonometric,'type)$
  42 put('sinh,'hyper_trigonometric,'type)$
  43 put('cosh,'hyper_trigonometric,'type)$
  44
  45 /* Declarations */
  46
  47 eval_when([translate,batch,demo],
  48           matchdeclare(a,true))$
  49
  50 /* Predicates */
  51
  52 trigonometricp(exp):=
  53   if not atom(exp) and symbolp(inpart(exp, 0))
  54     then is(get(inpart(exp,0),'type)='trigonometric
  55               or get(piece,'type)='hyper_trigonometric)$
  56
  57 /* Rules */
  58
  59 defrule(trigrule1,tan(a),sin(a)/cos(a))$
  60 defrule(trigrule2,sec(a),1/cos(a))$
  61 defrule(trigrule3,csc(a),1/sin(a))$
  62 defrule(trigrule4,cot(a),cos(a)/sin(a))$
  63 defrule(htrigrule1,tanh(a),sinh(a)/cosh(a))$
  64 defrule(htrigrule2,sech(a),1/cosh(a))$
  65 defrule(htrigrule3,csch(a),1/sinh(a))$
  66 defrule(htrigrule4,coth(a),cosh(a)/sinh(a))$
  67
  68 /* Functions */
  69
  70 trigsimp(x%):=
  71   trigsimp3(ratsimp(apply1(x%,
  72                           trigrule1,trigrule2,trigrule3,trigrule4,
  73                           htrigrule1,htrigrule2,htrigrule3,htrigrule4)))$
  74
  75 /*
  76  * Original version, left for posterity
  77  */
  78 /*
  79 trigsimp3(expn):=
  80    (expn:totaldisrep(expn),
  81     ratsimp(trigsimp1(num(expn))/trigsimp1(denom(expn)))) $
  82 */
  83
  84 /*
  85  * Like the original except that if expn is a list, we recurse over
  86  * the list one at a time instead of doing it all at once.  This
  87  * prevents quadratic (or exponential) behavior as the list gets
  88  * longer.
  89  *
  90  * See bug 965926
  91  */
  92
  93 trigsimp3(expn):=
  94    if listp(expn)
  95    then
  96      if expn = []
  97      then
  98         []
  99      else
 100         cons(ratsimp(trigsimp1(num(expn[1]))/trigsimp1(denom(expn[1]))),
 101              trigsimp3(rest(expn)))
 102    else
 103      ratsimp(trigsimp1(num(expn))/trigsimp1(denom(expn)))$
 104
 105 trigsimp1(expn):=block(
 106    [listoftrigsq, bestlength, trylength],
 107    listoftrigsq: listoftrigsq(expn),
 108    bestlength: 999999,
 109    if listoftrigsq#[]
 110    then improve(expn,expn,listoftrigsq)
 111    else expn)$
 112
 113 improve(expn,subsofar,listoftrigsq):=
 114   if listoftrigsq=[]
 115   then (if (trylength:expnlength(subsofar))<bestlength
 116         then (bestlength:trylength,subsofar)
 117         else expn)
 118   else (subsofar:improve(expn,subsofar,rest(listoftrigsq)),
 119         for alt in first(listoftrigsq) do
 120             subsofar:
 121             improve(subsofar,
 122                     ratsubst(get(inpart(alt,0),'unitcof)
 123                              +get(piece,'complement_cof)
 124                               *get(piece,'complement_function)(first(alt))^2,
 125                              alt^2,subsofar),
 126                     rest(listoftrigsq)),
 127         subsofar)$
 128
 129 listoftrigsq(expn):=
 130   if atom(expn)
 131   then []
 132   else block([inflag, ans:[]],
 133              if inpart(expn,0)="^" and integerp(inpart(expn,2))
 134                 and piece>=2
 135              then if atom(expn:inpart(expn,1))
 136                   then return([])
 137                   else if trigonometricp(expn)
 138                        then return([[expn]]),
 139              inflag:true,
 140              for arg in expn do
 141                  ans:specialunion(listoftrigsq(arg),ans),
 142              ans)$
 143
 144 specialunion(list1,list2):=
 145   if list1=[]
 146   then list2
 147   else if list2=[]
 148        then list1
 149        else block([alternates:first(list1)],
 150                   for alt in alternates do
 151                       list2:update(alt,get(inpart(alt,0),'complement_function)),
 152                   specialunion(rest(list1),list2))$
 153
 154 update(form, complement):=block(
 155    [ans],
 156    complement: apply(complement,[inpart(form,1)]),
 157    ans: for element in list2 do
 158       if member(form, element) then return('found)
 159       else if member(complement,element) then return(
 160          cons([form,complement], delete(element,list2))),
 161    if ans='found
 162    then list2
 163    else if ans='done
 164         then cons([form],list2)
 165         else ans)$
 166
 167 expnlength(expr):=block(
 168   [inflag:false],
 169   if atom(expr)
 170   then 1
 171   else 1+argslength(args(expr)))$
 172
 173 argslength(args):=
 174   apply("+",map('expnlength,args))$
 175
 176