axiom-source 20170501-3 / usr / share / axiom-20170501 / src / algebra / FORMULA.spad

)abbrev domain FORMULA ScriptFormulaFormat
++ Author: Robert S. Sutor
++ Date Created: 1987 through 1990
++ References:
++   SCRIPT Mathematical Formula Formatter User's Guide, SH20-6453,
++   IBM Corporation, Publishing Systems Information Development,
++   Dept. G68, P.O. Box 1900, Boulder, Colorado, USA 80301-9191.
++ Description:
++ \spadtype{ScriptFormulaFormat} provides a coercion from
++ \spadtype{OutputForm} to IBM SCRIPT/VS Mathematical Formula Format.
++ The basic SCRIPT formula format object consists of three parts:  a
++ prologue, a formula part and an epilogue.  The functions
++ \spadfun{prologue}, \spadfun{formula} and \spadfun{epilogue}
++ extract these parts, respectively.  The central parts of the expression
++ go into the formula part.  The other parts can be set
++ (\spadfun{setPrologue!}, \spadfun{setEpilogue!}) so that contain the
++ appropriate tags for printing.  For example, the prologue and
++ epilogue might simply contain ":df."  and ":edf."  so that the
++ formula section will be printed in display math mode.

ScriptFormulaFormat() : SIG == CODE where

  E      ==> OutputForm
  I      ==> Integer
  L      ==> List
  S      ==> String

  SIG ==> SetCategory with

    coerce : E -> %
      ++ coerce(o) changes o in the standard output format to
      ++ SCRIPT formula format.

    convert : (E,I) -> %
      ++ convert(o,step) changes o in standard output format to
      ++ SCRIPT formula format and also adds the given step number.
      ++ This is useful if you want to create equations with given numbers
      ++ or have the equation numbers correspond to the interpreter step
      ++ numbers.

    display : (%, I) -> Void
      ++ display(t,width) outputs the formatted code t so that each
      ++ line has length less than or equal to \spadvar{width}.

    display : % -> Void
      ++ display(t) outputs the formatted code t so that each
      ++ line has length less than or equal to the value set by
      ++ the system command \spadsyscom{set output length}.

    epilogue : % -> L S
      ++ epilogue(t) extracts the epilogue section of a formatted object t.

    formula : % -> L S
      ++ formula(t) extracts the formula section of a formatted object t.

    new : () -> %
      ++ new() create a new, empty object. Use \spadfun{setPrologue!},
      ++ \spadfun{setFormula!} and \spadfun{setEpilogue!} to set the
      ++ various components of this object.

    prologue : % -> L S
      ++ prologue(t) extracts the prologue section of a formatted object t.

    setEpilogue! : (%, L S) -> L S
      ++ setEpilogue!(t,strings) sets the epilogue section of a
      ++ formatted object t to strings.

    setFormula! : (%, L S) -> L S
      ++ setFormula!(t,strings) sets the formula section of a
      ++ formatted object t to strings.

    setPrologue! : (%, L S) -> L S
      ++ setPrologue!(t,strings) sets the prologue section of a
      ++ formatted object t to strings.

  CODE ==> add

    import OutputForm
    import Character
    import Integer
    import List OutputForm
    import List String

    Rep := Record(prolog : L S, formula : L S, epilog : L S)

    -- local variables declarations and definitions

    expr: E
    prec,opPrec: I
    str:  S
    blank         : S := " @@ "

    maxPrec       : I   := 1000000
    minPrec       : I   := 0

    splitChars    : S   := " <>[](){}+*=,-%"

    unaryOps      : L S := ["-","^"]$(L S)
    unaryPrecs    : L I := [700,260]$(L I)

    -- the precedence of / in the following is relatively low because
    -- the bar obviates the need for parentheses.
    binaryOps     : L S := ["+->","|","**","/","<",">","=","OVER"]$(L S)
    binaryPrecs   : L I := [0,0,900, 700,400,400,400,   700]$(L I)

    naryOps       : L S := ["-","+","*",blank,",",";"," ","ROW","",
                            " habove "," here "," labove "]$(L S)
    naryPrecs     : L I := [700,700,800,  800,110,110,  0,    0, 0,
                            0,  0,  0]$(L I)
    naryNGOps     : L S := nil$(L S)

    plexOps       : L S := ["SIGMA","PI","INTSIGN","INDEFINTEGRAL"]$(L S)
    plexPrecs     : L I := [    700, 800,      700,            700]$(L I)

    specialOps    : L S := ["MATRIX","BRACKET","BRACE","CONCATB",     _
                            "AGGLST","CONCAT","OVERBAR","ROOT","SUB", _
                            "SUPERSUB","ZAG","AGGSET","SC","PAREN"]

    -- the next two lists provide translations for some strings for
    -- which the formula formatter provides special variables.

    specialStrings : L S :=
      ["5","..."]
    specialStringsInFormula : L S :=
      [" alpha "," ellipsis "]

    -- local function signatures

    addBraces:      S -> S
    addBrackets:    S -> S
    group:          S -> S
    formatBinary:   (S,L E, I) -> S
    formatFunction: (S,L E, I) -> S
    formatMatrix:   L E -> S
    formatNary:     (S,L E, I) -> S
    formatNaryNoGroup: (S,L E, I) -> S
    formatNullary:  S -> S
    formatPlex:     (S,L E, I) -> S
    formatSpecial:  (S,L E, I) -> S
    formatUnary:    (S,  E, I) -> S
    formatFormula:      (E,I) -> S
    parenthesize:   S -> S
    precondition:   E -> E
    postcondition:  S -> S
    splitLong:      (S,I) -> L S
    splitLong1:     (S,I) -> L S
    stringify:      E -> S

    -- public function definitions

    new() : % == [[".eq set blank @",":df."]$(L S),
      [""]$(L S), [":edf."]$(L S)]$Rep

    coerce(expr : E): % ==
      f : % := new()$%
      f.formula := [postcondition
        formatFormula(precondition expr, minPrec)]$(L S)
      f

    convert(expr : E, stepNum : I): % ==
      f : % := new()$%
      f.formula := concat(["<leqno lparen ",string(stepNum)$S,
        " rparen>"], [postcondition
          formatFormula(precondition expr, minPrec)]$(L S))
      f

    display(f : %, len : I) ==
      s,t : S
      for s in f.prolog repeat sayFORMULA(s)$Lisp
      for s in f.formula repeat
        for t in splitLong(s, len) repeat sayFORMULA(t)$Lisp
      for s in f.epilog repeat sayFORMULA(s)$Lisp
      void()$Void

    display(f : %) ==
      display(f, _$LINELENGTH$Lisp pretend I)

    prologue(f : %) == f.prolog
    formula(f : %)  == f.formula
    epilogue(f : %) == f.epilog

    setPrologue!(f : %, l : L S) == f.prolog := l
    setFormula!(f : %, l : L S)  == f.formula := l
    setEpilogue!(f : %, l : L S) == f.epilog := l

    coerce(f : %): E ==
      s,t : S
      l : L S := nil
      for s in f.prolog repeat l := concat(s,l)
      for s in f.formula repeat
        for t in splitLong(s, (_$LINELENGTH$Lisp pretend Integer) - 4) repeat
          l := concat(t,l)
      for s in f.epilog repeat l := concat(s,l)
      (reverse l) :: E

    -- local function definitions

    postcondition(str: S): S ==
      len : I := #str
      len < 4 => str
      plus : Character := char "+"
      minus: Character := char "-"
      for i in 1..(len-1) repeat
        if (str.i =$Character plus) and (str.(i+1) =$Character minus)
          then setelt(str,i,char " ")$S
      str

    stringify expr == object2String(expr)$Lisp pretend S

    splitLong(str : S, len : I): L S ==
      -- this blocks into lines
      if len < 20 then len := _$LINELENGTH$Lisp
      splitLong1(str, len)

    splitLong1(str : S, len : I) ==
      l : List S := nil
      s : S := ""
      ls : I := 0
      ss : S
      lss : I
      for ss in split(str,char " ") repeat
        lss := #ss
        if ls + lss > len then
          l := concat(s,l)$List(S)
          s := ""
          ls := 0
        lss > len => l := concat(ss,l)$List(S)
        ls := ls + lss + 1
        s := concat(s,concat(ss," ")$S)$S
      if ls > 0 then l := concat(s,l)$List(S)
      reverse l

    group str ==
      concat ["<",str,">"]

    addBraces str ==
      concat ["left lbrace ",str," right rbrace"]

    addBrackets str ==
      concat ["left lb ",str," right rb"]

    parenthesize str ==
      concat ["left lparen ",str," right rparen"]

    precondition expr ==
      outputTran(expr)$Lisp

    formatSpecial(op : S, args : L E, prec : I) : S ==
      op = "AGGLST" =>
        formatNary(",",args,prec)
      op = "AGGSET" =>
        formatNary(";",args,prec)
      op = "CONCATB" =>
        formatNary(" ",args,prec)
      op = "CONCAT" =>
        formatNary("",args,prec)
      op = "BRACKET" =>
        group addBrackets formatFormula(first args, minPrec)
      op = "BRACE" =>
        group addBraces formatFormula(first args, minPrec)
      op = "PAREN" =>
        group parenthesize formatFormula(first args, minPrec)
      op = "OVERBAR" =>
        null args => ""
        group concat [formatFormula(first args, minPrec)," bar"]
      op = "ROOT" =>
        null args => ""
        tmp : S := formatFormula(first args, minPrec)
        null rest args => group concat ["sqrt ",tmp]
        group concat ["midsup adjust(u 1.5 r 9) ",
          formatFormula(first rest args, minPrec)," sqrt ",tmp]
      op = "SC" =>
        formatNary(" labove ",args,prec)
      op = "SUB" =>
        group concat [formatFormula(first args, minPrec)," sub ",
          formatSpecial("AGGLST",rest args,minPrec)]
      op = "SUPERSUB" =>
        -- variable name
        form : List S := [formatFormula(first args, minPrec)]
        -- subscripts
        args := rest args
        null args => concat form
        tmp : S := formatFormula(first args, minPrec)
        if tmp ^= "" then form := append(form,[" sub ",tmp])$(List S)
        -- superscripts
        args := rest args
        null args => group concat form
        tmp : S := formatFormula(first args, minPrec)
        if tmp ^= "" then form := append(form,[" sup ",tmp])$(List S)
        -- presuperscripts
        args := rest args
        null args => group concat form
        tmp : S := formatFormula(first args, minPrec)
        if tmp ^= "" then form := append(form,[" presup ",tmp])$(List S)
        -- presubscripts
        args := rest args
        null args => group concat form
        tmp : S := formatFormula(first args, minPrec)
        if tmp ^= "" then form := append(form,[" presub ",tmp])$(List S)
        group concat form
      op = "MATRIX" => formatMatrix rest args
      concat ["not done yet for ",op]

    formatPlex(op : S, args : L E, prec : I) : S ==
      hold : S
      p : I := position(op,plexOps)
      p < 1 => error "unknown Script Formula Formatter unary op"
      opPrec := plexPrecs.p
      n : I := #args
      (n ^= 2) and (n ^= 3) => error "wrong number of arguments for plex"
      s : S :=
        op = "SIGMA"   => "sum"
        op = "PI"      => "product"
        op = "INTSIGN" => "integral"
        op = "INDEFINTEGRAL" => "integral"
        "????"
      hold := formatFormula(first args,minPrec)
      args := rest args
      if op ^= "INDEFINTEGRAL" then
        if hold ^= "" then
          s := concat [s," from",group concat ["\displaystyle ",hold]]
        if not null rest args then
          hold := formatFormula(first args,minPrec)
          if hold ^= "" then
            s := concat [s," to",group concat ["\displaystyle ",hold]]
          args := rest args
        s := concat [s," ",formatFormula(first args,minPrec)]
      else
        hold := group concat [hold," ",formatFormula(first args,minPrec)]
        s := concat [s," ",hold]
      if opPrec < prec then s := parenthesize s
      group s

    formatMatrix(args : L E) : S ==
      -- format for args is [[ROW ...],[ROW ...],[ROW ...]]
      group addBrackets formatNary(" habove ",args,minPrec)

    formatFunction(op : S, args : L E, prec : I) : S ==
      group concat [op, " ", parenthesize formatNary(",",args,minPrec)]

    formatNullary(op : S) ==
      op = "NOTHING" => ""
      group concat [op,"()"]

    formatUnary(op : S, arg : E, prec : I) ==
      p : I := position(op,unaryOps)
      p < 1 => error "unknown Script Formula Formatter unary op"
      opPrec := unaryPrecs.p
      s : S := concat [op,formatFormula(arg,opPrec)]
      opPrec < prec => group parenthesize s
      op = "-" => s
      group s

    formatBinary(op : S, args : L E, prec : I) : S ==
      p : I := position(op,binaryOps)
      p < 1 => error "unknown Script Formula Formatter binary op"
      op :=
        op = "**"    => " sup "
        op = "/"     => " over "
        op = "OVER"  => " over "
        op
      opPrec := binaryPrecs.p
      s : S := formatFormula(first args, opPrec)
      s := concat [s,op,formatFormula(first rest args, opPrec)]
      group
        op = " over " => s
        opPrec < prec => parenthesize s
        s

    formatNary(op : S, args : L E, prec : I) : S ==
      group formatNaryNoGroup(op, args, prec)

    formatNaryNoGroup(op : S, args : L E, prec : I) : S ==
      null args => ""
      p : I := position(op,naryOps)
      p < 1 => error "unknown Script Formula Formatter nary op"
      op :=
        op = ","     => ", @@ "
        op = ";"     => "; @@ "
        op = "*"     => blank
        op = " "     => blank
        op = "ROW"   => " here "
        op
      l : L S := nil
      opPrec := naryPrecs.p
      for a in args repeat
        l := concat(op,concat(formatFormula(a,opPrec),l)$L(S))$L(S)
      s : S := concat reverse rest l
      opPrec < prec => parenthesize s
      s

    formatFormula(expr,prec) ==
      i : Integer
      ATOM(expr)$Lisp pretend Boolean =>
        str := stringify expr
        INTEGERP(expr)$Lisp =>
          i := expr : Integer
          if (i < 0) or (i > 9) then group str else str
        (i := position(str,specialStrings)) > 0 =>
          specialStringsInFormula.i
        str
      l : L E := (expr pretend L E)
      null l => blank
      op : S := stringify first l
      args : L E := rest l
      nargs : I := #args

      -- special cases
      member?(op, specialOps) => formatSpecial(op,args,prec)
      member?(op, plexOps)    => formatPlex(op,args,prec)

      -- nullary case
      0 = nargs => formatNullary op

      -- unary case
      (1 = nargs) and member?(op, unaryOps) =>
        formatUnary(op, first args, prec)

      -- binary case
      (2 = nargs) and member?(op, binaryOps) =>
        formatBinary(op, args, prec)

      -- nary case
      member?(op,naryNGOps) => formatNaryNoGroup(op,args, prec)
      member?(op,naryOps) => formatNary(op,args, prec)
      op := formatFormula(first l,minPrec)
      formatFunction(op,args,prec)