Initial population.

1 files changed, 311 insertions, 0 deletions

diff --git a/src/algebra/d01weights.spad.pamphlet b/src/algebra/d01weights.spad.pamphlet
new file mode 100644
index 00000000..7f41244f
--- /dev/null
+++ b/src/algebra/d01weights.spad.pamphlet
@@ -0,0 +1,311 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/algebra d01weights.spad}
+\author{Brian Dupee}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{package D01WGTS d01WeightsPackage}
+<<package D01WGTS d01WeightsPackage>>=
+)abbrev package D01WGTS d01WeightsPackage
+++ Author: Brian Dupee
+++ Date Created: July 1994
+++ Date Last Updated: January 1998 (Bug fix - exprHasListOfWeightsCosWXorSinWX)
+++ Basic Operations: exprHasWeightCosWXorSinWX, exprHasAlgebraicWeight, 
+++ exprHasLogarithmicWeights
+++ Description:
+++ \axiom{d01WeightsPackage} is a package for functions used to investigate
+++ whether a function can be divided into a simpler function and a weight
+++ function.  The types of weights investigated are those giving rise to
+++ end-point singularities of the algebraico-logarithmic type, and 
+++ trigonometric weights.
+d01WeightsPackage(): E == I where
+  LEDF	==> List Expression DoubleFloat
+  KEDF	==> Kernel Expression DoubleFloat
+  LKEDF	==> List Kernel Expression DoubleFloat
+  EDF	==> Expression DoubleFloat
+  PDF	==> Polynomial DoubleFloat
+  FI	==> Fraction Integer
+  LDF	==> List DoubleFloat
+  DF	==> DoubleFloat
+  SOCDF	==> Segment OrderedCompletion DoubleFloat
+  OCDF	==> OrderedCompletion DoubleFloat
+  NIA	==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF)
+  INT	==> Integer
+  BOP	==> BasicOperator
+  URBODF	==> Union(Record(op:BasicOperator,w:DF),"failed")
+  LURBODF	==> List(Union(Record(op:BasicOperator,w:DF), "failed"))
+ 
+  E ==> with
+    exprHasWeightCosWXorSinWX:NIA -> URBODF 
+      ++ \axiom{exprHasWeightCosWXorSinWX} looks for trigonometric
+      ++ weights in an expression of the form \axiom{cos \omega x} or
+      ++ \axiom{sin \omega x}, returning the value of \omega 
+      ++ (\notequal 1) and the operator. 
+    exprHasAlgebraicWeight:NIA -> Union(LDF,"failed")
+      ++ \axiom{exprHasAlgebraicWeight} looks for algebraic weights
+      ++ giving rise to singularities of the function at the end-points.
+    exprHasLogarithmicWeights:NIA -> INT
+      ++ \axiom{exprHasLogarithmicWeights} looks for logarithmic weights
+      ++ giving rise to singularities of the function at the end-points.
+ 
+ 
+    
+  I ==> add
+    score:(EDF,EDF) -> FI
+    kernelIsLog:KEDF -> Boolean 
+    functionIsPolynomial?:EDF -> Boolean
+    functionIsNthRoot?:(EDF,EDF) -> Boolean 
+    functionIsQuotient:EDF -> Union(EDF,"failed")
+    findCommonFactor:LEDF -> Union(LEDF,"failed")
+    findAlgebraicWeight:(NIA,EDF) -> Union(DF,"failed")
+    exprHasListOfWeightsCosWXorSinWX:(EDF,Symbol) -> LURBODF
+    exprOfFormCosWXorSinWX:(EDF,Symbol) -> URBODF
+    bestWeight:LURBODF -> URBODF
+    weightIn?:(URBODF,LURBODF) -> Boolean
+    inRest?:(EDF,LEDF)->Boolean
+    factorIn?:(EDF,LEDF)->Boolean
+    voo?:(EDF,EDF)->Boolean
+   
+    kernelIsLog(k:KEDF):Boolean ==
+      (name k = (log :: Symbol))@Boolean
+ 
+    factorIn?(a:EDF,l:LEDF):Boolean ==
+      for i in 1..# l repeat
+        (a = l.i)@Boolean => return true
+      false
+ 
+    voo?(b:EDF,a:EDF):Boolean ==
+       (voo:=isTimes(b)) case LEDF and factorIn?(a,voo)
+ 
+    inRest?(a:EDF,l:LEDF):Boolean ==
+      every?( voo?(#1,a) ,l)
+ 
+    findCommonFactor(l:LEDF):Union(LEDF,"failed") ==
+      empty?(l)$LEDF => "failed"
+      f := first(l)$LEDF
+      r := rest(l)$LEDF
+      (t := isTimes(f)$EDF) case LEDF =>
+        pos:=select(inRest?(#1,r),t)
+        empty?(pos) => "failed"
+        pos
+      "failed"
+ 
+    exprIsLogarithmicWeight(f:EDF,Var:EDF,a:EDF,b:EDF):INT ==
+      ans := 0$INT
+      k := tower(f)$EDF
+      lf := select(kernelIsLog,k)$LKEDF
+      empty?(lf)$LKEDF => ans
+      for i in 1..# lf repeat
+        arg := argument lf.i
+        if (arg.1 = (Var - a)) then
+          ans := ans + 1
+        else if (arg.1 = (b - Var)) then
+          ans := ans + 2
+      ans      
+ 
+    exprHasLogarithmicWeights(args:NIA):INT ==
+      ans := 1$INT
+      a := getlo(args.range)$d01AgentsPackage :: EDF
+      b := gethi(args.range)$d01AgentsPackage :: EDF
+      Var := args.var :: EDF
+      (l := isPlus numerator args.fn) case LEDF =>
+        (cf := findCommonFactor l) case LEDF =>
+          for j in 1..# cf repeat
+            ans := ans + exprIsLogarithmicWeight(cf.j,Var,a,b)
+          ans
+        ans
+      ans := ans + exprIsLogarithmicWeight(args.fn,Var,a,b)
+ 
+    functionIsQuotient(expr:EDF):Union(EDF,"failed") ==
+      (k := mainKernel expr) case KEDF =>
+        expr = inv(f := k :: KEDF :: EDF)$EDF => f
+--        one?(numerator expr) => denominator expr
+        (numerator expr = 1) => denominator expr
+        "failed"
+      "failed"
+ 
+    functionIsPolynomial?(f:EDF):Boolean ==
+      (retractIfCan(f)@Union(PDF,"failed"))$EDF case PDF
+ 
+    functionIsNthRoot?(f:EDF,e:EDF):Boolean ==
+      (m := mainKernel f) case "failed" => false
+--      (one?(# (kernels f))) 
+      ((# (kernels f)) = 1) 
+        and (name operator m = (nthRoot :: Symbol))@Boolean
+          and (((argument m).1 = e)@Boolean)
+ 
+    score(f:EDF,e:EDF):FI ==
+      ans := 0$FI
+      (t := isTimes f) case LEDF =>
+        for i in 1..# t repeat
+          ans := ans + score(t.i,e)
+        ans
+      (q := functionIsQuotient f) case EDF =>
+        ans := ans - score(q,e)
+      functionIsPolynomial? f =>
+        g:EDF := f/e
+        if functionIsPolynomial? g then
+          ans := 1+score(g,e)
+        else
+          ans 
+      (l := isPlus f) case LEDF =>
+        (cf := findCommonFactor l) case LEDF =>
+          factor := 1$EDF
+          for i in 1..# cf repeat
+            factor := factor*cf.i
+          ans := ans + score(f/factor,e) + score(factor,e)
+        ans
+      functionIsNthRoot?(f,e) =>
+        (p := isPower f) case "failed" => ans
+        exp := p.exponent
+        m := mainKernel f
+        m case KEDF => 
+          arg := argument m
+          a:INT := (retract(arg.2)@INT)$EDF
+          exp / a
+        ans
+      ans
+ 
+    findAlgebraicWeight(args:NIA,e:EDF):Union(DF,"failed") == 
+      zero?(s := score(args.fn,e)) => "failed"
+      s :: DF
+ 
+    exprHasAlgebraicWeight(args:NIA):Union(LDF,"failed") ==
+      (f := functionIsContinuousAtEndPoints(args)$d01AgentsPackage) 
+                                          case continuous =>"failed"
+      Var := args.var :: EDF
+      a := getlo(args.range)$d01AgentsPackage :: EDF
+      b := gethi(args.range)$d01AgentsPackage :: EDF
+      A := Var - a
+      B := b - Var
+      f case lowerSingular => 
+        (h := findAlgebraicWeight(args,A)) case "failed" => "failed"
+        [h,0] 
+      f case upperSingular => 
+        (g := findAlgebraicWeight(args,B)) case "failed" => "failed"
+        [0,g] 
+      h := findAlgebraicWeight(args,A) 
+      g := findAlgebraicWeight(args,B)
+      r := (h case "failed")
+      s := (g case "failed")
+      (r) and (s) => "failed"
+      r => [0,coerce(g)@DF]
+      s => [coerce(h)@DF,0]  
+      [coerce(h)@DF,coerce(g)@DF]
+ 
+    exprOfFormCosWXorSinWX(f:EDF,var:Symbol): URBODF ==
+      l:LKEDF := kernels(f)$EDF
+--      one?((# l)$LKEDF)$INT => 
+      # l = 1 => 
+        a:LEDF := argument(e:KEDF := first(l)$LKEDF)$KEDF
+        empty?(a) => "failed"
+        m:Union(LEDF,"failed") := isTimes(first(a)$LEDF)$EDF 
+        m case LEDF => -- if it is a list, it will have at least two elements
+          is?(second(m)$LEDF,var)$EDF =>
+            omega:DF := retract(first(m)$LEDF)@DF
+            o:BOP := operator(n:Symbol:=name(e)$KEDF)$BOP
+            (n = cos@Symbol)@Boolean => [o,omega]
+            (n = sin@Symbol)@Boolean => [o,omega]
+            "failed"
+          "failed"
+        "failed"
+      "failed"
+ 
+    exprHasListOfWeightsCosWXorSinWX(f:EDF,var:Symbol): LURBODF ==
+      (e := isTimes(f)$EDF) case LEDF => 
+        [exprOfFormCosWXorSinWX(u,var) for u in e]
+      empty?(k := kernels f) => ["failed"]
+      ((first(k)::EDF) = f) => 
+        [exprOfFormCosWXorSinWX(f,var)]
+      ["failed"]
+ 
+    bestWeight(l:LURBODF): URBODF ==
+      empty?(l)$LURBODF => "failed"
+      best := first(l)$LURBODF        --  best is first in list
+      empty?(rest(l)$LURBODF) => best
+      for i in 2..# l repeat          --  unless next is better
+        r:URBODF := l.i
+        if r case "failed" then leave
+        else if best case "failed" then
+          best := r
+        else if r.w > best.w then
+          best := r
+      best
+ 
+    weightIn?(weight:URBODF,listOfWeights:LURBODF):Boolean ==
+      n := # listOfWeights
+      for i in 1..n repeat                               -- cycle through list
+        (weight = listOfWeights.i)@Boolean => return true -- return when found
+      false
+ 
+    exprHasWeightCosWXorSinWX(args:NIA):URBODF ==
+      ans := empty()$LURBODF
+      f:EDF := numerator(args.fn)$EDF
+      (t:Union(LEDF,"failed") := isPlus(f)) case "failed" => 
+        bestWeight(exprHasListOfWeightsCosWXorSinWX(f,args.var))
+      if t case LEDF then
+        e1 := first(t)$LEDF
+        le1:LURBODF := exprHasListOfWeightsCosWXorSinWX(e1,args.var)
+        le1 := [u for u in le1 | (not (u case "failed"))]
+        empty?(le1)$LURBODF => "failed"
+        test := true
+        for i in 1..# le1 repeat
+          le1i:URBODF := le1.i
+          for j in 2..# t repeat
+            if test then
+              tj:LURBODF := exprHasListOfWeightsCosWXorSinWX(t.j,args.var)
+              test := weightIn?(le1i,tj)
+          if test then
+            ans := concat([le1i],ans)
+        bestWeight ans
+      else "failed"
+
+@
+\section{License}
+<<license>>=
+--Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+--All rights reserved.
+--
+--Redistribution and use in source and binary forms, with or without
+--modification, are permitted provided that the following conditions are
+--met:
+--
+--    - Redistributions of source code must retain the above copyright
+--      notice, this list of conditions and the following disclaimer.
+--
+--    - Redistributions in binary form must reproduce the above copyright
+--      notice, this list of conditions and the following disclaimer in
+--      the documentation and/or other materials provided with the
+--      distribution.
+--
+--    - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--      names of its contributors may be used to endorse or promote products
+--      derived from this software without specific prior written permission.
+--
+--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+--IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+--TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+--PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+--OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+--EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+--PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+--PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+--LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+--NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+--SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+@
+<<*>>=
+<<license>>
+
+<<package D01WGTS d01WeightsPackage>>
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}