share/simplification/absimp.mac

   1 ttyoff: nolabels: true $
   2 %signumdistribute:%absdistribute:false $
   3 %eligible:'[sinh,atan,tanh,atanh,erf,asinh,csch,coth,asin] $
   4 unitstep(u) := (1+signum(u))/2 $
   5 unitramp(u) := (u+abs(u))/2 $
   6
   7 matchdeclare([utrue, vtrue], true,  eveninteger, evenintegerp) $
   8 oddintegerp(u):=
   9    if integerp(u) and integerp((u+1)/2) or ?moddp(u)
  10       then true else false $
  11 evenintegerp(u):=
  12    if integerp(u) and integerp(u/2) or ?mevenp(u)
  13      then true else false $
  14 tellsimpafter(abs(utrue)^eveninteger, utrue^eveninteger) $
  15 tellsimpafter('diff(abs(utrue),vtrue),signum(utrue)*diff(utrue,vtrue))$
  16 tellsimpafter(cosh(abs(utrue)), cosh(utrue)) $
  17 tellsimpafter(sech(abs(utrue)), sech(utrue)) $
  18 tellsimpafter(cos(abs(utrue)), cos(utrue)) $
  19 tellsimpafter(sec(abs(utrue)), sec(utrue)) $
  20 tellsimpafter(abs(utrue),  absimp(utrue)) $
  21 absimp(ut) :=block(
  22    [partswitch, prederror, u, v, w, b, nomatch],
  23    partswitch:true, prederror:false,
  24    if atom(ut) or inpart(ut,0)="+"  then
  25       if is(ut>0 or ut=0)=true then return(ut)
  26       else if is(ut<0 or ut=0)=true then return(-ut)
  27       else return(abs(ut)),
  28    if piece="*" then(u:v:1,
  29       w:[],
  30       for j:1 step 1 while(b:inpart(ut,j))#end do
  31          if is(b>0 or b=0)=true then u:u*b
  32          else if is(b<0 or b=0)=true then u:-u*b
  33          else if atom(b) or not(member(inpart(b,0), %eligible) or
  34             piece="^" and oddintegerp(inpart(b,2))) then(nomatch:true,
  35             for ww in w while nomatch do
  36                if b=first(ww) then (nomatch:false,
  37                   u: u*b*first(rest(ww)),
  38                   w:delete(ww,w)),
  39             if nomatch then w:cons([b,b],w))
  40          else (nomatch:true,
  41             inpart(b,1),
  42             for ww in w while nomatch do
  43                if piece=first(ww) then (nomatch:false,
  44                   u: u*b*first(rest(ww)),
  45                   w:delete(ww,w)),
  46             if nomatch then w: cons([piece,b], w)),
  47          if w=[] then return(u),
  48       if %absdistribute then for ww in w do u:u*absimp(first(rest(ww)))
  49       else (for ww in w do v:v*first(rest(ww)),
  50          u:u*(if rest(w)=[] then absimp(v) else 'abs(v))),
  51       return(u)),
  52    if piece="^" then (u:inpart(ut,1),
  53       if is(u>0 or u=0)=true then return(ut),
  54       v:inpart(ut,2),
  55       if evenintegerp(v) then return(ut),
  56       if oddintegerp(v) and is(u<0 or u=0) then return(-ut),
  57       return(abs(ut))),
  58    if piece='log then(b:inpart(ut,1),
  59       if is(b>1 or b=1)=true then return(ut),
  60       if is(b<1 or b=1)=true then return(-ut),
  61       return(abs(ut))),
  62    if piece='cosh or piece='sech or piece='abs then return(ut),
  63    if member(piece, %eligible)
  64       then return(apply(piece, [absimp(inpart(ut,1))])),
  65    return(abs(ut))) $
  66
  67 matchdeclare(nonzero,nonzerop, oddinteger,oddintegerp) $
  68 nonzerop(u) :=
  69    if ev(is(u>0 or u<0),prederror:false)=true then true
  70    else false $
  71
  72 tellsimpafter(signum(utrue)^oddinteger, signum(utrue)) $
  73 tellsimpafter(signum(nonzero)^eveninteger, 1) $
  74 tellsimpafter('diff(signum(utrue),vtrue),
  75    2*delta(utrue)*diff(utrue,vtrue))$
  76 tellsimpafter(cosh(signum(nonzero)), cosh(1)) $
  77 tellsimpafter(sech(signum(nonzero)), sech(1)) $
  78 tellsimpafter(utrue*signum(utrue), absimp(utrue)) $
  79 tellsimpafter(cos(signum(utrue)), cos(1)) $
  80 tellsimpafter(sec(signum(utrue)), sec(1)) $
  81 tellsimpafter(signum(utrue), signumsimp(utrue)) $
  82 signumsimp(ut) := block(
  83    [partswitch, prederror, u, v, b, nomatch],
  84    partswitch:true, prederror:false,
  85    if atom(ut) or inpart(ut,0)="+" then
  86       if is(ut>0)=true then return(1)
  87       else if is(ut<0)=true then return(-1)
  88       else return(signum(ut)),
  89    if piece="*" then(u:v:1, w:[],
  90       for j:1 step 1 while(b:inpart(ut,j))#end do
  91          if is(b<0)=true then u:-u
  92          else if is(b>0)#true then
  93             if atom(b) or not(member(inpart(b,0),%eligible) or
  94                piece="^" and oddintegerp(inpart(b,2))) then(
  95                nomatch:true,
  96                for ww in w while nomatch do
  97                   if b=first(ww) then (nomatch:false,
  98                      w:cons([b,not first(rest(ww))], delete(ww,w))),
  99                if nomatch then w:cons([b,true],w))
 100             else (nomatch:true,
 101                inpart(b,1),
 102                for ww in w while nomatch do
 103                   if piece=first(ww) then (nomatch:false,
 104                     w:cons([piece,not first(rest(ww))],delete(ww,w))),
 105                if nomatch then w:cons([piece,true],w)),
 106       if w=[] then return(u),
 107       if %signumdistribute then for ww in w do u:u*
 108          (if first(rest(ww)) then signumsimp(first(ww))
 109          else signumsimp(first(ww)^2))
 110       else (
 111          for ww in w do v:v*(if first(rest(ww)) then first(ww)
 112             else first(ww)^2),
 113          u:u*(if rest(w)=[] then signumsimp(v) else 'signum(v))),
 114       return(u)),
 115    if piece="^" then(u:inpart(ut,1),
 116       if is(u>0)=true then return(1),
 117       v:inpart(ut,2),
 118       if evenintegerp(v) and nonzerop(u) then return(1),
 119       if oddintegerp(v) then return(signumsimp(u)),
 120       return(signum(ut))),
 121    if piece='log then(b:inpart(ut,1),
 122       if is(b>1)=true then return(1),
 123       if is(b<1)=true then return(-1),
 124       if is(b=1)=true then return(0),
 125       return(signum(ut))),
 126    if piece='cosh or piece='sech then return(1),
 127    if piece='signum then return(ut),
 128    if member(piece, %eligible) then return(signumsimp(inpart(ut,1))),
 129    return(signum(ut))) $
 130 ttyoff: nolabels: false $