path: root/src/algebra/mkfunc.spad.pamphlet

\documentclass{article}
\usepackage{open-axiom}

\title{src/algebra mkfunc.spad}
\author{Manuel Bronstein}

\begin{document}
\maketitle
\begin{abstract}
\end{abstract}
\tableofcontents
\eject

\section{domain INFORM InputForm}

<<domain INFORM InputForm>>=
)abbrev domain INFORM InputForm
++ Parser forms
++ Author: Manuel Bronstein
++ Date Created: ???
++ Date Last Updated: October 14, 2008
++ Description:
++   Domain of parsed forms which can be passed to the interpreter.
++   This is also the interface between algebra code and facilities
++   in the interpreter.

InputForm():
  Join(SExpressionCategory(String,Symbol,Integer,DoubleFloat,OutputForm),
       ConvertibleTo SExpression) with
    interpret: % -> Any
      ++ interpret(f) passes f to the interpreter.
    convert  : SExpression -> %
      ++ convert(s) makes s into an input form.
    binary   : (%, List %) -> %
      ++ \spad{binary(op, [a1,...,an])} returns the input form
      ++ corresponding to  \spad{a1 op a2 op ... op an}.
    function : (%, List Symbol, Symbol) -> %
      ++ \spad{function(code, [x1,...,xn], f)} returns the input form
      ++ corresponding to \spad{f(x1,...,xn) == code}.
    lambda   : (%, List Symbol) -> %
      ++ \spad{lambda(code, [x1,...,xn])} returns the input form
      ++ corresponding to \spad{(x1,...,xn) +-> code} if \spad{n > 1},
      ++ or to \spad{x1 +-> code} if \spad{n = 1}.
    +      : (%, %) -> %
      ++ \spad{a + b} returns the input form corresponding to \spad{a + b}.
    *      : (%, %) -> %
      ++ \spad{a * b} returns the input form corresponding to \spad{a * b}.
    /      : (%, %) -> %
      ++ \spad{a / b} returns the input form corresponding to \spad{a / b}.
    **     : (%, NonNegativeInteger) -> %
      ++ \spad{a ** b} returns the input form corresponding to \spad{a ** b}.
    **     : (%, Integer) -> %
      ++ \spad{a ** b} returns the input form corresponding to \spad{a ** b}.
    0        : constant -> %
      ++ \spad{0} returns the input form corresponding to 0.
    1        : constant -> %
      ++ \spad{1} returns the input form corresponding to 1.
    flatten  : % -> %
      ++ flatten(s) returns an input form corresponding to s with
      ++ all the nested operations flattened to triples using new
      ++ local variables.
      ++ If s is a piece of code, this speeds up
      ++ the compilation tremendously later on.
    unparse  : % -> String
      ++ unparse(f) returns a string s such that the parser
      ++ would transform s to f.
      ++ Error: if f is not the parsed form of a string.
    parseString: String -> %
      ++ parseString is the inverse of unparse.  It parses a 
      ++ string to InputForm.
    declare  : List %   -> Symbol
      ++ declare(t) returns a name f such that f has been
      ++ declared to the interpreter to be of type t, but has
      ++ not been assigned a value yet.
      ++ Note: t should be created as \spad{devaluate(T)$Lisp} where T is the
      ++ actual type of f (this hack is required for the case where
      ++ T is a mapping type).
    compile  : (Symbol, List %) -> Symbol
      ++ \spad{compile(f, [t1,...,tn])} forces the interpreter to compile
      ++ the function f with signature \spad{(t1,...,tn) -> ?}.
      ++ returns the symbol f if successful.
      ++ Error: if f was not defined beforehand in the interpreter,
      ++ or if the ti's are not valid types, or if the compiler fails.
 == SExpression add

    strsym    : % -> String
    tuplify   : List Symbol -> %
    flatten0  : (%, Symbol, NonNegativeInteger) ->
                                             Record(lst: List %, symb:%)

    0                        == convert(0::Integer)
    1                        == convert(1::Integer)
    convert(x:%):SExpression == rep x
    convert(x:SExpression):% == per x

    conv(ll : List %): % ==
      per convert(ll pretend List SExpression)$SExpression

    lambda(f,l) == conv([convert("+->"::Symbol),tuplify l,f]$List(%))

    interpret x ==
      v := interpret(x)$Lisp
      objNew(unwrap(objVal(v)$Lisp)$Lisp, objMode(v)$Lisp)$Lisp

    convert(x:DoubleFloat):% ==
      zero? x => 0
      one? x => 1
      convert(x)

    flatten s ==
      -- will not compile if I use 'or'
      atom? s => s
      every?(atom?,destruct s)$List(%) => s
      sy := new()$Symbol
      n:NonNegativeInteger := 0
      l := destruct s
      l2 := [flatten0(x, sy, n := n + 1) for x in rest l]
      conv(concat(convert("SEQ"::Symbol)@%,
        concat(concat [u.lst for u in l2], conv(
           [convert("exit"::Symbol)@%, 1$%, conv(concat(first l,
               [u.symb for u in l2]))@%]$List(%))@%)))@%

    flatten0(s, sy, n) ==
      atom? s => [nil(), s]
      a := convert(concat(string sy, string n)::Symbol)@%
      l := destruct s
      l2 := [flatten0(x, sy, n := n+1) for x in rest l]
      [concat(concat [u.lst for u in l2], conv([convert(
        "%LET"::Symbol)@%, a, conv(concat(first l,
             [u.symb for u in l2]))@%]$List(%))@%), a]

    strsym s ==
      string? s => string s
      symbol? s => string symbol s
      error ["strsym: form", s, "is neither a string or symbol"]

    unparse x ==
      inputForm2String(x)$Lisp

    parseString x ==
      ncParseFromString(x)$Lisp

    declare signature ==
      declare(name := new()$Symbol, signature)$Lisp
      name

    compile(name, types) ==
      name' := convert(name)@%
      symbol car cdr car
        selectLocalMms(mkAtreeForToken(name')$Lisp, name',
          types, nil$List(%))$Lisp

    binary(op, args) ==
      (n := #args) < 2 => error "Need at least 2 arguments"
      n = 2 => convert([op, first args, last args]$List(%))
      convert([op, first args, binary(op, rest args)]$List(%))

    tuplify l ==
      empty? l => convert(nil$List(%))
      empty? rest l => convert first l
      conv
        concat(convert("tuple"::Symbol), [convert x for x in l]$List(%))

    function(f, l, name) ==
      nn := convert(new(1 + #l, convert(nil()$List(%)))$List(%))@%
      conv([convert("DEF"::Symbol), conv(cons(convert(name)@%,
                        [convert(x)@% for x in l])), nn, nn, f]$List(%))

    s1 + s2 ==
      s1 = 0 => s2
      s2 = 0 => s1
      conv [convert("+"::Symbol), s1, s2]$List(%)

    s1 * s2 ==
      s1 = 0 or s2 = 0 => 0
      s1 = 1 => s2
      s2 = 1 => s1
      conv [convert("*"::Symbol), s1, s2]$List(%)

    s1:% ** n:Integer ==
      s1 = 0 and positive? n => 0
      s1 = 1 or zero? n => 1
      one? n => s1
      conv [convert("**"::Symbol), s1, convert n]$List(%)

    s1:% ** n:NonNegativeInteger == s1 ** (n::Integer)

    s1 / s2 ==
      s2 = 1 => s1
      conv [convert("/"::Symbol), s1, s2]$List(%)

    -- A displayed form of an InputForm should be suitable as
    -- input to the interpreter parser.
    coerce(x: %): OutputForm ==
      inputForm2OutputForm(x)$Lisp

@
\section{package INFORM1 InputFormFunctions1}
<<package INFORM1 InputFormFunctions1>>=
)abbrev package INFORM1 InputFormFunctions1

++ Tools for manipulating input forms
++ Author: Manuel Bronstein
++ Date Created: ???
++ Date Last Updated: 19 April 1991
++ Description: Tools for manipulating input forms.

InputFormFunctions1(R:Type):with
  packageCall: Symbol -> InputForm
    ++ packageCall(f) returns the input form corresponding to f$R.
  interpret  : InputForm -> R
    ++ interpret(f) passes f to the interpreter, and transforms
    ++ the result into an object of type R.
 == add
  Rname := devaluate(R)$Lisp :: InputForm

  packageCall name ==
    convert([convert("$elt"::Symbol), Rname,
                                convert name]$List(InputForm))@InputForm

  interpret form ==
    retract(interpret(convert([convert("@"::Symbol), form,
          Rname]$List(InputForm))@InputForm)$InputForm)$AnyFunctions1(R)

@
\section{package MKFUNC MakeFunction}
<<package MKFUNC MakeFunction>>=
)abbrev package MKFUNC MakeFunction
++ Tools for making interpreter functions from top-level expressions
++ Author: Manuel Bronstein
++ Date Created: 22 Nov 1988
++ Date Last Updated: 8 Jan 1990
++ Description: transforms top-level objects into interpreter functions.
MakeFunction(S:ConvertibleTo InputForm): Exports == Implementation where
  SY ==> Symbol

  Exports ==> with
    function: (S, SY         ) -> SY
      ++ function(e, foo) creates a function \spad{foo() == e}.
    function: (S, SY,      SY) -> SY
      ++ function(e, foo, x) creates a function \spad{foo(x) == e}.
    function: (S, SY, SY,  SY) -> SY
      ++ function(e, foo, x, y) creates a function \spad{foo(x, y) = e}.
    function: (S, SY, List SY) -> SY
      ++ \spad{function(e, foo, [x1,...,xn])} creates a function
      ++ \spad{foo(x1,...,xn) == e}.

  Implementation ==> add
    function(s, name)            == function(s, name, nil())
    function(s:S, name:SY, x:SY) == function(s, name, [x])
    function(s, name, x, y)      == function(s, name, [x, y])

    function(s:S, name:SY, args:List SY) ==
      interpret function(convert s, args, name)$InputForm
      name

@

\section{package MKUCFUNC MakeUnaryCompiledFunction}

<<package MKUCFUNC MakeUnaryCompiledFunction>>=
import Type
import Symbol
import ConvertibleTo InputForm
)abbrev package MKUCFUNC MakeUnaryCompiledFunction
++ Tools for making compiled functions from top-level expressions
++ Author: Manuel Bronstein
++ Date Created: 1 Dec 1988
++ Date Last Updated: 5 Mar 1990
++ Description: transforms top-level objects into compiled functions.
MakeUnaryCompiledFunction(S, D, I): Exports == Implementation where
  S: ConvertibleTo InputForm
  D, I: Type

  SY  ==> Symbol
  DI  ==> devaluate(D -> I)$Lisp

  Exports ==> with
    unaryFunction   : SY -> (D -> I)
      ++ unaryFunction(a) is a local function
    compiledFunction: (S, SY) -> (D -> I)
      ++ compiledFunction(expr, x) returns a function \spad{f: D -> I}
      ++ defined by \spad{f(x) == expr}. 
      ++ Function f is compiled and directly
      ++ applicable to objects of type D.

  Implementation ==> add
    import MakeFunction(S)

    func: (SY, D) -> I

    func(name: SY, x: D): I ==
      %funcall(name, x, %nil$Foreign(Builtin))$Foreign(Builtin)

    unaryFunction name  == func(name, #1)

    compiledFunction(e:S, x:SY) ==
      t := [convert([devaluate(D)$Lisp]$List(InputForm))
           ]$List(InputForm)
      unaryFunction compile(function(e, declare DI, x), t)

@

\section{package MKBCFUNC MakeBinaryCompiledFunction}

<<package MKBCFUNC MakeBinaryCompiledFunction>>=
import Type
import CoercibleTo InputForm
import Symbol
)abbrev package MKBCFUNC MakeBinaryCompiledFunction
++ Tools for making compiled functions from top-level expressions
++ Author: Manuel Bronstein
++ Date Created: 1 Dec 1988
++ Date Last Updated: 5 Mar 1990
++ Description: transforms top-level objects into compiled functions.
MakeBinaryCompiledFunction(S, D1, D2, I):Exports == Implementation where
  S: ConvertibleTo InputForm
  D1, D2, I: Type

  SY  ==> Symbol
  DI  ==> devaluate((D1, D2) -> I)$Lisp

  Exports ==> with
    binaryFunction  : SY -> ((D1, D2) -> I)
      ++ binaryFunction(s) is a local function
    compiledFunction: (S, SY, SY) -> ((D1, D2) -> I)
      ++ compiledFunction(expr,x,y) returns a function \spad{f: (D1, D2) -> I}
      ++ defined by \spad{f(x, y) == expr}.
      ++ Function f is compiled and directly
      ++ applicable to objects of type \spad{(D1, D2)}

  Implementation ==> add
    import MakeFunction(S)

    func(name: SY, x: D1, y: D2): I ==
      %funcall(name, x, y, %nil$Foreign(Builtin))$Foreign(Builtin)

    binaryFunction name == func(name, #1, #2)

    compiledFunction(e, x, y) ==
      t := [devaluate(D1)$Lisp, devaluate(D2)$Lisp]$List(InputForm)
      binaryFunction compile(function(e, declare DI, x, y), t)

@
\section{package MKFLCFN MakeFloatCompiledFunction}
<<package MKFLCFN MakeFloatCompiledFunction>>=
)abbrev package MKFLCFN MakeFloatCompiledFunction
++ Tools for making compiled functions from top-level expressions
++ Author: Manuel Bronstein
++ Date Created: 2 Mar 1990
++ Date Last Updated: 2 Dec 1996 (MCD)
++ Description:
++ MakeFloatCompiledFunction transforms top-level objects into
++ compiled Lisp functions whose arguments are Lisp floats.
++ This by-passes the \Language{} compiler and interpreter,
++ thereby gaining several orders of magnitude.
MakeFloatCompiledFunction(S): Exports == Implementation where
  S: ConvertibleTo InputForm

  INF ==> InputForm
  SF  ==> DoubleFloat
  DI1 ==> devaluate(SF -> SF)$Lisp
  DI2 ==> devaluate((SF, SF) -> SF)$Lisp

  Exports ==> with
    makeFloatFunction: (S, Symbol)         -> (SF -> SF)
      ++ makeFloatFunction(expr, x) returns a Lisp function
      ++ \spad{f: \axiomType{DoubleFloat} -> \axiomType{DoubleFloat}}
      ++ defined by \spad{f(x) == expr}. 
      ++ Function f is compiled and directly
      ++ applicable to objects of type \axiomType{DoubleFloat}.
    makeFloatFunction: (S, Symbol, Symbol) -> ((SF, SF) -> SF)
      ++ makeFloatFunction(expr, x, y) returns a Lisp function
      ++ \spad{f: (\axiomType{DoubleFloat}, \axiomType{DoubleFloat}) -> \axiomType{DoubleFloat}}
      ++ defined by \spad{f(x, y) == expr}.
      ++ Function f is compiled and directly
      ++ applicable to objects of type \spad{(\axiomType{DoubleFloat}, \axiomType{DoubleFloat})}.

  Implementation ==> add
    import MakeUnaryCompiledFunction(S, SF, SF)
    import MakeBinaryCompiledFunction(S, SF, SF, SF)

    streq?    : (INF, String) -> Boolean
    streqlist?: (INF, List String) -> Boolean
    gencode   : (String, List INF) -> INF
    mkLisp    : INF -> Union(INF, "failed")
    mkLispList: List INF -> Union(List INF, "failed")
    mkDefun   : (INF, List INF) -> INF
    mkLispCall: INF -> INF
    mkPretend : INF -> INF
    mkCTOR : INF -> INF

    lsf := convert([convert("DoubleFloat"::Symbol)@INF]$List(INF))@INF

    streq?(s, st)    == s = convert(st::Symbol)@INF
    gencode(s, l)    == convert(concat(convert(s::Symbol)@INF, l))@INF
    streqlist?(s, l) == member?(string symbol s, l)
    quote(f: INF): INF == gencode("QUOTE",[f])
    coerceToSF(f: INF): INF == 
      gencode("COERCE",[f, quote getVMType(SF)$Foreign(Builtin)])

    -- return true if the form `x' is contained in `y'
    contained?(x: INF, y: INF): Boolean ==
      atom? y => x = y
      contained?(x, car y) or contained?(x, cdr y)

    mkPretend form ==
      convert([convert("pretend"::Symbol), form, lsf]$List(INF))@INF

    mkCTOR form ==
      convert([convert("C-TO-R"::Symbol), form]$List(INF))@INF


    mkLispCall name ==
      convert([convert("$elt"::Symbol),
                           convert("Lisp"::Symbol), name]$List(INF))@INF

    mkDefun(s, lv) ==
      name := convert(new()$Symbol)@INF
      body := coerceToSF mkCTOR s
      unusedParms := [ p for p in lv | not contained?(p,s)]
      stmts :=
        null unusedParms => [body]
        [gencode("DECLARE",[gencode("IGNORE", unusedParms)]),body]
      stmts := concat(gencode("DECLARE",[gencode("FLOAT",lv)]), stmts)
      header := [convert("DEFUN"::Symbol), name, convert lv]
      fun := convert append(header,stmts)
      EVAL(fun)$Lisp
      if _$compileDontDefineFunctions$Lisp then COMPILE(name)$Lisp
      name

    makeFloatFunction(f, x, y) ==
      (u := mkLisp(convert(f)@INF)) case "failed" =>
        compiledFunction(f, x, y)
      name := mkDefun(u::INF, [ix := convert x, iy := convert y])
      t    := [lsf, lsf]$List(INF)
      spadname := declare DI2
      spadform:=mkPretend convert([mkLispCall name,ix,iy]$List(INF))@INF
      interpret function(spadform, [x, y], spadname)
      binaryFunction compile(spadname, t)

    makeFloatFunction(f, var) ==
      (u := mkLisp(convert(f)@INF)) case "failed" =>
        compiledFunction(f, var)
      name := mkDefun(u::INF, [ivar := convert var])
      t    := [lsf]$List(INF)
      spadname := declare DI1
      spadform:= mkPretend convert([mkLispCall name,ivar]$List(INF))@INF
      interpret function(spadform, [var], spadname)
      unaryFunction compile(spadname, t)

    mkLispList l ==
      ans := nil()$List(INF)
      for s in l repeat
        (u := mkLisp s) case "failed" => return "failed"
        ans := concat(u::INF, ans)
      reverse! ans
    

    mkLisp s ==
      atom? s => s
      op := first(l := destruct s)
      (u := mkLispList rest l) case "failed" => "failed"
      ll := u::List(INF)
      streqlist?(op, ["+","*","/","-"]) => convert(concat(op, ll))@INF
      streq?(op, "**") => gencode("EXPT", ll)
      streqlist?(op, ["exp","sin","cos","tan","atan", 
         "log", "sinh","cosh","tanh","asinh","acosh","atanh","sqrt"]) =>
            gencode(upperCase string symbol op, ll)
      streq?(op, "nthRoot") =>
        second ll = convert(2::Integer)@INF =>gencode("SQRT",[first ll])
        gencode("EXPT", concat(first ll, [1$INF / second ll]))
      streq?(op, "float") =>
        a := ll.1
        e := ll.2
        b := ll.3
        _*(a, EXPT(b, e)$Lisp)$Lisp pretend INF
      "failed"

@
\section{License}
<<license>>=
--Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--All rights reserved.
--Copyright (C) 2007-2009, Gabriel Dos Reis.
--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>>

<<domain INFORM InputForm>>
<<package INFORM1 InputFormFunctions1>>
<<package MKFUNC MakeFunction>>
<<package MKUCFUNC MakeUnaryCompiledFunction>>
<<package MKBCFUNC MakeBinaryCompiledFunction>>
<<package MKFLCFN MakeFloatCompiledFunction>>
@
\eject
\begin{thebibliography}{99}
\bibitem{1} nothing
\end{thebibliography}
\end{document}