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