archive/share/trash/trgsmp.mc

   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   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(RADCAN(APPLY1(X,
  72                           TRIGRULE1,TRIGRULE2,TRIGRULE3,TRIGRULE4,
  73                           HTRIGRULE1,HTRIGRULE2,HTRIGRULE3,HTRIGRULE4)))$
  74
  75 TRIGSIMP3(EXPN):=
  76    (EXPN:TOTALDISREP(EXPN),
  77     RATSIMP(TRIGSIMP1(NUM(EXPN))/TRIGSIMP1(DENOM(EXPN)))) $
  78
  79 TRIGSIMP1(EXPN):=BLOCK(
  80    [LISTOFTRIGSQ, BESTLENGTH, TRYLENGTH],
  81    LISTOFTRIGSQ: LISTOFTRIGSQ(EXPN),
  82    BESTLENGTH: 999999,
  83    IF LISTOFTRIGSQ#[]
  84    THEN IMPROVE(EXPN,EXPN,LISTOFTRIGSQ)
  85    ELSE EXPN)$
  86
  87 IMPROVE(EXPN,SUBSOFAR,LISTOFTRIGSQ):=
  88   IF LISTOFTRIGSQ=[]
  89   THEN (IF (TRYLENGTH:EXPNLENGTH(SUBSOFAR))<BESTLENGTH
  90         THEN (BESTLENGTH:TRYLENGTH,SUBSOFAR)
  91         ELSE EXPN)
  92   ELSE (SUBSOFAR:IMPROVE(EXPN,SUBSOFAR,REST(LISTOFTRIGSQ)),
  93         FOR ALT IN FIRST(LISTOFTRIGSQ) DO
  94             SUBSOFAR:
  95             IMPROVE(SUBSOFAR,
  96                     RATSUBST(GET(INPART(ALT,0),'UNITCOF)
  97                              +GET(PIECE,'COMPLEMENT_COF)
  98                               *GET(PIECE,'COMPLEMENT_FUNCTION)(FIRST(ALT))^2,
  99                              ALT^2,SUBSOFAR),
 100                     REST(LISTOFTRIGSQ)),
 101         SUBSOFAR)$
 102
 103 LISTOFTRIGSQ(EXPN):=
 104   IF ATOM(EXPN)
 105   THEN []
 106   ELSE BLOCK([INFLAG, ANS:[]],
 107              DECLARE(ANS,SPECIAL),
 108              IF INPART(EXPN,0)="^" AND INTEGERP(INPART(EXPN,2))
 109                 AND PIECE>=2
 110              THEN IF ATOM(EXPN:INPART(EXPN,1))
 111                   THEN RETURN([])
 112                   ELSE IF TRIGONOMETRICP(EXPN)
 113                        THEN RETURN([[EXPN]]),
 114              INFLAG:TRUE,
 115              FOR ARG IN EXPN DO
 116                  ANS:SPECIALUNION(LISTOFTRIGSQ(ARG),ANS),
 117              ANS)$
 118
 119 SPECIALUNION(LIST1,LIST2):=
 120   IF LIST1=[]
 121   THEN LIST2
 122   ELSE IF LIST2=[]
 123        THEN LIST1
 124        ELSE BLOCK([ALTERNATES:FIRST(LIST1)],
 125                   FOR ALT IN ALTERNATES DO
 126                       LIST2:UPDATE(ALT,GET(INPART(ALT,0),'COMPLEMENT_FUNCTION)),
 127                   SPECIALUNION(REST(LIST1),LIST2))$
 128
 129 DECLARE(LIST2,SPECIAL)$
 130
 131 UPDATE(FORM, COMPLEMENT):=BLOCK(
 132    [ANS],
 133    DECLARE(ANS,SPECIAL),
 134    COMPLEMENT: APPLY(COMPLEMENT,[INPART(FORM,1)]),
 135    ANS: FOR ELEMENT IN LIST2 DO
 136       IF MEMBER(FORM, ELEMENT) THEN RETURN('FOUND)
 137       ELSE IF MEMBER(COMPLEMENT,ELEMENT) THEN RETURN(
 138          CONS([FORM,COMPLEMENT], DELETE(ELEMENT,LIST2))),
 139    IF ANS='FOUND
 140    THEN LIST2
 141    ELSE IF ANS='DONE
 142         THEN CONS([FORM],LIST2)
 143         ELSE ANS)$
 144
 145 EXPNLENGTH(EXPR):=BLOCK(
 146   [INFLAG:TRUE],
 147   IF ATOM(EXPR)
 148   THEN 1
 149   ELSE 1+ARGSLENGTH(ARGS(EXPR)))$
 150
 151 ARGSLENGTH(ARGS):=
 152   APPLY("+",MAP('EXPNLENGTH,ARGS))$
 153
 154