-- Copyright (c) 1993, 1994, Joachim Schue, Werner M. Seiler
-- 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 Karlsruhe University 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.
--
-- (C) Version 1  1993  Joachim Schue, Werner M. Seiler
-- (C) Version 2  1994  Werner M. Seiler
--

)abbrev category JBC JetBundleCategory
++ Description:
++ \spadtype{JetBundleCategory} provides basic data structures and
++ procedures for jet bundles. Nearly all necessary functions are implemented
++ already here. Only the representation and functions which direct access
++ to it must be implemented in a domain.
++ Two notations of derivatives are supported. Default is multi-index
++ notation, where the i-th entry of the index denotes the number of
++ differentiations taken with respect to \spad{x^i}. In repeated index
++ notation each entry \spad{i} in the index denotes a differentiation
++ with respect to \spad{x^i}. The choice affects, however, only in-
++ and output. Internally, multi-index notation is used throughout.

JetBundleCategory() : Category == Def where

  V    ==> Vector
  B    ==> Boolean
  Sy   ==> Symbol
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  L    ==> List
  EI   ==> Expression Integer
  OUT  ==> OutputForm

  errmsg1  ==> "Improper multi-index"
  errmsg2  ==> "Improper upper index"
  errmsg3  ==> "Integration not possible"
  Const    ==> "Const"::Sy
  Indep    ==> "Indep"::Sy
  Dep      ==> "Dep"::Sy
  Deriv    ==> "Deriv"::Sy
  Multi    ==> "Multi"::Sy
  Repeated ==> "Repeated"::Sy
  DerMode  ==> [Multi, Repeated]@L Sy


  Def ==> Join(OrderedSet, CoercibleTo EI) with

      setNotation : Sy -> Sy
        ++ \spad{setNotation(s)} chooses the notation used for derivatives.
        ++ Returns the old value.

      getNotation : () -> Sy
        ++ \spad{getNotation()} shows the currently used notation.

      multiIndex : % -> L NNI
        ++ \spad{multiIndex(jv)} returns the multi-index of the jet
        ++ variable \spad{jv}.

      repeatedIndex : % -> L PI
        ++ \spad{repeatedIndex(jv)} returns the multi-index of the jet
        ++ variable \spad{jv} in repeated index notation.

      r2m : L PI -> L NNI
        ++ \spad{r2m(ind)} transforms a repeated index into a multi-index.

      m2r : L NNI -> L PI
        ++ \spad{m2r(ind)} transforms a multi-index into a repeated index.

      allRepeated : L NNI -> L L PI
        ++ \spad{allRepeated(ind)} returns a list of all possible realizations
        ++ of a given multi-index as repeated index.

      index : % -> PI
        ++ \spad{index(jv)} yields number of the jet variable \spad{jv}.

      type : % -> Sy
        ++ \spad{type(jv)} yields the type (\spad{Const, Indep, Dep, Deriv})
        ++ of the jet variable \spad{jv}.

      name : % -> Sy
        ++ \spad{name(jv)} yields the name of the jet variable \spad{jv}.

      class : L NNI -> NNI
        ++ \spad{class(ind)} yields the class of the multi-index \spad{ind}
        ++ (Position for first non-vanishing entry).

      class : % -> NNI
        ++ \spad{class(jv)} yields the class of the jet variable \spad{jv}
        ++ (Class of multi-index for derivative, 0 else).

      order : % -> NNI
        ++ \spad{order(jv)} yields the order of the jet variable \spad{jv}
        ++ (Order as derivative).

      weight : % -> NNI
        ++ \spad{weight(jv)} assigns each jet variable a unique integer
        ++ reflecting its position in the internal ordering. The variable with
        ++ the greater weight is also greater in this ordering.

      ">" : (%, %) -> B
        ++ \spad{jv1 > jv2} checks whether \spad{jv1} is greater than
        ++ \spad{jv2} in the internal ordering.

      differentiate : (%, PI) -> Union(%, "0")
        ++ \spad{differentiate(jv, i)} differentiates \spad{jv} wrt the
        ++ \spad{i}-th independent variable.

      derivativeOf? : (%, %) -> L NNI
        ++ \spad{derivativeOf?(jv1, jv2)} checks whether \spad{jv1} is a
        ++ derivative of \spad{jv2}. In this case, the difference of their
        ++ multi-indices is returned. Otherwise, an empty list is returned.

      integrateIfCan : (%, PI) -> Union(%, "failed")
        ++ \spad{integrate(jv, i)} integrated \spad{jv} wrt the \spad{i}-th
        ++ independent variable, if possible.

      integrate : (%, PI) -> %
        ++ \spad{integrate(jv, i)} is like \spad{integrateIfCan(jv, i)} but
        ++ yields an error, if the integration is not possible.

      X : PI -> %
        ++ \spad{X(i)} generates the \spad{i}-th independent variable.
      U : PI -> %
        ++ \spad{U(i)} generates the \spad{i}-th dependent variable.
      P : (PI, L NNI) -> %
        ++ \spad{P(i, ind)} generates the derivative of the \spad{i}-th
        ++ dependent variable wrt the index \spad{ind}. Whether \spad{ind}
        ++ is interpreted as multi-index or as repeated index depends on the
        ++ chosen notation.
      Pm : (PI, L NNI) -> %
        ++ \spad{Pm(i, ind)} is like \spad{P(i, ind)} but \spad{ind} is
        ++ always a multi-index.
      Pr : (PI, L PI) -> %
        ++ \spad{Pr(i, ind)} is like \spad{P(i, ind)} but \spad{ind} is
        ++ always a repeated index.

      1 : constant -> %
        ++ \spad{1} generates the special "jet variable" 1, which is
        ++ needed for the representation of linear functions.

      one? : % -> B
        ++ \spad{one?(jv)} checks whether the jet variables \spad{jv}
        ++ is the special variable 1.

      -- For the special cases of only one independent or only one dependent
      -- variable simpler calls are provided.
      X : () -> %
        ++ \spad{X()} generates the only independent variable.
      U : () -> %
        ++ \spad{U()} generates the only dependent variable.
      P : L NNI -> %
        ++ \spad{P(ind)} generates the derivative of the only dependent
        ++ variable wrt the index \spad{ind}.
      P : (PI, NNI) -> %
        ++ \spad{P(i, j)} generates the \spad{j}-th derivative of the
        ++ \spad{i}-th independent variable wrt the only independent
        ++ variable.
      P : NNI -> %
        ++ \spad{P(i)} generates the \spad{i}-th derivative of the only
        ++ dependent variable wrt the only independent variable.

      variables : NNI -> L %
        ++ \spad{variables(q)} computes the list of all jet variables up to
        ++ order \spad{q}.

      variables : (NNI, PI) -> L %
        ++ \spad{variables(q, c)} computes all jet variables of order \spad{q}
        ++ whose class is greater than or equal to \spad{c}.

      dimJ : NNI -> NNI
        ++ \spad{dimJ(q)} computes the (fibre) dimension of the \spad{q}-th
        ++ order jet bundle.

      dimS : NNI -> NNI
        ++ \spad{dimS(q)} computes dimension of SqT x VE
        ++ (= number of derivatives of order \spad{q}).

      numIndVar : () -> PI
        ++ \spad{numIndVar} returns the number of independent variables.

      numDepVar : () -> PI
        ++ \spad{numDepVar} returns the number of dependent variables.

    add

      -- Default section.
      -- The only procedures not implemented are:
      --   multiIndex, index, type, name, X, U, Pm (generic case)
      --   coerce, numIndVar, numDepVar, setNotation, getNotation

      import from Symbol
      import from List(NNI)

      -- global constants for parameters of jet bundle
      nn : PI := numIndVar()
      mm : PI := numDepVar()

      m2r(mi : L NNI) : L PI ==
          ri : L PI := empty
          k : PI := 1
          for i in mi repeat
              for j in 1..i repeat
                  ri := cons(k, ri)
              k := k+1
          ri

      r2m(ri : L PI) : L NNI ==
          mi : L NNI := new(numIndVar(), 0)
          for i in ri repeat
              i > nn => error errmsg1
              mi.i := 1 + mi.i
          mi

      allRepeated(mu : L NNI) : L L PI ==
          res : L L PI := empty
          for i in 1..nn  for k in mu repeat
              if not zero? k then
                  nu := copy mu
                  nu.i := (k - 1)::NNI
                  tmp := allRepeated nu
                  res := concat!(res, map((x : L PI) : L PI +-> cons(i::PI, x),
                                          tmp))
          empty? res => [empty$(L PI)]
          res

      repeatedIndex(jv : %) : L PI == m2r multiIndex jv

      -- ---------------- --
      -- Simple Functions --
      -- ---------------- --

      class(l : L NNI) : NNI ==
          res : PI := 1
          for i in l while zero? i repeat
              res := res + 1
          res

      class(jv : %) : NNI ==
          type(jv) ~= Deriv => 0
          class multiIndex jv

      order(jv : %) : NNI ==
       type(jv) ~= Deriv => 0
       sum : NNI := 0
       for i in multiIndex jv repeat
           sum := sum+i
       sum

      dimJ(q : NNI) : NNI ==
          mm*binomial(q + nn, nn)$Integer ::NNI

      dimS(q : NNI) : NNI ==
          mm*binomial(q + nn - 1, nn - 1)$Integer ::NNI

      X() : % == X(1)

      U() : % == U(1)

      P(lo : L NNI) : % == P(1, lo)

      P(up : PI, lo : NNI) : % == Pm(up, [lo])

      P(lo : NNI) : % == Pm(1, [lo])

      P(up : PI, lo : L NNI) : % ==
          getNotation() = Multi => Pm(up, lo)
          lop : L PI := empty
          for i in lo repeat
              zero? i => error errmsg1
              lop := cons(i::PI, lop)
          Pr(up, reverse! lop)

      Pr(up : PI, lo : L PI) : % == Pm(up, r2m lo)

      coerce(jv : %) : OUT == name(jv)::OUT

      -- ---------- --
      -- Dimensions --
      -- ---------- --

      dimJV : V NNI := new(1, mm)
      dimSV : V NNI := new(1, mm)
      mn : Integer := minIndex dimJV
          -- global vectors with already computed dimensions

      dimJ(q : NNI) : NNI ==
          q < #dimJV =>
              res := qelt(dimJV, mn + q)
              res > 0 => res
              res := mm*binomial(q + nn, nn)$Integer ::NNI
              qsetelt!(dimJV, mn + q, res)
              res
          oldJV := copy dimJV
          dimJV := new(q + 1, 0)
          for qq in mn..(mn + #oldJV - 1) repeat
              qsetelt!(dimJV, qq, qelt(oldJV, qq))
          res := mm*binomial(q + nn, nn)$Integer ::NNI
          qsetelt!(dimJV, mn + q, res)
          res

      dimS(q : NNI) : NNI ==
          q < #dimSV =>
              res := qelt(dimSV, mn + q)
              res > 0 => res
              res := mm*binomial(q + nn - 1, nn - 1)$Integer ::NNI
              qsetelt!(dimSV, mn + q, res)
              res
          oldSV := copy dimSV
          dimSV := new(q + 1, 0)
          for qq in mn..(mn + #oldSV - 1) repeat
              qsetelt!(dimSV, qq, qelt(oldSV, qq))
          res := mm*binomial(q + nn - 1, nn - 1)$Integer ::NNI
          qsetelt!(dimSV, mn + q, res)
          res

      -- --------------- --
      -- Differentiation --
      -- --------------- --

      differentiate(jv : %, i : PI) : Union(%, "0") ==
          i > nn => error errmsg2
          jt := type jv
          jt = Const => "0"
          jt = Indep =>
              index(jv) = i => 1
              "0"
          getNotation() = Multi =>
              mind := multiIndex jv
              setelt!(mind, i, elt(mind, i - 1 + minIndex(mind)) + 1)
              Pm(index jv, mind)
          rind := repeatedIndex jv
          empty? rind => Pr(index jv, [i])
          nind : L PI := empty
          while not empty? rind  while first(rind) > i repeat
              nind := cons(first(rind), nind)
              rind := rest rind
          nind := concat!(reverse!(nind), cons(i, rind))
          Pr(index jv, nind)

      derivativeOf?(jv1 : %, jv2 : %) : L NNI ==
          type(jv1) ~= Deriv => empty
          jt := type jv2
          jt ~= Deriv and jt ~= Dep => empty
          index(jv1) ~= index(jv2) => empty
          res : L NNI := empty
          for i1 in multiIndex(jv1) for i2 in multiIndex(jv2) repeat
              i1 < i2 => return empty
              res := cons((i1 - i2)::NNI, res)
          reverse! res

      integrateIfCan(jv : %, i : PI) : Union(%, "failed") ==
          i > nn => error errmsg2
          type(jv) ~= Deriv => "failed"
          getNotation() = Multi =>
              mind := multiIndex jv
              pos := i - 1 + minIndex mind
              mi := qelt(mind, pos)
              zero? mi => "failed"
              setelt!(mind, pos, (mi - 1)::NNI)
              Pm(index jv, mind)
          rind := repeatedIndex jv
          pos := position(i, rind)
          pos < minIndex rind => "failed"
          rind := delete(rind, pos)
          Pr(index jv, rind)

      integrate(jv : %, i : PI) : % ==
          ji := integrateIfCan(jv, i)
          ji case "failed" => error errmsg3
          ji::%

      -- -------- --
      -- Ordering --
      -- -------- --

      weight(jv : %) : NNI ==
          t := type jv
          t = Const => 0
          t = Indep => index jv
          t = Dep => (nn + 1)*index(jv)
          pos := nn + 1
          res := pos*index(jv)
          for i in repeatedIndex jv repeat
              pos := pos*(nn + 1)
              res := res + i*pos
          res

      one?(jv : %) == type(jv) = Const

      jv1 : % = jv2 : % ==
          t1 := type jv1
          t1 = Const => type(jv2) = Const
          t1 = Indep =>
              type(jv2) = Indep => index(jv1) = index(jv2)
              false
          index(jv1) = index(jv2) and multiIndex(jv1) = multiIndex(jv2)

      jv1 : % < jv2 : % ==
          -- Implements a total degree and class respecting ordering.
          -- More efficient than weight(jv1) < weight(jv2).
          t1 := type jv1
          t2 := type jv2
          t2 = Const => false
          t1 = Const => true
          t1 = Indep =>
              t2 = Indep => index(jv1) < index(jv2)
              true
          t1 = Dep =>
              t2 = Indep => false
              t2 = Dep => index(jv1) < index(jv2)
              true
          (t2 = Indep) or (t2 = Dep) => false
          o1 := order jv1
          o2 := order jv2
          o1 = o2 =>
              for i1 in multiIndex(jv1)  for i2 in multiIndex(jv2) repeat
                  if i1 ~= i2 then return i1 > i2
              index(jv1) < index(jv2)
          o1 < o2

      jv1 : % > jv2 : % == jv2 < jv1

      -- --------- --
      -- Variables --
      -- --------- --

      variables(q : NNI) : L % ==
          -- Generates all jet variables up to order q with the exception of 1.
          zero? q => [X(i::PI)  for i in nn..1 by -1]

          OIndList : L L PI := [[i::PI]  for i in 1..nn]
          IndList : L L PI := [[i::PI]  for i in nn..1 by -1]

          for qq in 2..q repeat
              NIndList : L L PI := empty
              for ind in OIndList repeat
                  for j in first(ind)..nn repeat
                      NIndList := cons(cons(j::PI, ind), NIndList)
              OIndList := reverse NIndList
              IndList := concat!(NIndList, IndList)

          JV : L % := empty
          for ind in IndList repeat
              for k in 1..mm repeat
                  JV := cons(Pr(k::PI, ind), JV)
          concat!(concat!([X(i::PI)  for i in 1..nn], _
                              [U(i::PI)  for i in 1..mm]), JV)

      variables(q : NNI, c : PI) : L % ==
          zero? q => empty

          OIndList : L L PI := [[i::PI]  for i in c..nn]
          for qq in 2..q repeat
              NIndList : L L PI := empty
              for ind in OIndList repeat
                  for j in first(ind)..nn repeat
                      NIndList := cons(cons(j::PI, ind), NIndList)
              OIndList := reverse! NIndList

          JV : L % := empty
          for ind in OIndList repeat
              for k in 1..mm repeat
                  JV := cons(Pr(k::PI, ind), JV)
          JV

)abbrev category JBFC JetBundleFunctionCategory
++ Description:
++ \spadtype{JetBundleFunctionCategory} defines the category of functions
++ (local sections) over a jet bundle. The formal derivative is defined
++ already here. It uses the Jacobi matrix of the functions. The columns
++ of the matrices are enumerated by jet variables. Thus they are
++ represented as a \spadtype{Record} of the matrix and a list of the jet
++ variables. Several simplification routines are implemented already here.

JetBundleFunctionCategory(JB : JBC) : Category == Def where

  Sy   ==> Symbol
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  I    ==> Integer
  B    ==> Boolean
  L    ==> List
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory
  SEM  ==> SparseEchelonMatrix(JB, %)

  SIMPREC ==> Record(Sys : L %, JM : SEM, Depend : Union("failed", L L NNI))
  LDREC   ==> Record(LD : JB, Fake? : B, Dep : L NNI, Fun : %)

  errmsg ==> "cannot simplify"


  Def ==> Join(PartialDifferentialRing Sy, _
               GcdDomain, _
               RetractableTo JB) with

      -- The following procedures are copied from JetBundleCategory for
      -- easier use.
      X : PI -> %
      U : PI -> %
      P : (PI, L NNI) -> %
      X : () -> %
      U : () -> %
      P : L NNI -> %
      P : (PI, NNI) -> %
      P : NNI -> %

      setNotation : Sy -> Void
      getNotation : () -> Sy

      numIndVar : () -> PI
      numDepVar : () -> PI

      coerce : JB -> %
        ++ \spad{coerce(jv)} coerces the jet variable \spad{jv}
        ++ into a local section.

      jetVariables : % -> L JB
        ++ \spad{jetVariables(f)} yields all jet variables effectively
        ++ occurring in \spad{f} in an ordered list.

      const? : % -> B
        ++ \spad{const?(f)} checks whether \spad{f} depends of jet variables.

      order : % -> NNI
        ++ \spad{order(f)} gives highest order of the jet variables
        ++ effectively occurring in \spad{f}.

      class : % -> NNI
        ++ \spad{class(f)} is defined as the highest class of the
        ++ jet variables effectively occurring in \spad{f}.

      numerator : % -> %
        ++ \spad{numerator(f)} yields the numerator of \spad{f}.

      denominator : % -> %
        ++ \spad{denominator(f)} yields the denominator of \spad{f}.

      jacobiMatrix : L % -> SEM
        ++ \spad{jacobiMatrix(sys)} constructs the Jacobi matrix
        ++ of the family \spad{sys} of functions.

      jacobiMatrix : (L %, L L JB) -> SEM
        ++ \spad{jacobiMatrix(sys, jvars)} constructs the Jacobi matrix
        ++ of the family \spad{sys} of functions. \spad{jvars} contains
        ++ for each function the effectively occurring jet variables.
        ++ The columns of the matrix are ordered.

      extractSymbol : SEM -> SEM
        ++ \spad{extractSymbol(jm)} extracts the highest order part of the
        ++ Jacobi matrix.

      symbol : L % -> SEM
        ++ \spad{symbol(sys)} computes directly the symbol of the family
        ++ \spad{sys} of functions.

      differentiate : (%, JB) -> %
        ++ \spad{differentiate(f, jv)} differentiates the function
        ++ \spad{f} wrt the jet variable \spad{jv}.

      formalDiff : (%, PI) -> %
        ++ \spad{formalDiff(f, i)} formally (totally) differentiates
        ++ \spad{f} wrt the \spad{i}-th independent variable.

      formalDiff : (%, L NNI) -> %
        ++ \spad{formalDiff(f, mu)} formally differentiates \spad{f} as
        ++ indicated by the multi-index \spad{mu}.

      formalDiff : (L %, PI) -> L %
        ++ \spad{formalDiff(sys, i)} formally differentiates a family
        ++ \spad{sys} of functions wrt the \spad{i}-th independent
        ++ variable.

      formalDiff2 : (%, PI, SEM) -> Record(DPhi : %, JVars : L JB)
        ++ \spad{formalDiff2(f, i, jm)} formally differentiates the
        ++ function \spad{f} with the Jacobi matrix \spad{jm} wrt
        ++ the \spad{i}-th independent variable. \spad{JVars} is
        ++ a list of the jet variables effectively in the
        ++ result \spad{DPhi} (might be too large).

      formalDiff2 : (L %, PI, SEM) -> Record(DSys : L %, JVars : L L JB)
        ++ \spad{formalDiff2(sys, i, jm)} is like the other
        ++ \spadfun{formalDiff2} but for systems.

      dimension : (L %, SEM, NNI) -> NNI
        ++ \spad{dimension(sys, jm, q)} computes the dimension of the manifold
        ++ described by the system \spad{sys} with Jacobi matrix \spad{jm}
        ++ in the jet bundle of order \spad{q}.

      orderDim : (L %, SEM, NNI) -> NNI
        ++ \spad{orderDim(sys, jm, q)} computes the dimension of the manifold
        ++ described by the system \spad{sys} with Jacobi matrix \spad{jm}
        ++ in the jet bundle of order \spad{q} over the jet bundle of
        ++ order \spad{q-1}.

      freeOf? : (%, JB) -> B
        ++ \spad{freeOf?(fun, jv)} checks whether \spad{fun} contains the
        ++ jet variable \spad{jv}.

      subst : (%, JB, %) -> %
        ++ \spad{subst(f, jv, exp)} substitutes \spad{exp} for the jet
        ++ variable \spad{jv} in the function \spad{f}.

      leadingDer : % -> JB
        ++ \spad{leadingDer(fun)} yields the leading derivative of \spad{fun}.
        ++ If \spad{fun} contains no derivatives \spad{1} is returned.

      sortLD : L % -> L %
        ++ \spad{sortLD(sys)} sorts the functions in \spad{sys} according
        ++ to their leading derivatives.

      solveFor : (%, JB) -> Union(%, "failed")
        ++ \spad{solveFor(fun, jv)} tries to solve \spad{fun} for the jet
        ++ variable \spad{jv}.

      dSubst : (%, JB, %) -> %
        ++ \spad{dSubst(f, jv, exp)} is like \spad{subst(f, jv, exp)}. But
        ++ additionally for all derivatives of \spad{jv} the corresponding
        ++ substitutions are performed.

      simplify : (L %, SEM) -> SIMPREC
        ++ \spad{simplify(sys, jm)} simplifies a system with given Jacobi
        ++ matrix. The Jacobi matrix of the simplified system is returned, too.
        ++ \spad{Depend} contains for each equation of the simplified system
        ++ the numbers of the equations of the original system out of which it
        ++ is build, if it is possible to obtain this information. If one can
        ++ generate equations of lower order by purely algebraic operations,
        ++ then \spad{simplify} should do this.

      simpOne : % -> %
        ++ \spad{simpOne(f)} removes unnecessary coefficients and
        ++ exponents, denominators etc.

      simpMod : (L %, L %) -> L %
        ++ \spad{simpMod(sys1, sys2)} simplifies the system \spad{sys1}
        ++ modulo the system \spad{sys2}.

      simpMod : (L %, SEM, L %) -> SIMPREC
        ++ \spad{simpMod(sys1, sys2)} simplifies the system \spad{sys1}
        ++ modulo the system \spad{sys2}. Returns the same information as
        ++ \spad{simplify}.

      reduceMod : (L %, L %) -> L %
        ++ \spad{reduceMod(sys1, sys2)} reduces the system \spad{sys1} modulo
        ++ the system \spad{sys2}.

      autoReduce : L % -> L %
        ++ \spad{autoReduce(sys)} tries to simplify a system by solving each
        ++ equation for its leading term and substituting it into the other
        ++ equations.

    add

      -- Default section.
      -- The following functions are already implemented here:
      --   const?, order, class, leadingDer, gcd, retractIfCan
      --   dSubst, simpOne, simpMod, reduceMod, autoReduce
      --   jacobiMatrix, extractSymbol
      --   formalDiff, formalDiff2
      -- The following procedures must be implemented in the domain
      --   coerce
      --   basic arithmetics, differentiate
      --   jetVariables, subst, solveFor
      -- The default version of simplify can treat only simple systems and
      -- should be overwritten by a domain specific implementation. The
      -- default implementation of gcd always returns 1!

      import from List(%)
      import from List(JB)
      import from List(List(JB))

      -- --------- --
      -- JBC Stuff --
      -- --------- --

      nn : PI := numIndVar()$JB
        -- global constant

      X(i : PI) : % == X(i)$JB ::%
      U(i : PI) : % == U(i)$JB ::%
      P(i : PI, l : L NNI) : % == P(i, l)$JB ::%
      X() : % == X()$JB ::%
      U() : % == U()$JB ::%
      P(l : L NNI) : % == P(l)$JB ::%
      P(i : PI, l : NNI) : % == P(i, l)$JB ::%
      P(i : NNI) : % == P(i)$JB ::%

      setNotation(s : Sy) : Void == setNotation(s)$JB
      getNotation() : Sy == getNotation()$JB

      numIndVar() : PI == numIndVar()$JB
      numDepVar() : PI == numDepVar()$JB

      -- ---------------- --
      -- Simple Functions --
      -- ---------------- --

      gcd(f1 : %, f2 : %) : % == 1

      retractIfCan(f : %) : Union(JB, "failed") ==
          JV := jetVariables f
          one?(#JV) =>
              jv := first JV
              one? differentiate(f, jv) => jv
              "failed"
          "failed"

      const?(Phi : %) : B ==
          JV := jetVariables Phi
          empty? JV => true
          #JV > 1 => false
          first(JV) = 1

      order(Phi : %) : NNI == order leadingDer Phi

      class(Phi : %) : NNI == class leadingDer Phi

      leadingDer(fun : %) : JB ==
          JV := jetVariables fun
          empty? JV => 1
          first JV

      freeOf?(fun : %, jv : JB) : B == not member?(jv, jetVariables fun)

      characteristic() : NNI == 0

      dSubst(f : %, jv : JB, exp : %) : % ==
          -- Performs for every derivative of jv the corresponding
          -- substitution using subst.
          of : % := 0
          nf : % := f
          while nf ~= of repeat
              of := nf
              JVar : L JB := jetVariables of
              for jvar in JVar  until jvar < jv repeat
                  d := derivativeOf?(jvar, jv)
                  if not empty? d then
                      dexp := formalDiff(exp, d)
                      nf := subst(nf, jvar, dexp)
          nf

      -- --------- --
      -- Dimension --
      -- --------- --

      -- The default implementation assumes that sys is simplified and
      -- that simplified systems contain only functionally independent
      -- equations. There are no checks whether the equations are of
      -- correct order in orderDim.

      dimension(sys : L %, jm : SEM, q : NNI) : NNI ==
          (dimJ(q)$JB - #sys)::NNI

      orderDim(sys : L %, jm : SEM, q : NNI) : NNI ==
          (dimS(q)$JB - #sys)::NNI

      -- --------------- --
      -- Jacobi Matrices --
      -- --------------- --

      noChecks? : B := (% has lazyRepresentation)
          -- Global constant. Attribute must be set by domain implementation.

      jacobiMatrix(funs : L %) : SEM ==
          jacobiMatrix(funs, [jetVariables(fun) for fun in funs])

      jacobiMatrix(funs : L %, varlist : L L JB) : SEM  ==
          -- Computes Jacobi matrix wrt the jet variables in varlist.
          -- Each element of varlist contains the variables for one function.
          -- It is assumed that these lists are sorted.
          -- Returns matrix with sorted columns.
          JvList := first varlist
          for vars in rest varlist repeat
              JvList := removeDuplicates! merge(">", JvList, vars)
          JM : SEM := new(JvList, #funs)
          for f in funs  for vars in varlist  for i in 1.. repeat
              ents : L % := empty
              inds : L JB := empty
              for jv in vars repeat
                  df := differentiate(f, jv)
                  if noChecks? or not zero? df then
                      ents := cons(df, ents)
                      inds := cons(jv, inds)
              setRow!(JM, i, reverse! inds, reverse! ents)
          JM

      symbol(funs : L %) : SEM ==
          JVL : L L JB := [jetVariables fun  for fun in funs]
          ol : L NNI := [order(first jl)$JB  for jl in JVL]
          ord := reduce(max, ol, 0)
          oJV : L L JB := empty
          allJV : L JB := empty
          for jl in JVL repeat
              ojl : L JB := empty
              while not(empty?(jl) or order(first jl)$JB < ord) repeat
                  ojl := cons(first jl, ojl)
                  jl := rest jl
              ojl := reverse! ojl
              oJV := cons(ojl, oJV)
              allJV := removeDuplicates! merge(">", allJV, ojl)
          oJV := reverse! oJV

          symb : SEM := new(allJV, #funs)
          for f in funs  for ojl in oJV  for i in 1.. repeat
              ents : L % := empty
              inds : L JB := empty
              for jv in ojl repeat
                  df := differentiate(f, jv)
                  if noChecks? or not zero? df then
                      ents := cons(df, ents)
                      inds := cons(jv, inds)
              setRow!(symb, i, reverse! inds, reverse! ents)
          symb

      extractSymbol(jm : SEM) : SEM ==
          inds := allIndices jm
          o := order first inds
          inds := rest inds
          while not(empty? inds) and (order(first inds) = o) repeat
              inds := rest inds
          empty? inds => jm
          horizSplit(jm, first inds).Left

      -- ---------------------- --
      -- Formal Differentiation --
      -- ---------------------- --

      formalDiff(Sys : L %, i : PI) : L % ==
          JM := jacobiMatrix Sys
          formalDiff2(Sys, i, JM).DSys

      formalDiff(Eq : %, i : PI) : % ==
          first formalDiff([Eq], i)

      formalDiff(f : %, mu : L NNI) : % ==
          JV : L JB := jetVariables f
          df := f
          for i in 1..nn  for j in mu repeat
              for k in 1..j repeat
                  jm := jacobiMatrix([df], [JV])
                  tmp := formalDiff2(df, i::PI, jm)
                  df := tmp.DPhi
                  JV := tmp.JVars
          df

      formalDiff2(Sys : L %, i : PI, JM : SEM
                         ) : Record(DSys : L %, JVars : L L JB) ==
          -- Formal differentiation with given Jacobi matrix.
          -- Returns list of effectively occurring jet variables for
          -- each function.
          inds := allIndices JM
          empty? inds => [[0 for eq in Sys], [empty for eq in Sys]]
          LRes : L % := empty
          LJV : L L JB := empty

          -- compute formal derivative for each function
          for l in 1..nrows(JM) repeat
              r := row(JM, l)
              res : % := 0
              JV : L JB := empty
              for df in reverse r.Entries  for jv in reverse r.Indices repeat
                  if noChecks? or not zero? df then
                      djv := differentiate(jv, i)
                      if djv case "0" then
                         JV := cons(jv, JV)
                      else if djv = 1 then
                          res := res + df
                          JV := cons(jv, JV)
                      else
                          res := res + df*(djv::JB::%)
                          JV := cons(djv, cons(jv, JV))
              LRes := cons(res, LRes)
              JV := sort!(">", removeDuplicates! JV)
              LJV := cons(JV, LJV)

          [reverse! LRes, reverse! LJV]

      formalDiff2(Eq : %, i : PI, JM : SEM) : Record(DPhi : %, JVars : L JB) ==
          tmp := formalDiff2([Eq], i, JM)
          [first tmp.DSys, first tmp.JVars]

      -- -------------- --
      -- Simplification --
      -- -------------- --

      -- The simplification routines can be divided into two classes:
      -- The first one contains reduceMod and autoReduce. They use dSubst
      -- and hence try to reduce the order of the equations. The second
      -- class contains simplify, simpOne and simpMod. They do not use dSubst.
      -- Thus they can also be applied in a geometric framework, where
      -- derivatives are considered as independent variables.

      greater(r1 : LDREC, r2 : LDREC) : B == (r1.LD > r2.LD)
          -- local function for sorting purposes

      sortLD(sys : L %) : L % ==
          sl : L LDREC := [[leadingDer(f), false, [1], f]  for f in sys]
          sl := sort!(greater, sl)
          [l.Fun  for l in sl]

      simpLD(l : L LDREC) : L LDREC ==
          -- assumes l is sorted using greater
          #l < 2 => l
          cur := first l
          l := rest l
          cur.LD ~= first(l).LD => cons(cur, simpLD l)
          eqLD : L LDREC := [cur]
          while not(empty? l) and (cur.LD = (fl : LDREC := first l).LD) repeat
              fl.Fake? => error errmsg
              eqLD := cons(fl, eqLD)
              l := rest l

          -- try to solve one equation and substitute in the other ones
          solvable? : B := false
          for eq in eqLD  until solvable? repeat
              s := solveFor(eq.Fun, cur.LD)
              solvable? := (s case %)
              seq := eq
          newL : L LDREC := empty
          if solvable? then
              for eq in eqLD | eq ~= seq repeat
                  neweq := simpOne subst(eq.Fun, cur.LD, s::%)
                  if not zero? neweq then
                      newld := leadingDer neweq
                      newL := merge(greater, newL, _
                        [[newld, false, append(eq.Dep, seq.Dep), neweq]$LDREC])

          else
          -- try to analyse jet variables
              seq := first eqLD
              sj := jetVariables(seq.Fun)
              minlen := #sj
              lJV : L L JB := [sj]
              for eq in rest eqLD repeat
                  JV := jetVariables(eq.Fun)
                  len := #JV
                  lJV := cons(JV, lJV)
                  if len < minlen then
                      seq := eq
                      sj := JV
                      minlen := len
              lJV := reverse! lJV
              if one? minlen then
                  for eq in eqLD  for JV in lJV  | eq ~= seq repeat
                      one?(#JV) => error errmsg
                      newL := merge(greater, newL, _
                                    [[second(JV), true, eq.Dep, eq.Fun]$LDREC])
              else
                  sjv := second sj
                  for eq in eqLD  for JV in lJV  | eq ~= seq repeat
                      newld := max(second(JV), sjv)
                      newL := merge(greater, newL,
                                    [[newld, true, eq.Dep, eq.Fun]$LDREC])

          cons(seq, simpLD merge(greater, l, newL))

      simplify(sys : L %, jm : SEM) : SIMPREC ==
          -- Tries to get as far as possible by analysing leading derivatives
          -- Will give an error if there are dependent equations in sys
          newSys : L % := empty
          for eq in sys  for i in 1.. repeat
              neq := simpOne eq
              if neq ~= eq then
                  jmi := jacobiMatrix([neq])
                  setRow!(jm, i, row(jmi, 1))
              newSys := cons(neq, newSys)
          newSys := reverse! newSys
          sl : L LDREC := [[first(row(jm, i).Indices), false, [i::NNI], f] _
                              for f in newSys  for i in 1..]
          sl := simpLD sort!(greater, sl)
          resSys := [l.Fun  for l in sl]
          resDep := [l.Dep  for l in sl]

          -- adjust Jacobi matrix
          inds := allIndices jm
          resJM : SEM := new(inds, #sl)
          for eq in resSys  for dep in resDep  for i in 1.. repeat
              if one?(#dep) then
                  r := row(jm, first(dep))
              else
                  tmp := jacobiMatrix([eq], [inds])
                  r := row(tmp, 1)
              setRow!(resJM, i, r)

          [resSys, resJM, resDep]

      simpOne(f : %) : % == numerator f

      -- The default implementations of simpMod and reduceMod are almost
      -- identical. The only difference lies in the use of subst and dSubst,
      -- respectively.

      simpMod(sys1 : L %, sys2 : L %) : L % ==
          -- Default implementation uses only the equation of sys2 which can be
          -- solved for their leading derivatives. It further assumes that sys2
          -- is already simplified and reduced.
          empty?(sys1) or empty?(sys2) => sys1
          LD : L JB := empty
          LS : L % := empty

          for eq2 in sys2 repeat
              ld := leadingDer eq2
              ls := solveFor(eq2, ld)
              if ls case % then
                  i : NNI := 1
                  for jv in LD while jv > ld repeat
                      i := i + 1
                  LD := insert(ld, LD, i)
                  LS := insert(ls::%, LS, i)

          newSys : L % := map(simpOne@(% -> %), sys1)$L(%)
          empty? LD => newSys
          res : L % := empty
          for eq1 in newSys repeat
              neq := eq1
              LD1 : L JB := LD
              LS1 : L % := LS
              until empty? LD1 repeat
                  ld := leadingDer neq
                  while not empty? LD1 and first(LD1) > ld repeat
                      LD1 := rest LD1
                      LS1 := rest LS1
                  if not empty? LD1 then
                      neq := subst(neq, first LD1, first LS1)
                      LD1 := rest LD1
                      LS1 := rest LS1
              if neq ~= eq1 then
                  neq := simpOne neq
              if not zero? neq then
                  res := cons(neq, res)

          sortLD reverse! res

      simpMod(sys1 : L %, jm : SEM, sys2 : L %) : SIMPREC ==
          -- Default implementation uses only the equation of sys2 which
          -- can be solved for their leading derivatives.  It further
          -- assumes that sys2 is already simplified and reduced.
          empty?(sys1) or empty?(sys2) =>
              [sys1, jm, [[i::NNI] for i in 1..#sys1]]
          --print("simpMod")$OUT
          osys := sys1
          LD : L JB := empty
          LS : L % := empty

          for eq2 in sys2 repeat
              ld := leadingDer eq2
              ls := solveFor(eq2, ld)
              if ls case % then
                  i : NNI := 1
                  for jv in LD while jv > ld repeat
                      i := i + 1
                  LD := insert(ld, LD, i)
                  LS := insert(ls::%, LS, i)

          newSys : L % := map(simpOne, sys1)
          res : L % := empty
          for eq1 in newSys repeat
              neq := eq1
              LD1 : L JB := LD
              LS1 : L % := LS
              until empty? LD1 repeat
                  ld := leadingDer neq
                  while not empty? LD1 and first(LD1) > ld repeat
                      LD1 := rest LD1
                      LS1 := rest LS1
                  if not empty? LD1 then
                      neq := subst(neq, first LD1, first LS1)
                      LD1 := rest LD1
                      LS1 := rest LS1
              if neq ~= eq1 then
                  neq := simpOne neq
              res := cons(neq, res)

          resSys : L % := empty
          resJM := jm
          for neq in res  for oeq in reverse! osys  for i in #res..1 by -1 repeat
              if neq ~= oeq then
                  njm := jacobiMatrix([neq])
                  setRow!(resJM, i, row(njm, 1))
              resSys := cons(neq, resSys)
          --print("END simpMod")$OUT
          [resSys, resJM, [[i::NNI] for i in 1..#resSys]]

      reduceMod(sys1 : L %, sys2 : L %) : L % ==
          -- Default implementation uses only the equation of sys2 which can
          -- be solved for their leading derivatives. It further assumes that
          -- sys2 is already simplified and reduced.
          empty?(sys1) or empty?(sys2) => sys1
          --print("reduceMod")$OUT
          LD : L JB := empty
          LS : L % := empty

          for eq2 in sys2 repeat
              ld := leadingDer eq2
              ls := solveFor(eq2, ld)
              if ls case % then
                  i : NNI := 1
                  for jv in LD while jv > ld repeat
                      i := i + 1
                  LD := insert(ld, LD, i)
                  LS := insert(ls::%, LS, i)

          newSys := map(simpOne, sys1)
          empty? LD => newSys
          res : L % := empty
          for eq1 in newSys repeat
              eq := eq1
              oeq : % := 0
              neq : % := eq1

              while neq ~= oeq repeat
                  oeq := neq
                  LD1 : L JB := LD
                  LS1 : L % := LS
                  until empty? LD1 repeat
                      ld := leadingDer neq
                      while not(empty? LD1) and first(LD1) > ld repeat
                          LD1 := rest LD1
                          LS1 := rest LS1
                      if not empty? LD1 then
                          neq := dSubst(neq, first LD1, first LS1)
                          LD1 := rest LD1
                          LS1 := rest LS1
              if not zero? neq then
                  if neq = eq then
                      res := cons(neq, res)
                  else
                      res := cons(simpOne neq, res)

          --print("END reduceMod")$OUT
          sortLD reverse! res

      autoReduce(sys : L %) : L % ==
          -- Equations which can not be solved for their leading derivatives
          -- are kept in a special list. May be they become solvable after
          -- some other simplifications ...
          empty? sys => empty
          one?(#sys) => sys
          --print("autoReduce")$OUT

          nl : L % := map(simpOne, sys)   -- new equations
          nsl : L % := empty               -- unsolved equations
          sl : L LDREC := empty          -- solved equations
          osl := sl                            -- old value of sl

          while not empty? nl repeat

              -- try to solve new equations
              for eq in nl repeat
                  ld := leadingDer eq
                  su := solveFor(eq, ld)
                  if su case "failed" then
                      nsl := cons(eq, nsl)
                  else
                      sl := merge!(greater, sl, [[ld, true, empty, su::%]])
              nl := empty

              -- reduce solved equations
              osl := empty
              sl := reverse! sl          -- now ordered smallest ld first
              while not empty? sl repeat
                  sub := first sl
                  osl := cons(sub, osl)
                  sl := rest sl

                  -- check for integrability conditions
                  while not(empty? sl) repeat
                      rec := first sl
                      rec.LD > sub.LD => break
                      sl := rest sl
                      ic := simpOne(rec.Fun - sub.Fun)
                      if not zero? ic then
                          nl := cons(ic, nl)

                  tmp : L LDREC := empty
                  for rec in sl repeat
                      d := derivativeOf?(rec.LD , sub.LD)
                      if empty? d then
                          seq := dSubst(rec.Fun, sub.LD, sub.Fun)
                          tmp := cons([rec.LD, true, empty, seq], tmp)
                      else
                          ic := dSubst(formalDiff(sub.Fun, d) - _
                                       rec.Fun, sub.LD, sub.Fun)
                          ic := simpOne ic
                          if not zero? ic then
                              nl := cons(ic, nl)
                  sl := reverse! tmp
              sl := osl                      -- now ordered largest first

              -- reduce unsolved equations
              ol : L % := empty
              for eq in nsl repeat
                  seq := eq
                  for sub in sl repeat
                      seq := dSubst(seq, sub.LD, sub.Fun)
                  if seq = eq then
                      ol := cons(eq, ol)
                  else
                      if not zero? seq then
                          nl := cons(simpOne seq, nl)
              nsl := ol

              -- reduce new equations
              ol : L % := empty
              for eq in nl repeat
                  seq := eq
                  for sub in sl repeat
                      seq := dSubst(seq, sub.LD, sub.Fun)
                  if not zero? seq then
                      ol := cons(simpOne seq, ol)
              nl := ol

          -- recombine lists
          tmp1 := [[leadingDer(eq), true, empty, eq]  for eq in nsl]
          tmp2 := [[rec.LD, true, empty, simpOne(rec.LD::% - rec.Fun)] _
                        for rec in sl]
          tmp1 := sort!(greater, concat!(tmp1, tmp2))
          --print("END autoReduce")$OUT
          [rec.Fun  for rec in tmp1]

)abbrev category JBBFC JetBundleBaseFunctionCategory
++ Description:
++ \spadtype{JetBundleBaseFunctionCategory} defines the category of functions
++ (local sections) of the base space of a jet bundle, i.e. functions
++ depending only on the independent variables. Such a category is needed
++ e.g. for the representation of solutions.

JetBundleBaseFunctionCategory(JB : JBC) : Category == Def where

  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  B    ==> Boolean
  L    ==> List
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory JB
  SEM  ==> SparseEchelonMatrix(JB, %)

  SIMPREC ==> Record(Sys : L %, JM : SEM, Depend : Union("failed", L L NNI))
  LDREC   ==> Record(LD : JB, Fake? : B, Dep : L NNI, Fun : %)

  errmsg ==> "Only functions of independent variables allowed"

  Def ==> JBFC add

    U(i : PI) : % == error errmsg

    U() : % == error errmsg

    P(i : PI, l : L NNI) : % == error errmsg

    P(l : L NNI) : % == error errmsg

    P(i : PI, l : NNI) : % == error errmsg

    P(i : NNI) : % == error errmsg


)abbrev domain SEM SparseEchelonMatrix
++ Description:
++  \spad{SparseEchelonMatrix(C, D)} implements sparse matrices whose columns
++  are enumerated by the \spadtype{OrderedSet} \spad{C} and whose entries
++  belong to the \spadtype{GcdDomain} \spad{D}. The basic operation of
++  this domain is the computation of an row echelon form. The used algorithm
++  tries to maintain the sparsity and is especially adapted to matrices who
++  are already close to a row echelon form.

SparseEchelonMatrix(C : OrderedSet, D : Ring) : Cat == Def where

  Sy  ==> Symbol
  L   ==> List
  V   ==> Vector
  VD  ==> Vector D
  MD  ==> Matrix D
  FD  ==> Fraction D
  MFD ==> Matrix FD
  I   ==> Integer
  NNI ==> NonNegativeInteger
  B   ==> Boolean
  OUT ==> OutputForm

  ROWREC ==> Record(Indices : L C, Entries : L D)

  iter ==> "iterated"::Sy
  rand ==> "random"::Sy

  Cat ==> CoercibleTo OUT with

    shallowlyMutable
      ++ Matrices may be altered destructively.

    finiteAggregate
      ++ Matrices are finite.

    coerce : % -> MD
      ++ \spad{coerce(A)} yields the matrix \spad{A} in the usual matrix type.

    copy : % -> %
      ++ \spad{copy(A)} returns a copy of the matrix \spad{A}.

    ncols : % -> NNI
      ++ \spad{ncols(A)} returns the number of columns of the matrix \spad{A}.

    nrows : % -> NNI
      ++ \spad{nrows(A)} returns the number of rows of the matrix \spad{A}.

    allIndices : % -> L C
      ++ \spad{allIndices(A)} returns all indices used for enumerating the
      ++ columns of the matrix \spad{A}.

    elimZeroCols! : % -> Void
      ++ \spad{elimZeroCols!(A)} removes columns which contain only zeros.
      ++ This effects basically only the value of \spad{allIndices(A)}.

    purge! : (%, C-> B) -> Void
      ++ \spad{purge!(A, crit)} eliminates all columns belonging to an index
      ++ \spad{c} such that \spad{crit(c)} yields \spad{true}.

    sortedPurge! : (%, C-> B) -> Void
      ++ \spad{sortedPurge!(A, crit)} is like \spad{purge}, however, with the
      ++ additional assumption that \spad{crit} respects the ordering of the
      ++ indices.

    new : (L C, I) -> %
      ++ \spad{new(inds, nrows)} generates a new matrix with \spad{nrows}
      ++ rows and columns enumerated by the indices \spad{inds}. The matrix
      ++ is empty, i.e. the zero matrix.

    elt : (%, I, C) -> D
      ++ \spad{elt(A, i, c)} returns the entry of the matrix \spad{A} in row
      ++ \spad{i} and in the column with index \spad{c}.

    setelt! : (%, I, C, D) -> Void
      ++ \spad{setelt!(A, i, c, d)} sets the entry of the matrix \spad{A} in
      ++ row \spad{i} and in the column with index \spad{c} to the value
      ++ \spad{d}.

    row : (%, I) -> ROWREC
      ++ \spad{row(A, i)} returns the \spad{i}-th row of the matrix \spad{A}.

    setRow! : (%, I, ROWREC) -> Void
      ++ \spad{setRow!(A, i, ind, ent)} sets the \spad{i}-th row of the matrix
      ++ \spad{A} to the value \spad{r}.

    setRow! : (%, I, L C, L D) -> Void
      ++ \spad{setRow!(A, i, ind, ent)} sets the \spad{i}-th row of the matrix
      ++ \spad{A}. Its indices are \spad{ind}; the entries \spad{ent}.

    deleteRow! : (%, I) -> Void
      ++ \spad{deleteRow(A, i)} deletes the \spad{i}-th row of the matrix
      ++ \spad{A}.

    consRow! : (%, ROWREC) -> Void
      ++ \spad{consRow!(A, r)} inserts the row \spad{r} at the top of the
      ++ matrix \spad{A}.

    appendRow! : (%, ROWREC) -> Void
      ++ \spad{appendRow!(A, r)} appends the row \spad{r} at the end of the
      ++ matrix \spad{A}.

    extract : (%, I, I) -> %
      ++ \spad{extract(A, i1, i2)} extracts the rows \spad{i1} to \spad{i2}
      ++ and returns them as a new matrix.

    rowEchelon : % -> Record(Ech : %, Lt : MD, Pivots : L D, Rank : NNI)
      ++ \spad{primitiveRowEchelon(A)} computes a row echelon form for the
      ++ matrix \spad{A}. The algorithm used is fraction-free elimination.
      ++ It is especially adapted to matrices already close to row echelon
      ++ form. The transformation matrix, the used pivots and the rank of the
      ++ matrix are also returned.

    if D has GcdDomain then

      setGcdMode : Sy -> Sy
        ++ \spad{setGcdMode(s)} sets a new value for the flag deciding on
        ++ the method used to compute gcd`s for lists. Possible values for
        ++ \spad{s} are \spad{iterated} and \spad{random}.

      primitiveRowEchelon : % -> Record(Ech : %, Lt : MFD, Pivots : L D, Rank : NNI)
        ++ \spad{primitiveRowEchelon(A)} computes a row echelon form for the
        ++ matrix \spad{A}. The algorithm used is fraction-free elimination.
        ++ Every row is made primitive by division by the gcd. The algorithm
        ++ is especially adapted to matrices already close to row echelon
        ++ form. The transformation matrix, the used pivots and the rank of the
        ++ matrix are also returned.

    pivot : (%, I) -> Record(Index : C, Entry : D)
      ++ \spad{pivot(A, i)} returns the leading entry of the \spad{i}-th row
      ++ of the matrix \spad{A} together with its index.

    pivots : % -> ROWREC
      ++ \spad{pivots(A)} returns all leading entries of the matrix \spad{A}
      ++ together with their indices.

    "*" : (MD, %) -> %
      ++ \spad{L*A} implements left multiplication with a usual matrix.

    if D has IntegralDomain then

      "*" : (MFD, %) -> %
        ++ \spad{L*A} implements left multiplication with a usual matrix over
        ++ the quotient field of \spad{D}.

    join : (%, %) -> %
      ++ \spad{join(A, B)} vertically concats the matrices \spad{A} and
      ++ \spad{B}.

    horizJoin : (%, %) -> %
      ++ \spad{horizJoin(A, B)} horizontally concats the matrices \spad{A} and
      ++ \spad{B}. It is assumed that all indices of \spad{B} are smaller than
      ++ those of \spad{A}.

    horizSplit : (%, C) -> Record(Left : %, Right : %)
      ++ \spad{horizSplit(A, c)} splits the matrix \spad{A} into two at the
      ++ column given by \spad{c}. The first column of the right matrix is
      ++ enumerated by the first index less or equal to \spad{c}.

  Def ==> add

    minInd : I := minIndex([i for i in 1..1])
    offset : I := minInd-1
    emptyRec : ROWREC := [empty, empty]
    noChecks? : B := D has lazyRepresentation  -- flag for lazy representation
    seed : I := 113                   -- seed for random number generation
    GCDmode : Sy := iter              -- flag for gcd algorithm

    greater(r1 : ROWREC, r2 : ROWREC) : B ==
        empty? r1.Indices => false
        empty? r2.Indices => true
        first(r2.Indices) < first(r1.Indices)

    -- -------------- --
    -- Representation --
    -- -------------- --

    -- For efficiency reasons most checks for correct index ranges are omitted.

    Rep := Record(NCols : NNI, NRows : NNI, AllInds : L C, Rows : V ROWREC)

    ncols(A : %) : NNI == A.NCols

    nrows(A : %) : NNI == A.NRows

    allIndices(A : %) : L C == copy A.AllInds

    row(A : %, i : I) : ROWREC ==
        -- i < 0 or i > A.NRows => error "index out of range"
        qelt(A.Rows, i)

    setRow!(A : %, i : I, r : ROWREC) : Void ==
        -- i < 0 or i > A.NRows => error "index out of range"
        qsetelt!(A.Rows, i, r)
        void

    setRow!(A : %, i : I, inds : L C, ents : L D) : Void ==
        -- i < 0 or i > A.NRows => error "index out of range"
        -- #inds  ~=  #ents => error "improper row"
        qsetelt!(A.Rows, i, [inds, ents])
        void

    new(inds : L C, n : I) : % ==
        [#inds, n::NNI, inds, [copy emptyRec  for i in 1..n]]

    elt(A : %, i : I, c : C) : D ==
        r := row(A, i)
        pos := position(c, r.Indices)
        pos < minInd => 0$D
        qelt(r.Entries, pos)

    setelt!(A : %, i : I, c : C, d : D) : Void ==
        r := row(A, i)
        pos := position(c, r.Indices)
        if pos >= minInd then
            qsetelt!(r.Entries, pos, d)
        else
            j := minInd
            for ind in r.Indices  while c < ind repeat
                j := j+1
            r.Indices := insert!(c, r.Indices, j)
            r.Entries := insert!(d, r.Entries, j)
        qsetelt!(A.Rows, i, r)
        void

    coerce(A : %) : MD ==
        zero? A.NCols => error "cannot coerce matrix with zero columns"
        AA : MD := new(A.NRows, A.NCols, 0$D)
        for r in entries(A.Rows)  for i in minRowIndex(AA).. repeat
            inds := r.Indices
            ents := r.Entries
            for ind in A.AllInds  for j in minColIndex(AA).. _
                    while not empty? inds repeat
                if ind = first inds then
                    qsetelt!(AA, i, j, first ents)
                    inds := rest inds
                    ents := rest ents
        AA

    coerce(A : %) : OUT ==
        zero? A.NCols => 0$D ::OUT
        A::MD::OUT

    copy(A : %) : % ==
        resRows : V ROWREC := new(A.NRows, emptyRec)
        for l in 1..A.NRows repeat
            r := qelt(A.Rows, l)
            qsetelt!(resRows, l, [copy r.Indices, copy r.Entries])
        [A.NCols, A.NRows, copy A.AllInds, resRows]

    -- ----------------------- --
    -- Basic Matrix Operations --
    -- ----------------------- --

    elimZeroCols!(A : %) : Void ==
        newInds : L C := empty
        for r in entries(A.Rows) repeat
            newInds := removeDuplicates! merge!((x, y) +-> y < x,
                                                newInds, r.Indices)
        A.AllInds := newInds
        void

    purge!(A : %, crit : C-> B) : Void ==
        newInds : L C := empty
        for c in A.AllInds repeat
            if not crit c then
                newInds := cons(c, newInds)
        newInds := reverse! newInds
        if #newInds  ~=  #A.AllInds then
            A.AllInds := newInds
            for l in 1..A.NRows repeat
                r := qelt(A.Rows, l)
                newInds : L C := empty
                newEnts : L D := empty
                for c in r.Indices   for e in r.Entries repeat
                    if not crit c then
                        newInds := cons(c, newInds)
                        newEnts := cons(e, newEnts)
                qsetelt!(A.Rows, l, [reverse! newInds, reverse! newEnts])
        void

    sortedPurge!(A : %, crit : C-> B) : Void ==
        if crit first A.AllInds then
            while not(empty? A.AllInds) and crit first A.AllInds repeat
                A.AllInds := rest A.AllInds
            for l in 1..A.NRows repeat
                r := qelt(A.Rows, l)
                while not(empty? r.Indices) and crit first r.Indices repeat
                    r.Indices := rest r.Indices
                    r.Entries := rest r.Entries
                qsetelt!(A.Rows, l, r)
        void

    deleteRow!(A : %, i : I) : Void ==
        i > A.NRows => A
        nr := (A.NRows-1)::NNI
        resRows : V ROWREC := new(nr, emptyRec)
        for l in 1..(i-1) repeat
            qsetelt!(resRows, l, qelt(A.Rows, l))
        for l in (i+1)..A.NRows repeat
            qsetelt!(resRows, l-1, qelt(A.Rows, l))
        A.NRows := nr
        A.Rows := resRows
        void

    consRow!(A : %, r : ROWREC) : Void ==
        A.NRows := A.NRows + 1
        newRows : L ROWREC := cons(r, entries A.Rows)
        A.Rows := construct newRows
        newInds := setDifference(r.Indices, A.AllInds)
        if not empty? newInds then
            A.AllInds := merge((x, y) +-> y < x, A.AllInds,
                               sort!((x, y) +-> y < x, newInds))
        void

    appendRow!(A : %, r : ROWREC) : Void ==
        A.NRows := A.NRows + 1
        newRows : L ROWREC := concat(entries A.Rows, r)
        A.Rows := construct newRows
        newInds := setDifference(r.Indices, A.AllInds)
        if not empty? newInds then
            A.AllInds := merge((x, y) +-> y < x, A.AllInds,
                               sort!((x, y) +-> y < x, newInds))
        void

    extract(A : %, i1 : I, i2 : I) : % ==
        nr := (i2-i1+1)::NNI
        resRows : V ROWREC := new(nr, emptyRec)
        newInds : L C := empty
        for i in i1..i2 repeat
            qsetelt!(resRows, i-i1+1, row(A, i))
            newInds := removeDuplicates! merge((x, y) +-> y < x,
                                               newInds, row(A, i).Indices)
        [A.NCols, nr, newInds, resRows]

    join(A1 : %, A2 : %) : % ==
        newInds := removeDuplicates! merge((x : C, y : C) : Boolean +-> y < x,
                                           A1.AllInds, A2.AllInds)
        newNRows := A1.NRows + A2.NRows
        newRows : V ROWREC := new(newNRows, emptyRec)
        for l in 1..A1.NRows repeat
            qsetelt!(newRows, l, qelt(A1.Rows, l))
        for l in 1..A2.NRows repeat
            qsetelt!(newRows, A1.NRows+l, qelt(A2.Rows, l))
        [#newInds, newNRows, newInds, newRows]

    horizJoin(A1 : %, A2 : %) : % ==
        A1.NRows ~= A2.NRows => error "incompatible dimensions in horizJoin"
        newInds := append(A1.AllInds, A2.AllInds)
        res : % := new(newInds, A1.NRows)
        for i in 1..A1.NRows repeat
            r1 := row(A1, i)
            r2 := row(A2, i)
            setRow!(res, i, append(r1.Indices, r2.Indices), _
                            append(r1.Entries, r2.Entries))
        res

    horizSplit(A : %, c : C) : Record(Left : %, Right : %) ==
        rinds : L C := allIndices A
        linds : L C := empty
        while not(empty? rinds) and (first(rinds) > c) repeat
            linds := cons(first(rinds), linds)
            rinds := rest rinds
        empty? linds => [new(linds, A.NRows), A]
        linds := reverse! linds
        empty? rinds => [A, new(rinds, A.NRows)]
        LA : % := new(linds, A.NRows)
        RA : % := new(rinds, A.NRows)
        for i in 1..A.NRows repeat
            r := row(A, i)
            ri : L C := r.Indices
            re : L D := r.Entries
            li : L C := empty
            le : L D := empty
            while not(empty? ri) and (first(ri) > c) repeat
                li := cons(first(ri), li)
                le := cons(first re, le)
                ri := rest ri
                re := rest re
            if not empty? li then
                li := reverse! li
                le := reverse! le
                setRow!(LA, i, li, le)
            if not empty? ri then
                setRow!(RA, i, ri, re)
        [LA, RA]

    -- ----------- --
    -- Row Echelon --
    -- ----------- --

    addRows(d1 : D, r1 : ROWREC, d2 : D, r2 : ROWREC) : ROWREC ==
        -- Computes linear combination of two rows.
        -- Local function.
        empty? r1.Indices =>
            one? d2 => r2
            [r2.Indices, [d2*e2  for e2 in r2.Entries]]
        empty? r2.Indices =>
            one? d1 => r1
            [r1.Indices, [d1*e1  for e1 in r1.Entries]]
        resI : L C := empty
        resE : L D := empty
        lent1 : L D
        lent2 : L D
        if not(noChecks?) and one? d1 then
            lent1 := r1.Entries
        else
            lent1 := [d1*e1  for e1 in r1.Entries]
        if not(noChecks?) and one? d2 then
            lent2 := copy r2.Entries
        else
            lent2 := [d2*e2  for e2 in r2.Entries]
        lind2 := copy r2.Indices

        for c1 in r1.Indices  for e1 in lent1 repeat
            while not(empty? lind2) and c1 < first(lind2) repeat
                resI := cons(first lind2, resI)
                resE := cons(first(lent2), resE)
                lind2 := rest lind2
                lent2 := rest lent2
            if not(empty? lind2) and first(lind2) = c1 then
                sum := e1+first(lent2)
                if noChecks? or not zero? sum then
                    resI := cons(c1, resI)
                    resE := cons(sum, resE)
                lind2 := rest lind2
                lent2 := rest lent2
            else
                resI := cons(c1, resI)
                resE := cons(e1, resE)

        resI := concat!(reverse! resI, lind2)
        resE := concat!(reverse! resE, lent2)
        while not(empty? resE) and zero? first resE repeat
            resI := rest resI
            resE := rest resE
        [resI, resE]

    pivot(A : %, i : I) : Record(Index : C, Entry : D) ==
        r := row(A, i)
        empty? r.Indices => error "empty row"
        [first r.Indices, first r.Entries]

    pivots(A : %) : ROWREC ==
        resI : L C := empty
        resE : L D := empty
        for r in entries A.Rows | not empty? r.Indices repeat
            resI := cons(first r.Indices, resI)
            resE := cons(first r.Entries, resE)
        [reverse! resI, reverse! resE]

    rowEchelon(AA : %) : Record(Ech : %, Lt : MD, Pivots : L D, Rank : NNI) ==
        A := copy AA
        LTr : MD := diagonalMatrix [1$D  for i in 1..A.NRows]
        Pivs : L D := empty

        -- check pivots
        for i in 1..A.NRows repeat
            r := qelt(A.Rows, i)
            changed? : B := false
            while not(empty? r.Entries) and zero? first r.Entries repeat
                r.Entries := rest r.Entries
                r.Indices := rest r.Indices
                changed? := true
            if changed? then
                qsetelt!(A.Rows, i, r)

        -- sort rows by pivots (bubble sort)
        sorted? : B := false
        until sorted? repeat
            sorted? := true
            oldr := qelt(A.Rows, 1)
            for i in 2..A.NRows repeat
                newr := qelt(A.Rows, i)
                if greater(newr, oldr) then
                    qsetelt!(A.Rows, i, oldr)
                    qsetelt!(A.Rows, i-1, newr)
                    swapRows!(LTr, i-1, i)
                    sorted? := false
                else
                    oldr := newr

        -- fraction-free elimination
        finished? : B := false
        pivlen, pivrow, rk : NNI
        for i in 1..A.NRows  until finished? repeat
            r := qelt(A.Rows, i)
            finished? := empty? r.Indices
            if finished? then
                rk : NNI := (i-1)::NNI
            else                         -- search good pivot
                pivind := first r.Indices
                pivlen := #r.Indices
                pivrow := i
                k : I := 0
                for j in (i+1)..A.NRows _
                        while not(empty? qelt(A.Rows, j).Indices) and _
                            pivind = first(qelt(A.Rows, j).Indices) repeat
                    len := #qelt(A.Rows, j).Indices
                    k := k+1
                    if len < pivlen then
                        pivlen := len
                        pivrow := j
                piv : D := first qelt(A.Rows, pivrow).Entries
                Pivs := cons(piv, Pivs)

                -- elimination necessary?
                if k > 0 then
                    if pivrow ~= i then
                        pr := qelt(A.Rows, pivrow)
                        qsetelt!(A.Rows, pivrow, qelt(A.Rows, i))
                        qsetelt!(A.Rows, i, pr)
                        swapRows!(LTr, i, pivrow)

                    -- elimination (and resorting of rows)
                    pr := copy qelt(A.Rows, i)
                    pr.Indices := rest pr.Indices
                    pr.Entries := rest pr.Entries
                    for j in (i+1)..(i+k) repeat
                        r := copy qelt(A.Rows, i+1)
                        c := first r.Entries
                        r.Indices := rest r.Indices
                        r.Entries := rest r.Entries
                        r := addRows(piv, r, -c, pr)
                        for l in 1..A.NRows repeat
                            f := piv*qelt(LTr, i+1, l) - c*qelt(LTr, i, l)
                            qsetelt!(LTr, i+1, l, f)
                        for l in (i+2)..(2*i+k+1-j) repeat
                            qsetelt!(A.Rows, l-1, qelt(A.Rows, l))
                            swapRows!(LTr, l-1, l)
                        for l in (2*i+k+2-j)..A.NRows _
                                while greater(qelt(A.Rows, l), r) repeat
                            qsetelt!(A.Rows, l-1, qelt(A.Rows, l))
                            swapRows!(LTr, l-1, l)
                        qsetelt!(A.Rows, l-1, r)

        if not finished? then
            rk : NNI := A.NRows
        [A, LTr, Pivs, rk]

    if D has GcdDomain then

        setGcdMode(s : Sy) : Sy ==
            tmp := GCDmode
            (s = iter) or (s = rand) =>
                GCDmode := s
                tmp
            error "unknown gcd mode"

        randomGCD(le : L D) : D ==
            -- Probabilistic technique.
            #le = 2 => gcd(first le, second le)
            f := first le
            g := second le
            l := rest rest le
            while not empty? l repeat
                one? first l => return 1$D
                f := f + (1+random(113)$I)*first(l)
                l := rest l
                if not empty? l then
                    one? first l => return 1$D
                    g := g + (1+random(113)$I)*first(l)
                    l := rest l
            h := gcd(f, g)
            l := [h]
            for e in le repeat
                tmp := e exquo h
                if tmp case "failed" then
                    l := cons(e, l)
            one?(#l) => h
            randomGCD l

        iteratedGCD(le : L D) : D ==
            -- Computes gcd iteratively
            res := gcd(first le, second le)
            l := rest rest le
            while not(empty?(l) or one?(res)) repeat
                res := gcd(res, first l)
                l := rest l
            res

        makePrimitive(r : ROWREC) : Record(GCD : D, Row : ROWREC) ==
            -- remove common gcd of row
            le := r.Entries
            one?(#le) => [first le, [r.Indices, [1$D]]]
            g : D
            if GCDmode = 'iterated then
                g := iteratedGCD le
            else
                g := randomGCD le
            one? g => [1, r]
            le := [(e exquo g)::D  for e in le]
            [g, [r.Indices, le]]

        primitiveRowEchelon(AA : %) : _
                Record(Ech : %, Lt : MFD, Pivots : L D, Rank : NNI) ==
            A := copy AA
            LTr : MFD := diagonalMatrix [1$FD  for i in 1..A.NRows]
            Pivs : L D := empty

            -- check pivots
            for i in 1..A.NRows repeat
                r := qelt(A.Rows, i)
                changed? : B := false
                while not(empty? r.Entries) and zero? first r.Entries repeat
                    r.Entries := rest r.Entries
                    r.Indices := rest r.Indices
                    changed? := true
                if changed? then
                    qsetelt!(A.Rows, i, r)

            -- sort rows by pivots (bubble sort)
            sorted? : B := false
            until sorted? repeat
                sorted? := true
                oldr := qelt(A.Rows, 1)
                for i in 2..A.NRows repeat
                    newr := qelt(A.Rows, i)
                    if greater(newr, oldr) then
                        qsetelt!(A.Rows, i, oldr)
                        qsetelt!(A.Rows, i-1, newr)
                        swapRows!(LTr, i-1, i)
                        sorted? := false
                    else
                        oldr := newr

            -- primitive fraction-free elimination
            finished? : B := false
            pivlen, pivrow, rk : NNI
            for i in 1..A.NRows  until finished? repeat
                r := qelt(A.Rows, i)
                finished? := empty? r.Indices
                if finished? then
                    rk : NNI := (i-1)::NNI
                else                          -- search good pivot
                    pivind := first r.Indices
                    pivlen := #r.Indices
                    pivrow := i
                    k : I := 0
                    for j in (i+1)..A.NRows _
                            while not(empty? qelt(A.Rows, j).Indices) and _
                              pivind = first(qelt(A.Rows, j).Indices) repeat
                        len := #qelt(A.Rows, j).Indices
                        k := k+1
                        if len < pivlen then
                            pivlen := len
                            pivrow := j

                    -- make row primitive
                    tmp := makePrimitive qelt(A.Rows, pivrow)
                    if not one? tmp.GCD then
                        qsetelt!(A.Rows, pivrow, tmp.Row)
                        q : FD := 1/tmp.GCD
                        for l in 1..A.NRows | not zero? qelt(LTr, pivrow, l) _
                                repeat
                            qsetelt!(LTr, pivrow, l, q*qelt(LTr, pivrow, l))
                    piv : D := first qelt(A.Rows, pivrow).Entries
                    Pivs := cons(piv, Pivs)

                    -- elimination necessary?
                    if k > 0 then
                        if pivrow ~= i then
                            pr := qelt(A.Rows, pivrow)
                            qsetelt!(A.Rows, pivrow, qelt(A.Rows, i))
                            qsetelt!(A.Rows, i, pr)
                            swapRows!(LTr, i, pivrow)

                        -- elimination (and resorting of rows)
                        pr := copy tmp.Row
                        pr.Indices := rest pr.Indices
                        pr.Entries := rest pr.Entries
                        for j in (i+1)..(i+k) repeat
                            r := copy qelt(A.Rows, i+1)
                            c := first r.Entries
                            r.Indices := rest r.Indices
                            r.Entries := rest r.Entries
                            r := addRows(piv, r, -c, pr)
                            for l in 1..A.NRows repeat
                                fd : FD := piv *$FD qelt(LTr, i+1, l) - _
                                           (c*qelt(LTr, i, l))::FD
                                qsetelt!(LTr, i+1, l, fd)
                            for l in (i+2)..(2*i+k+1-j) repeat
                                qsetelt!(A.Rows, l-1, qelt(A.Rows, l))
                                swapRows!(LTr, l-1, l)
                            for l in (2*i+k+2-j)..A.NRows _
                                    while greater(qelt(A.Rows, l), r) repeat
                                qsetelt!(A.Rows, l-1, qelt(A.Rows, l))
                                swapRows!(LTr, l-1, l)
                            qsetelt!(A.Rows, l-1, r)

            if not finished? then
                rk : NNI := A.NRows
            [A, LTr, Pivs, rk]

    -- -------------- --
    -- Multiplication --
    -- -------------- --

    LM : MD * AA : % ==
        ncols(LM) ~= AA.NRows => error "improper matrix dimensions"
        A := copy AA
        rlen := nrows LM
        res : % := new(A.AllInds, rlen)

        for c in A.AllInds repeat
            tmp : V D := new(rlen, 0$D)
            for i in 1..A.NRows repeat
                r := qelt(A.Rows, i)
                inds := r.Indices
                if not(empty? inds) and first(inds) = c then
                    for k in 1..rlen | not zero? qelt(LM, k, i) repeat
                        qsetelt!(tmp, k, qelt(tmp, k) + qelt(LM, k, i)* _
                                 first(r.Entries))
                    r.Entries := rest r.Entries
                    r.Indices := rest inds
                    qsetelt!(A.Rows, i, r)
            for k in 1..rlen | not zero? qelt(tmp, k) repeat
                r := qelt(res.Rows, k)
                r.Indices := cons(c, r.Indices)
                r.Entries := cons(qelt(tmp, k), r.Entries)
                qsetelt!(res.Rows, k, r)

        for k in 1..rlen repeat
            r := qelt(res.Rows, k)
            r.Indices := reverse! r.Indices
            r.Entries := reverse! r.Entries
            qsetelt!(res.Rows, k, r)
        res

    if D has IntegralDomain then

        mult(f : FD, d : D) : D ==
            res := numer(f)*d
            tmp := res exquo denom(f)
            tmp case "failed" => error "cannot divide in mult"
            tmp::D

        LM : MFD * AA : % ==
            ncols(LM) ~= AA.NRows => error "improper matrix dimensions"
            A := copy AA
            rlen := nrows LM
            res : % := new(A.AllInds, rlen)

            for c in A.AllInds repeat
                tmp : V FD := new(rlen, 0$FD)
                for i in 1..A.NRows repeat
                    r := qelt(A.Rows, i)
                    inds := r.Indices
                    if not(empty? inds) and first(inds) = c then
                        for k in 1..rlen | not zero? qelt(LM, k, i) repeat
                            qsetelt!(tmp, k, qelt(tmp, k) + qelt(LM, k, i)* _
                                     first(r.Entries))
                        r.Entries := rest r.Entries
                        r.Indices := rest inds
                        qsetelt!(A.Rows, i, r)
                for k in 1..rlen | not zero? qelt(tmp, k) repeat
                    d : Union(D, "failed") := retractIfCan qelt(tmp, k)
                    d case "failed" => error "cannot divide in *"
                    r := qelt(res.Rows, k)
                    r.Indices := cons(c, r.Indices)
                    r.Entries := cons(d::D, r.Entries)
                    qsetelt!(res.Rows, k, r)

            for k in 1..rlen repeat
                r := qelt(res.Rows, k)
                r.Indices := reverse! r.Indices
                r.Entries := reverse! r.Entries
                qsetelt!(res.Rows, k, r)
            res

)abbrev domain JBUNDLE JetBundle
++ Description:
++ \spad{JetBundle} implements a jet bundle of arbitrary order with given
++ names for the independent and dependent variables. It supports only
++ repeated index notation.

JetBundle(IVar : LS, DVar : LS) : Cat == Def where

  V    ==> Vector
  B    ==> Boolean
  Sy   ==> Symbol
  BOP  ==> BasicOperator
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  L    ==> List
  LS   ==> List Symbol
  EI   ==> Expression Integer
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory

  Cat ==> JBC with

    coerce : Sy -> %
      ++ \spad{coerce(sy)} allows for the input of jet variables as symbols.
      ++ Yields an error, if the symbol is not contained in \spad{IVar} or
      ++ \spad{DVar}.

    D : (Sy, L Sy) -> %
      ++ \spad{D(U, [X1, ..., Xq])} generates a derivative. \spad{U} must
      ++ be in \spad{DVar}; all other symbols in \spad{IVar}.

  Def ==> add

    errmsg1  ==> "Improper multi-index"
    errmsg2  ==> "Improper upper index"
    errmsg4  ==> "illegal symbol in JetBundle"


    -- some global constants
    nn : NNI := #IVar
    mm : NNI := #DVar

    nameX := construct(IVar)$V(Sy)
    nameU := construct(DVar)$V(Sy)

    Rep := L NNI
      -- The list has length 2 for independent variables, length n+2 for
      -- derivatives and dependent variables. The first entry is zero for 1,
      -- one for independent, two for dependent variables and three for
      -- derivatives.  The second entry is the upper index, the rest the
      -- multi-index.

    setNotation(s : Sy) : Sy ==
        print(message("only repeated index notation possible"))$OUT
        'Repeated

    getNotation() : Sy == 'Repeated

    multiIndex(jv : %) : L NNI == copy rest rest jv::Rep

    index(jv : %) : PI == first(rest jv)::PI

    type(jv : %) : Sy ==
        t := first jv
        zero? t => 'Const
        one? t => 'Indep
        t = 2 => 'Dep
        'Deriv

    CheckZeroIndex(il : L NNI) : B ==
        -- Local function; checks, whether multi-index is zero.
        for i in il repeat
            if not zero? i then return false
        true

    X(up : PI) : % ==
        up > nn => error errmsg2
        [1, up::NNI]

    U(up : PI) : % ==
        up > mm => error errmsg2
        cons(2, cons(up::NNI, [0$NNI  for i in 1..nn]))

    Pm(up : PI, lo : L NNI) : % ==
        up > mm => error errmsg2
        #lo ~= nn => error errmsg1
        CheckZeroIndex(lo) => U(up)
        cons(3, cons(up::NNI, lo))

    coerce(s : Sy) : % ==
        pos := position(s, IVar)
        pos < minIndex(IVar) =>
            pos := position(s, DVar)
            pos < minIndex(DVar) => error errmsg4
            U(pos::PI)
        X(pos::PI)

    D(u : Sy, der : L Sy) : % ==
        up := position(u, DVar)
        up < minIndex(DVar) => error errmsg4
        lower : L PI := empty
        for d in der repeat
            pos := position(d, IVar)
            pos < minIndex(IVar) => error errmsg4
            lower := cons(pos::PI, lower)
        lower := reverse! lower
        Pr(up::PI, lower)

    1 : % == [0, 1]

    numIndVar() : PI == nn::PI

    numDepVar() : PI == mm::PI

    -- ----------- --
    -- Output Form --
    -- ----------- --

    name(jv : %) : Sy ==
        (jt := type(jv)) = 'Const => "1"::Sy
        i := index jv
        jt = 'Indep => qelt(nameX, i)
        jt = 'Dep => qelt(nameU, i)
        mu := repeatedIndex jv
        res := qelt(nameU, i)
        lower : L OUT := empty
        for j in mu repeat
            lower := cons(qelt(nameX, j)::OUT, lower)
        lower := reverse! lower
        subscript(res, lower)

    -- Coerce to Symbol looses all information; therefore
    -- all important data like type and indices are saved
    -- as arguments of an operator

    opdisp(l : L OUT) : OUT == first l

    coerce(jv : %) : EI ==
        -- Name of operator must be unique and the same as jv::Sy
        -- to allow to differentiate and substitute in EI.
        type(jv) = 'Const => 1
        opname : Sy := name jv
        jop := operator(opname)$BOP
        display(jop, opdisp)
        tmp : None := coerce(jv)$NoneFunctions1(%)
        jop := setProperty(jop, "%symbol"::Symbol, tmp)$BOP
        tmp := coerce(weight(jv))$NoneFunctions1(NNI)
        jop := setProperty(jop, "%weight"::Symbol, tmp)$BOP
        tmp := coerce(type(jv))$NoneFunctions1(Sy)
        jop := setProperty(jop, "%jet"::Symbol, tmp)$BOP
        arg : L EI := concat!([opname::EI, index(jv)::EI], _
                              [i::EI  for i in repeatedIndex jv])
        kernel(jop, arg)


)abbrev domain IJB IndexedJetBundle
++ Description:
++ \spadtype{JetBundle} provides the standard implementation for a jet bundle
++ with a given number of dependent and independent variables.

IndexedJetBundle(x, u, p, n, m) : Cat == Def where

  V    ==> Vector
  B    ==> Boolean
  Sy   ==> Symbol
  BOP  ==> BasicOperator
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  L    ==> List
  EI   ==> Expression Integer
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory

  Const    ==> "Const"::Sy
  Indep    ==> "Indep"::Sy
  Dep      ==> "Dep"::Sy
  Deriv    ==> "Deriv"::Sy
  Multi    ==> "Multi"::Sy
  Repeated ==> "Repeated"::Sy
  DerMode  ==> [Multi, Repeated]@L Sy

  x, u, p : Sy
  m, n   : PI

  Cat ==> JBC

  Def ==> add

    errmsg1  ==> "Improper multi-index"
    errmsg2  ==> "Improper upper index"

    Rep := L NNI
      -- The list has length 2 for independent variables, length n+2 for
      -- derivatives and dependent variables. The first entry is zero for 1,
      -- one for independent, two for dependent variables and three for
      -- derivatives.  The second entry is the upper index, the rest the
      -- multi-index.

    notation : Sy := Repeated
      -- Global variable for notation.

    setNotation(s : Sy) : Sy ==
        not member?(s, DerMode) => error "Unknown notation"
        t := notation
        notation := s
        t

    getNotation() : Sy == notation

    multiIndex(jv : %) : L NNI == copy rest rest jv::Rep

    index(jv : %) : PI == first(rest jv)::PI

    type(jv : %) : Sy ==
        t := first jv
        zero? t => Const
        one? t => Indep
        t = 2 => Dep
        Deriv

    CheckZeroIndex(il : L NNI) : B ==
        -- Local function; checks, whether multi-index is zero.
        for i in il repeat
            if not zero? i then return false
        true

    X(up : PI) : % ==
        up > n => error errmsg2
        [1, up::NNI]

    U(up : PI) : % ==
        up > m => error errmsg2
        cons(2, cons(up::NNI, [0$NNI  for i in 1..n]))

    Pm(up : PI, lo : L NNI) : % ==
        up > m => error errmsg2
        #lo ~= n => error errmsg1
        CheckZeroIndex(lo) => U(up)
        cons(3, cons(up::NNI, lo))

    1 : % == [0, 1]

    numIndVar() : PI == n

    numDepVar() : PI == m

    -- ----------- --
    -- Output Form --
    -- ----------- --

    name(jv : %) : Sy ==
        (jt := type(jv)) = Const => "1"::Sy
        jt = Indep =>
            n > 1 => superscript(x, [index(jv)::OUT])
            x
        jt = Dep =>
            m > 1 => superscript(u, [index(jv)::OUT])
            u
        getNotation() = Multi =>
            m > 1 => script(p, _
                   [[bracket [i::OUT  for i in multiIndex jv]], _
                    [index(jv)::OUT], [], [], []])
            subscript(p, _
                      [bracket [i::OUT  for i in multiIndex jv]])
        m > 1 => script(p, _
                   [[blankSeparate [j::OUT  for j in repeatedIndex jv]], _
                    [index(jv)::OUT], [], [], []])
        subscript(p, [blankSeparate [j::OUT  for j in repeatedIndex jv]])

    -- Coerce to Symbol looses all information; therefore
    -- all important data like type and indices are saved
    -- as arguments of an operator

    opdisp(l : L OUT) : OUT == first l

    coerce(jv : %) : EI ==
        -- Name of operator must be unique and the same as jv::Sy
        -- to allow to differentiate and substitute in EI.
        type(jv) = Const => 1
        opname : Sy := name jv
        jop := operator(opname)$BOP
        display(jop, opdisp)
        tmp : None := coerce(jv)$NoneFunctions1(%)
        jop := setProperty(jop, "%symbol"::Symbol, tmp)$BOP
        tmp := coerce(weight(jv))$NoneFunctions1(NNI)
        jop := setProperty(jop, "%weight"::Symbol, tmp)$BOP
        tmp := coerce(type(jv))$NoneFunctions1(Sy)
        jop := setProperty(jop, "%jet"::Symbol, tmp)$BOP
        if getNotation() = Multi then
            arg := [i::EI  for i in multiIndex jv]
        else
            arg := [j::EI  for j in repeatedIndex jv]
        arg := concat!([opname::EI, index(jv)::EI], arg)
        kernel(jop, arg)


)abbrev domain JBE JetBundleExpression
++ Description:
++ \spadtype{JetBundleExpression} defines expressions over a jet bundle
++ based on \spadtype{Expression Integer}. It allows all kind of algebraic
++ operations. \spad{simplify} is implemented using Groebner bases in
++ polynomials over kernels. Thus it might not work correctly for general
++ expressions. This also affects \spad{dimension}.

JetBundleExpression(JB : JBC) : Cat == Def where

  Sy    ==> Symbol
  PI    ==> PositiveInteger
  NNI   ==> NonNegativeInteger
  I     ==> Integer
  B     ==> Boolean
  L     ==> List
  K     ==> Kernel %
  BOP   ==> BasicOperator
  SMP   ==> SparseMultivariatePolynomial(I, K)
  IE    ==> IndexedExponents K
  GB    ==> GroebnerPackage(I, IE, SMP)
  FLAF1 ==> FiniteLinearAggregateFunctions2(%, L %, SMP, L SMP)
  FLAF2 ==> FiniteLinearAggregateFunctions2(SMP, L SMP, %, L %)
  EI    ==> Expression Integer
  FS    ==> FunctionSpace Integer
  ACFS  ==> AlgebraicallyClosedFunctionSpace Integer
  TFC   ==> TranscendentalFunctionCategory
  COC   ==> CombinatorialOpsCategory
  LFC   ==> LiouvillianFunctionCategory
  SFC   ==> SpecialFunctionCategory
  JBC   ==> JetBundleCategory
  JBE   ==> JetBundleExpression JB
  JBX   ==> JetBundleXExpression JB
  JBFC  ==> JetBundleFunctionCategory JB
  JP    ==> SparseMultivariatePolynomial(EI, JB)
  OUT   ==> OutputForm
  SEM   ==> SparseEchelonMatrix(JB, %)

  SIMPREC ==> Record(Sys : L %, JM : SEM, Depend : Union("failed", L L NNI))
  ROWREC  ==> Record(Indices : L JB, Entries : L %)
  LDREC   ==> Record(Fun : %, JMR : ROWREC, Depend : L NNI)

  Const   ==> "Const"::Sy
  Indep   ==> "Indep"::Sy
  Dep     ==> "Dep"::Sy
  Deriv   ==> "Deriv"::Sy

  Cat ==> Join(JBFC, FS, ACFS, TFC, COC, LFC, SFC) with

    coerce : EI -> %
    coerce : %  -> EI

    coerce : SMP -> %

    coerce : JP -> %
    numerJP : % -> JP
      ++ \spad{numerJP(f)} writes \spad{f} as polynomial over \spad{JB}.

    reduce : % -> %
      ++ \spad{reduce(x)} reduces algebraics in \spad{x}.

    function : (Sy, L %, NNI) -> %
      ++ \spad{function(f, arg, show)} generates a function with name \spad{f}
      ++ and arguments \spad{arg}. In the output only the first \spad{show}
      ++ arguments are shown.

  Def ==> EI add

    -- -------------- --
    -- Representation --
    -- -------------- --

    Rep := EI

    coerce(jv : JB) : % == jv::EI

    coerce(exp : EI) : % == exp@Rep

    coerce(f : %) : EI == f::Rep

    coerce(p : SMP) : % == p / 1$SMP

    numerJP(f : %) : JP ==
        res : JP := 0
        p : SMP := numer f
        PM := primitiveMonomials p
        CO := coefficients p
        for mon in PM  for co in CO repeat
            JV : L JB := empty
            Exp : L NNI := empty
            newco : EI := co::EI
            for v in variables mon repeat
                vs := v::%
                jv : Union(JB, "failed") := retractIfCan vs
                if jv case "failed" then
                    newco := newco * (vs::EI)
                else
                    JV := cons(jv::JB, JV)
                    Exp := cons(degree(mon, v), Exp)
            res := res + newco*monomial(1, reverse! JV, reverse! Exp)
        res

    coerce(p : JP) : % ==
        res : % := 0
        PM := primitiveMonomials p
        CO := coefficients p
        for mon in PM  for co in CO repeat
            prod := co
            for v in variables mon repeat
                prod := prod * (v::%)^degree(p, v)
            res := res + prod
        res

    gcd(f1 : %, f2 : %) : % == gcd(numer f1, numer f2)$SMP ::%

    f1 : % exquo f2 : % ==
        p := (numer(f1) exquo$SMP numer(f2))
        p case "failed" => "failed"
        p::SMP::%

    recip(f : %) : Union(%, "failed") == 1/f

    -- --------- --
    -- Dimension --
    ------------ --

    purge(l : L K, q : NNI) : L K == [k  for k in l | order(k::%) = q]

    dimrec(lmv : L L K, indVars : L K, remVars : L K, sets : L L K) : L L K ==
        -- recursive computation of independent sets
        res := sets
        newVars := remVars
        while not empty? newVars repeat
            jk := first newVars
            newVars := rest newVars
            elem : B := false
            indK := concat(indVars, jk)
            for lv in lmv  until elem repeat
                elem := (lv = indK)
            if not elem then
                res := dimrec(lmv, indK, newVars, res)
        elem := false
        for m in res  until elem repeat
            elem := reduce("and", [member?(ik, m)  for ik in indVars], true)
        if not elem then
            res := cons(indVars, res)
        res

    dimension(sys : L %, jm : SEM, q : NNI) : NNI ==
        polys : L SMP := map(numer, sys)$FLAF1
        lmv := [sort! variables leadingMonomial p  for p in polys]
        allvars := first lmv
        for lv in rest lmv repeat
            allvars := removeDuplicates! merge(lv, allvars)
        dim0 := (dimJ(q)$JB - #allvars)::NNI
        indSets := dimrec(lmv, empty, allvars, empty)
        dim : NNI := 0
        for ind in indSets repeat
            dim := max(dim, #ind)
        dim0 + dim --reduce(max, [#ind  for ind in indSets], 0)

    orderDim(sys : L %, jm : SEM, q : NNI) : NNI ==
        polys : L SMP := map(numer, sys)$FLAF1
        lmv := [sort! purge(variables(leadingMonomial(p)), q)  for p in polys]
        allvars := first lmv
        for lv in rest lmv repeat
            allvars := removeDuplicates! merge(lv, allvars)
        dim0 := (dimS(q)$JB - #allvars)::NNI
        indSets := dimrec(lmv, empty, allvars, empty)
        dim : NNI := 0
        for ind in indSets repeat
            dim := max(dim, #ind)
        dim0 + dim --reduce(max, [#ind  for ind in indSets], 0)

    -- -------------- --
    -- Simplification --
    -- -------------- --

    simpSMP(p : SMP) : SMP ==
        -- local function to support simplification
        ground? p => 1
        tv := mainVariable p
        tv case "failed" => error "inconsistent system"
        --print("simpSMP")$OUT
        v := tv::K
        up := univariate(p, v)
        monomial? up =>
            --print("  monomial")$OUT
            lc := leadingCoefficient up
            mainVariable(lc) case "failed" =>
                --print("End simpSMP")$OUT
                monomial(1, v, 1)
            --print("End simpSMP (Rekursion)")$OUT
            monomial(simpSMP lc, v, 1)
        (md := minimumDegree up) > 0 =>
            --print("  reduce degree")$OUT
            up := monicDivide(up, monomial(1, md)).quotient
            --print("END simpSMP")$OUT
            multivariate(up, v)
        --print("END simpSMP")$OUT
        p

    simpOne(f : %) : % ==
        zero? f => 0
        simpSMP(numer f)::%

    greaterLD(r1 : LDREC, r2 : LDREC) : B ==
        -- local function for sorting purposes
        empty? r1.JMR.Indices => false
        empty? r2.JMR.Indices => true
        ind1 := r1.JMR.Indices
        ind2 := r2.JMR.Indices
        first(ind1) = first(ind2) => #ind1 < #ind2
        first(ind1) > first(ind2)

    groebner(sys : L %) : L % ==
         polys : L SMP := map(numer, sys)$FLAF1
         --print("groebner")$OUT
         print(assign(message("polys"), polys::OUT))$OUT
         gbase := groebner(polys)$GB
         --print("END groebner")$OUT
         map(coerce, gbase)$FLAF2

    groebnerSimp(sysL : L LDREC, ind : L JB) : L LDREC ==
        -- Simplification using Groebner bases for truly non-linear
        -- equations. Looses all information about dependencies.
        print(assign(message("groebnerSimp: #"), (#sysL)::OUT))$OUT
        tmp : L L NNI := [rec.Depend  for rec in sysL]
        resDep : L NNI := reduce(setUnion, tmp, empty)
        resSys := groebner([rec.Fun  for rec in sysL])
        resJM := jacobiMatrix(resSys, [ind  for eq in resSys])
        print(message("END groebnerSimp"))$OUT
        [[fun, row(resJM, i), resDep]  for fun in resSys  for i in 1..]

    linearSimp(sysL : L LDREC, ind : L JB) : L LDREC ==
        -- Tries to find an equation which is linear in its leading
        -- derivative, in order to avoid Groebner bases.
        --print(assign("linearSimp: #", (#sysL)::OUT))$OUT
        solved? : B := false
        srec : LDREC
        sld : JB
        rsysL : L LDREC := empty
        while not(solved? or empty? sysL) repeat
            rec := first sysL
            sysL := rest sysL
            ld := first rec.JMR.Indices
            s := solveFor(rec.Fun, ld)
            solved? := s case %
            if solved? then
                srec := rec
                sld := ld
            else
                rsysL := cons(rec, rsysL)
        rsysL := concat!(reverse! rsysL, sysL)
        solved? =>
            ssub := s::%
            res : L LDREC := [srec]
            sdep := srec.Depend
            for rec in rsysL repeat
                newFun := simpOne subst(rec.Fun, sld, ssub)
                if not zero? newFun then
                    newJMR := row(jacobiMatrix([newFun], [ind]), 1)$SEM
                    newDep := removeDuplicates! append(rec.Depend, sdep)
                    res := cons([newFun, newJMR, newDep], res)
            --print("END linearSimp")$OUT
            reverse! res
        --print("END linearSimp")$OUT
        groebnerSimp(rsysL, ind)

    simpRec(sysL : L LDREC, ind : L JB) : L LDREC ==
        -- Checks whether a leading derivative occurs more than once.
        -- If yes, linearSimp is called to simplify all equations with
        -- same leading derivative. These equations are sorted according
        -- to the number of jet variables occurring in them.
        #sysL < 2 => sysL
        --print("simpRec")$OUT
        frec := first sysL
        fld := first frec.JMR.Indices
        sysL := rest sysL
        srec := first sysL
        sld := first srec.JMR.Indices
        fld > sld =>
            --print("END simpRec")$OUT
            cons(frec, simpRec(sysL, ind))
        eqLD : L LDREC := [frec]
        while not(empty? sysL) and (sld = fld) repeat
            eqLD := cons(srec, eqLD)
            sysL := rest sysL
            if not empty? sysL then
                srec := first sysL
                sld := first srec.JMR.Indices
        eqLD := sort!(greaterLD, linearSimp(reverse! eqLD, ind))
        srec := first eqLD
        sld := first srec.JMR.Indices
        resLD : L LDREC := empty
        while not(empty? eqLD) and (sld = fld) repeat
            resLD := cons(srec, resLD)
            eqLD := rest eqLD
            if not empty? eqLD then
                srec := first eqLD
                sld := first srec.JMR.Indices
        newSysL : L LDREC := merge(greaterLD, eqLD, sysL)
        --print("END simpRec")$OUT
        concat!(reverse! resLD, simpRec(newSysL, ind))

    simplify(sys : L %, jm : SEM) : SIMPREC ==
        -- Sorts equations according to their leading derivatives.
        -- Ambiguities are resolved either by solving one equation
        -- for its leading derivative or by Groebner bases.
        --print("##### SIMPLIFY #####")$OUT
        inds := allIndices jm
        sysL : L LDREC := empty
        for eq in sys | not zero? eq  for i in 1.. repeat
            neq := simpOne eq
            if neq = eq then
                r := row(jm, i)
            else
                r := row(jacobiMatrix([neq], [row(jm, i).Indices]), 1)
            empty?(r.Indices) or (type(first r.Indices) = Indep) =>
                error "inconsistent system"
            sysL := cons([neq, r, [i::NNI]], sysL)
        empty? sysL => [empty, new(empty, 0), empty]
        sysL := simpRec(sort!(greaterLD, sysL), inds)

        resSys : L % := empty
        resJM : SEM := new(inds, #sysL)
        resDep : L L NNI := empty
        for rec in sysL  for i in 1.. repeat
            empty?(rec.JMR.Indices) or (first rec.JMR.Indices < U(1)$JB) =>
                error "inconsistent system"
            resSys := cons(rec.Fun, resSys)
            setRow!(resJM, i, rec.JMR)
            resDep := cons(rec.Depend, resDep)
        --print("##### END SIMPLIFY #####")$OUT
        [reverse! resSys, resJM, reverse! resDep]

    -- -------------- --
    -- JBFC Functions --
    -- -------------- --

    jetVariables(Phi : %) : L JB ==
        JV : L JB := empty
        LKernels := tower Phi
        LOps := [operator Ke  for Ke in LKernels]
        for Ke in LKernels  for Op in LOps | has?(Op, "%jet"::Symbol)$BOP repeat
            typ := property(Op, "%jet"::Symbol)::None pretend Sy
            arg := argument Ke
            if typ = Indep then
                xindex : I := retract(second arg)
                JV := cons(X(xindex::PI)$JB, JV)
            else if typ = Dep then
                uindex : I := retract(second arg)
                JV := cons(U(uindex::PI)$JB, JV)
            else
                pupindex : I := retract(second arg)
                mindex : L I := [retract i for i in rest rest arg]
                pmindex := [i::NNI for i in mindex]
                JV := cons(P(pupindex::PI, pmindex)$JB, JV)
        sort(">", removeDuplicates! JV)

    differentiate(fun : %, jv : JB) : % ==
        x := name jv
        differentiate(fun, x)

    differentiate(fun : %, x : Sy) : % == differentiate(fun::EI, x)$Rep

    subst(f : %, jv : JB, exp : %) : % ==
        --print("subst")$OUT
        res := eval(f::Rep, jv::Rep = exp::Rep)
        --print("END subst")$OUT
        res

    solveFor(f : %, jv : JB) : Union(%, "failed") ==
        -- Succeeds only if f is linear in jv!
        fun := numer f
        var : K := retract(jv::%)
        md := monicDivide(fun, var::SMP, var)
        vrem := variables md.remainder
        vquo := variables md.quotient
        member?(var, append(vrem, vquo)) => "failed"
        zero? md.remainder =>
            empty? vquo => 0
            "failed"
        - md.remainder / md.quotient

    -- --------- --
    -- Functions --
    -- --------- --

    -- Hack around the problem with the kernels. Courtesy M. Bronstein.

    kernel0(op : BOP, ls : L %) : % == kernel(op, ls pretend L EI)$EI

    sy2jbe(s : Sy) : % == s::EI

    -- The following hacks are necessary due to the not very satisfactory
    -- treatment of differentiation in FunctionSpace. They ensure that
    -- partial differentiations commute and that derivatives hide the same
    -- arguments as the original functions.

    hidedisp(l : L %) : OUT ==
        -- Yields output form for functions with hidden arguments.
        -- l is supposed to have the following structure:
        --    l = [name, #args, #shown args, args, diff]
        -- diff is a list of integers showing previous differentiations.
        name : Sy := retract first l
        l := rest l
        num : I := retract first l
        l := rest l
        show : I := retract first l
        l := rest l
        args : L OUT := empty
        for k in 1..show repeat
            args := concat!(args, [first(l)::OUT])
            l := rest l
        for k in (show + 1)..num repeat
            l := rest l
        if empty? l then
            op := name::OUT
        else
            op := sub(name::OUT, commaSeparate [e::OUT  for e in l])
        empty? args => op
        prefix(op, args)

    hidediff(l : L %, x : Sy) : % ==
        -- Differentiates functions generated by function.
        -- l has the same form as in hidedisp
        oldarg := copy l
        name : Sy := retract first l
        l := rest l
        num : I := retract first l
        zero? num => 0
        l := rest l
        show : I := retract first l
        l := rest l
        args : L % := empty
        for k in 1..num repeat
            args := cons(first l, args)
            l := rest l
        diff : L I := [retract k  for k in l]

        oldarg := first(oldarg, (num + 3)::NNI)
        op := operator(name)$BOP
        setProperty(op, "%specialDisp"::Symbol,
                    hidedisp@(L % -> OUT) pretend None)
        setProperty(op, "%specialDiff"::Symbol,
                    hidediff@((L %, Sy) -> %) pretend None)
        res : % := 0
        for k in num..1 by -1  for arg in args repeat
            da := differentiate(arg, x)
            if not zero? da then
                newarg := append(oldarg, [j::%  for j in merge(diff, [k])])
                res := res + kernel0(op, newarg)*da
        res

    function(f : Sy, arg : L %, show : NNI) : % ==
        -- Special output and differentiation routines are added using the
        -- two hooks provided by FunctionSpace and BasicOperator.
        op := operator(f)$BOP
        setProperty(op, "%specialDisp"::Symbol,
                    hidedisp@(L % -> OUT) pretend None)
        setProperty(op, "%specialDiff"::Symbol,
                    hidediff@((L %, Sy) -> %) pretend None)
        args := append([sy2jbe f, #arg::%, show::%], arg)
        kernel0(op, args)


)abbrev domain JBX JetBundleXExpression
++ Description:
++ \spadtype{JetBundleXExpression} implements arbitrary functions in a jet
++ bundle which depend only on the independent variables \spad{x}. Otherwise
++ it is identical with \spadtype{JetBundleExpression}. Such a domain is
++ needed for \spadtype{JetLinearFunction}.

JetBundleXExpression(JB : JBC) : Cat == Def where

  Sy    ==> Symbol
  PI    ==> PositiveInteger
  NNI   ==> NonNegativeInteger
  L     ==> List
  EI    ==> Expression Integer
  FS    ==> FunctionSpace Integer
  ACFS  ==> AlgebraicallyClosedFunctionSpace Integer
  TFC   ==> TranscendentalFunctionCategory
  COC   ==> CombinatorialOpsCategory
  LFC   ==> LiouvillianFunctionCategory
  SFC   ==> SpecialFunctionCategory
  JBC   ==> JetBundleCategory
  JBE   ==> JetBundleExpression JB
  JBFC  ==> JetBundleFunctionCategory JB
  BFC   ==> JetBundleBaseFunctionCategory JB

  Indep    ==> "Indep"::Sy

  errmsg ==> "Only functions of independent variables allowed"

  Cat ==> Join(JBFC, BFC, FS, ACFS, TFC, COC, LFC, SFC) with

    coerce : EI -> %
    coerce : %  -> EI

    retractIfCan : JBE -> Union(%, "failed")
      ++ \spad{retractIfCan(p)} checks whether \spad{p} depends only on
      ++ the independent variables. If yes, it is coerced.

    retract : JBE -> %
      ++ \spad{retract(p)} is like \spad{retractIfCan(p)} put yields a
      ++ hard error, if \spad{p} contains further jet variables.

    reduce : % -> %
      ++ \spad{reduce(x)} reduces the algebraics in \spad{x}.

    function : (Sy, L %) -> %
      ++ \spad{function(f, arg)} generates a function with name \spad{f}
      ++ and arguments \spad{arg}.

  Def ==> JBE add

    Rep := JBE

    coerce(jv : JB) : % ==
        type(jv) ~= Indep => error errmsg
        coerce(jv)$JBE

    retractIfCan(p : JBE) : Union(%, "failed") ==
        reduce("and", [type(jv) = Indep  for jv in jetVariables p], true) =>
            p::Rep::%
        "failed"

    retract(p : JBE) : % ==
        px : Union(%, "failed") := retractIfCan(p)
        px case "failed" => error errmsg
        px::%


)abbrev domain JBLF JetBundleLinearFunction
++ Description:
++ \spadtype{JetBundleLinearFunction} implements linear functions over
++ a jet bundle. The coefficients are functions of the independent
++ variables only.

JetBundleLinearFunction(JB : JBC, D : BFC) : Cat == Def where

  Sy    ==> Symbol
  PI    ==> PositiveInteger
  NNI   ==> NonNegativeInteger
  I     ==> Integer
  B     ==> Boolean
  L     ==> List
  JBC   ==> JetBundleCategory
  JBE   ==> JetBundleExpression JB
  JBFC  ==> JetBundleFunctionCategory JB
  BFC   ==> JetBundleBaseFunctionCategory JB
  OUT   ==> OutputForm
  SEM   ==> SparseEchelonMatrix(JB, %)
  SEMD  ==> SparseEchelonMatrix(JB, D)

  SIMPREC ==> Record(Sys : L %, JM : SEM, Depend : Union("failed", L L NNI))

  Const   ==> "Const"::Sy
  Indep   ==> "Indep"::Sy

  errmsg1 ==> "non-linear function"
  errmsg2 ==> "Substitution for 1 not allowed"

  Cat ==> Join(JBFC, Module D, RetractableTo D) with

    if D has lazyRepresentation then
        lazyRepresentation

    coerce : D -> %

    coerce : L % -> SEMD
    coerce : SEMD -> L %
      ++ coercion to matrices over ground domain.

    ground? : % -> B
      ++ \spad{ground?(l)} yields true, if \spad{l} is an element of the
      ++ ground domain \spad{D}.

    ground : % -> %
      ++ \spad{ground(l)} returns the ground part of \spad{l}.

    if D has with retractIfCan : JBE -> Union(D, "failed") then

        retractIfCan : JBE -> Union(%, "failed")
          ++ \spad{retractIfCan(p)} tries to write a general expression as
          ++ a linear function.

        retract : JBE -> %
          ++ \spad{retract(p)} is like \spad{retractIfCan(p)} put yields a
          ++ hard error, if \spad{p} contains further jet variables.

  Def ==> add

    -- -------------- --
    -- Representation --
    -- -------------- --

    -- The linear function is represented by two lists: the first contains
    -- the coefficients, the second the jet variables. The second list is
    -- always ordered.

    Rep := Record(Coeffs : L D, JVars : L JB)

    nn : PI := numIndVar()$JB
      -- global constant for number of independent variables

    monom(c : D, jv : JB) : OUT ==
        one? c => jv::OUT
        one? jv => c::OUT
        c::OUT * jv::OUT

    coerce(l : %) : OUT ==
        zero? l => 0$NNI ::OUT
        res : OUT := monom(first(l.Coeffs), first(l.JVars))
        for c in rest l.Coeffs  for jv in rest l.JVars repeat
            res := res + monom(c, jv)
        res

    coerce(jv : JB) : % ==
        jt := type jv
        jt = Const => 1
        jt = Indep => [[jv::D], [1]]
        [[1], [jv]]

    coerce(ex : D) : % ==
        zero? ex => 0
        [[ex], [1]]

    coerce(jm : SEMD) : L % ==
        res : L % := empty
        for i in 1..nrows(jm) repeat
            r := row(jm, i)
            if not empty? r.Indices then
                res := cons([r.Entries, r.Indices], res)
        reverse! res

    coerce(ll : L %) : SEMD ==
        inds : L JB := empty
        for l in ll repeat
            inds := removeDuplicates! merge(">", inds, l.JVars)
        res : SEMD := new(inds, #ll)
        for l in ll  for i in 1.. repeat
            setRow!(res, i, l.JVars, l.Coeffs)
        res

    ground?(l : %) : B == zero?(l) or one?(first l.JVars)

    ground(l : %) : % ==
        not member?(1$JB, l.JVars) => 0
        [[last l.Coeffs], [1$JB]]

    retractIfCan(l : %) : Union(D, "failed") ==
        zero? l => 0$D
        one?(first l.JVars)$JB => first l.Coeffs
        "failed"

    numerator(l : %) : % == l

    denominator(l : %) : % == 1

    if D has with retractIfCan : JBE -> Union(D, "failed") then

        retractIfCan(ex : JBE) : Union(%, "failed") ==
            pd := retractIfCan(ex)$D
            pd case D => [[pd::D], [1$JB]]
            resJ := jetVariables ex
            resC : L D := empty
            for jv in resJ repeat
                cd := retractIfCan(differentiate(ex, jv))$D
                cd case "failed" => return "failed"
                resC := cons(cd::D, resC)
            [reverse! resC, resJ]

        retract(ex : JBE) : % ==
            pl : Union(%, "failed") := retractIfCan ex
            pl case "failed" => error errmsg1
            pl::%

    -- -------- --
    -- Equality --
    -- -------- --

    zero?(l : %) : B == empty? l.JVars

    l1 : % = l2 : % == zero?(l1-l2)

    -- ----------- --
    -- Arithmetics --
    -- ----------- --

    0 : % == [[], []]

    1 : % == [[1], [1]]

    - l : % == [[-$D c  for c in l.Coeffs], l.JVars]

    l1 : % + l2 : % ==
        zero? l1 => l2
        zero? l2 => l1
        lc2 := copy l2.Coeffs
        lj2 := copy l2.JVars
        resC : L D := empty
        resJ : L JB := empty

        for c1 in l1.Coeffs  for j1 in l1.JVars repeat
            while not empty?(lj2) and first(lj2) > j1 repeat
                resC := cons(first lc2, resC)
                resJ := cons(first lj2, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            if not empty?(lj2) and first(lj2) = j1 then
                sum := c1 +$D first lc2
                if not zero? sum then
                    resC := cons(sum, resC)
                    resJ := cons(j1, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            else
                resC := cons(c1, resC)
                resJ := cons(j1, resJ)

        [concat!(reverse! resC, lc2), concat!(reverse! resJ, lj2)]

    i : I * l : % ==
        zero? i => 0
        one? i => l
        [[i *$D c for c in l.Coeffs], l.JVars]

    ex : D * l : % ==
        zero? ex => 0
        one? ex => l
        [[ex *$D c for c in l.Coeffs], l.JVars]

    l1 : % * l2 : % ==
        zero? l1 or zero? l2 => 0
        l1.JVars = [1] => first(l1.Coeffs)*l2
        l2.JVars = [1] => first(l2.Coeffs)*l1
        error errmsg1

    recip(l : %) : Union(%, "failed") ==
        l.JVars = [1] =>
            rc := recip(first(l.Coeffs))$D
            rc case D => rc::D::%
            "failed"
        "failed"

    -- The following two functions are currently only for simple cases
    -- implemented. This suffices, however, for the needs of simplify!

    l1 : % exquo l2 : % ==
        not one? first l2.JVars => "failed"
        d := first l2.Coeffs
        newC : L D := empty
        for c in l1.Coeffs repeat
            e := c exquo d
            e case "failed" => return "failed"
            newC := cons(e, newC)
        [reverse! newC, l1.JVars]

    gcd(l1 : %, l2 : %) : % ==
        (#l1.JVars > 1) or (#l2.JVars > 1) => 1
        g := gcd(first l1.Coeffs, first l2.Coeffs)
        first(l1.JVars) = first(l2.JVars) => [[g], l1.JVars]
        g::%

    -- -------------- --
    -- JBFC Functions --
    -- -------------- --

    jetVariables(l : %) : L JB ==
        zero? l => []
        res : L JB := empty
        for c in l.Coeffs repeat
            res := merge(">", res, jetVariables c)
        res := removeDuplicates! res
        if member?(1, l.JVars) then
            res := concat!(remove(1, l.JVars), res)
        else
            res := append(l.JVars, res)
        res

    differentiate(l : %, s : Sy) : % ==
        -- No check whether symbol might be a jet variable!!!
        resC : L D := empty
        resJ : L JB := empty
        for c in l.Coeffs  for j in l.JVars repeat
            dc := differentiate(c, s)$D
            if not zero? dc then
                resC := cons(dc, resC)
                resJ := cons(j, resJ)
        [reverse! resC, reverse! resJ]

    differentiate(l : %, jv : JB) : % ==
        jt := type jv
        jt = Indep =>
            resC : L D := empty
            resJ : L JB := empty
            for c in l.Coeffs  for j in l.JVars repeat
                dc := differentiate(c, jv)$D
                if not zero? dc then
                    resC := cons(dc, resC)
                    resJ := cons(j, resJ)
            [reverse! resC, reverse! resJ]
        pos := position(jv, l.JVars)
        pos < minIndex(l.JVars) => 0
        [[qelt(l.Coeffs, pos)], [1]]

    jacobiMatrix(sys : L %) : SEM ==
        inds : L JB := empty
        cinds : L JB := empty
        for eq in sys repeat
            inds := removeDuplicates! merge(">", inds, eq.JVars)
            while #cinds < nn  for co in eq.Coeffs repeat
                cinds := removeDuplicates! merge(">", cinds, jetVariables(co)$D)
        empty? cinds =>             -- constant coefficients
            res : SEM := new(inds, #sys)
            for eq in sys  for i in 1.. repeat
                setRow!(res, i, eq.JVars, [co::% for co in eq.Coeffs])
            res
        res : SEM := new(append(inds, cinds), #sys)
        for eq in sys  for i in 1.. repeat
            ents := [co::%  for co in eq.Coeffs]
            rowJ : L JB := empty
            rowC : L % := empty
            for cjv in cinds repeat
                dJV : L JB := empty
                dCo : L D := empty
                for co in eq.Coeffs  for jv in eq.JVars repeat
                    dco := differentiate(co, cjv)$D
                    if not zero? dco then
                        dJV := cons(jv, dJV)
                        dCo := cons(dco, dCo)
                if not empty? dJV then
                    rowJ := cons(cjv, rowJ)
                    rowC := cons([reverse! dCo, reverse! dJV], rowC)
            setRow!(res, i, append(eq.JVars, reverse! rowJ), _
                            append(ents, reverse! rowC))
        res

    jacobiMatrix(sys : L %, varlist : L L JB) : SEM ==
        inds := first varlist
        for vars in rest varlist repeat
            inds := removeDuplicates! merge(">", inds, vars)
        res : SEM := new(inds, #sys)
        for eq in sys  for vars in varlist  for i in 1.. repeat
            ents := [co::%  for co in eq.Coeffs]
            ivars := sort!("<", select((x : JB) : Boolean +->
                                   type(x) = Indep, vars))
            if empty? ivars then
                setRow!(res, i, eq.JVars, ents)
            else
                rowJ : L JB := empty
                rowC : L % := empty
                for ijv in ivars repeat
                    dJV : L JB := empty
                    dCo : L D := empty
                    for co in eq.Coeffs  for jv in eq.JVars repeat
                        dco := differentiate(co, ijv)$D
                        if not zero? dco then
                            dJV := cons(jv, dJV)
                            dCo := cons(dco, dCo)
                    if not empty? dJV then
                      rowJ := cons(ijv, rowJ)
                      rowC := cons([reverse! dCo, reverse! dJV], rowC)
                setRow!(res, i, append(eq.JVars, reverse! rowJ), _
                                append(ents, reverse! rowC))
        res

    -- -------------- --
    -- Simplification --
    -- -------------- --

    leadingDer(l : %) : JB ==
        zero? l => 1
        first l.JVars

    freeOf?(l : %, jv : JB) : B ==
        type(jv) = Indep =>
            reduce("and", [freeOf?(c, jv)$D for c in l.Coeffs], true)
        not member?(jv, l.JVars)

    solveFor(l : %, jv : JB) : Union(%, "failed") ==
        -- Solving for independent variables not supported!
        jt := type jv
        jt = Const or jt = Indep => "failed"
        pos := position(jv, l.JVars)
        pos < minIndex(l.JVars) => "failed"
        one?(#l.JVars) => 0
        rc := recip(l.Coeffs.pos)$D
        rc case "failed" => "failed"
        [[-c*rc  for c in delete(l.Coeffs, pos)], delete(l.JVars, pos)]

    subst(l : %, jv : JB, exp : %) : % ==
        -- Syntactic substitution.
        jt := type jv
        jt = Const => error errmsg2
        jt = Indep =>                          -- substitution in coefficients
            xexp : D := retract exp
            resC : L D := empty
            resJ : L JB := empty
            for c in l.Coeffs for cj in l.JVars repeat
                nc := subst(c, jv, xexp)$D
                if not zero? nc then
                    resC := cons(nc, resC)
                    resJ := cons(cj, resJ)
            [reverse! resC, reverse! resJ]
        pos := position(jv, l.JVars)     -- substitution in jet variables
        zero? pos => l
        c := qelt(l.Coeffs, pos)
        nl : % := [delete(l.Coeffs, pos), delete(l.JVars, pos)]
        nl + c*exp

    simplify(sys : L %, jm : SEM) : SIMPREC ==
        one?(#sys) => [sys, jm, [[1]]]

        -- make system triangular
        RRec := primitiveRowEchelon(sys::SEMD)$SEMD
        newSys := RRec.Ech::L %
        Trafo := RRec.Lt
        minR := minRowIndex Trafo
        maxR := maxRowIndex Trafo

        -- construct new Jacobi matrix and build dependency list
        inds := allIndices jm
        cinds := copy inds
        while not(empty? cinds) and (type(first cinds) ~= Indep) repeat
            cinds := rest cinds
        if not empty? cinds then
            cinds := reverse! cinds
        newJM : SEM := new(inds, #newSys)
        dep : L L NNI := empty
        for eq in newSys  for j in 1.. repeat
            if empty? cinds then            -- constant coefficients
                setRow!(newJM, j, eq.JVars, [co::% for co in eq.Coeffs])
            else                            -- non-constant coefficients
                ents := [co::%  for co in eq.Coeffs]
                rowJ : L JB := empty
                rowC : L % := empty
                for cjv in cinds repeat
                    dJV : L JB := empty
                    dCo : L D := empty
                    for co in eq.Coeffs  for jv in eq.JVars repeat
                        dco := differentiate(co, cjv)$D
                        if not zero? dco then
                            dJV := cons(jv, dJV)
                            dCo := cons(dco, dCo)
                    if not empty? dJV then
                        rowJ := cons(cjv, rowJ)
                        rowC := cons([reverse! dCo, reverse! dJV], rowC)
                setRow!(newJM, j, append(eq.JVars, reverse! rowJ), _
                                  append(ents, reverse! rowC))
            depj : L NNI := empty
            for k in maxR..minR by -1 repeat
                kb := k+minIndex(sys)-minR
                if not zero? qelt(Trafo, j, k) then
                    depj := cons((k-minR+minIndex(depj))::NNI, depj)
            dep := cons(depj, dep)

        [newSys, newJM, reverse! dep]

    simpOne(f : %) : % ==
        one?(#(f.JVars)) => [[1], f.JVars]
        f


)abbrev domain JVF JetVectorField
++ Description:
++ \spad{JetVectorField(JB, D)} implements vector fields over the jet bundle
++ \spad{JB} with coefficients from \spad{D}. The fields operate on functions
++ from \spad{D}.

JetVectorField(JB : JBC, D : JBFC JB) : Cat == Def where

  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  Sy   ==> Symbol
  L    ==> List
  B    ==> Boolean
  M    ==> Matrix
  MD   ==> Matrix D
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory
  OUT  ==> OutputForm

  Indep  ==> "Indep"::Sy
  Dep    ==> "Dep"::Sy
  errmsg ==> "not base vector field in prolong"


  Cat ==> Module(D) with

    diff : JB -> %
      ++ \spad{diff(jb)} returns the base vector field in direction \spad{jb}.

    diffX : PI -> %
      ++ \spad{diffX(i)} returns the base vector field in direction
      ++ \spad{X(i)}.

    diffU : PI -> %
      ++ \spad{diffU(i)} returns the base vector field in direction
      ++ \spad{U(i)}.

    diffP : (PI, L NNI) -> %
      ++ \spad{diffP(i, mu)} returns the base vector field in direction
      ++ \spad{P(i, mu)}.

    coefficients : % -> L D
      ++ \spad{coefficients(v)} yields the coefficients of \spad{v}.

    directions : % -> L JB
      ++ \spad{directions(v)} yields the directions of the base vectors where
      ++ \spad{v} has non-vanishing coefficients.

    coefficient : (%, JB) -> D
      ++ \spad{coefficient(v, jb)} returns the coefficient of \spad{v} in
      ++ direction \spad{jb}.

    copy : % -> %
      ++ \spad{copy(v)} returns a copy of the vector field \spad{v}.

    commutator : (%, %) -> %
      ++ \spad{commutator(v, w)} calculates the commutator of two vector fields.

    table : L % -> TwoDimensionalArray %
      ++ \spad{table(lv)} computes the commutator table for a given list of
      ++ vector fields.

    lie : (%, %) -> %
      ++ \spad{lie(v, w)} calculates the Lie derivative of \spad{w} with
      ++ respect to \spad{v}. (This yields the commutator of the fields.)

    eval : (%, D) -> D
      ++ \spad{eval(v, f)} applies the vector field \spad{v} to the function
      ++ \spad{f}.

    prolong : (%, NNI) -> %
      ++ \spad{prolong(v, q)} prolongs a vector field \spad{v} defined on the
      ++ base space into the jet bundle of order \spad{q}.

  Def ==> add

    nn : PI := numIndVar()$JB
    mm : PI := numDepVar()$JB
    -- global variables with the numbers of variables

    -- -------------- --
    -- Representation --
    -- -------------- --

    Rep := Record(Coeff : L D, Dir : L JB)

    diff(jb : JB) : % == [[1], [jb]]

    diffX(i : PI) : % == diff X(i)$JB

    diffU(i : PI) : % == diff U(i)$JB

    diffP(i : PI, mu : L NNI) : % == diff P(i, mu)$JB

    monom(c : D, jb : JB) : OUT ==
        one? c => sub(message("D"), jb::OUT)
        c::OUT * sub(message("D"), jb::OUT)

    coerce(v : %) : OUT ==
        empty? v.Dir => 0$D ::OUT
        one?(#v.Dir) => monom(first v.Coeff, first v.Dir)
        reduce("+", [monom(c, jb) for c in v.Coeff for jb in v.Dir])

    coefficients(v : %) : L D == copy v.Coeff

    directions(v : %) : L JB == copy v.Dir

    coefficient(v : %, jb : JB) : D ==
        pos := position(jb, v.Dir)
        pos < minIndex(v.Dir) => 0
        qelt(v.Coeff, pos)

    copy(v : %) : % == [copy v.Coeff, copy v.Dir]

    -- ---------- --
    -- Arithmetic --
    -- ---------- --

    0 : % == [empty, empty]

    zero?(v : %) : B == empty? v.Dir

    - v : % == [[-$D c  for c in v.Coeff], v.Dir]

    v : % + w : % ==
        zero? v => w
        zero? w => v
        lc2 : L D := copy w.Coeff
        lj2 : L JB := copy w.Dir
        resC : L D := empty
        resJ : L JB := empty

        for c1 in v.Coeff  for j1 in v.Dir repeat
            while not empty?(lj2) and first(lj2) < j1 repeat
                resC := cons(first lc2, resC)
                resJ := cons(first lj2, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            if not empty?(lj2) and first(lj2) = j1 then
                sum := c1 +$D first lc2
                if not zero? sum then
                    resC := cons(sum, resC)
                    resJ := cons(j1, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            else
                resC := cons(c1, resC)
                resJ := cons(j1, resJ)

        [concat!(reverse! resC, lc2), concat!(reverse! resJ, lj2)]

    f : D * v : % ==
        zero? f => 0
        [[f *$D c  for c in v.Coeff], v.Dir]

    -- ------------ --
    -- Prolongation --
    -- ------------ --

    prolong(v : %, q : NNI) : % ==
        zero? q => v
        dirs := directions v
        coeffs := coefficients v
        xi : L D := empty
        eta : L D := empty
        ind1 : L PI := empty
        ind2 : L PI := empty

        for jv in dirs  for co in coeffs repeat
            jt := type jv
            if jt = Indep then
                xi := cons(co, xi)
                ind1 := cons(index(jv), ind1)
            else if jt = Dep then
                eta := cons(co, eta)
                ind2 := cons(index(jv), ind2)
            else
                error errmsg

        dxi : MD := new(#xi, nn, 0)
        for co in xi  for i in 1.. repeat
            jm := jacobiMatrix [co]
            for j in 1..nn repeat
                qsetelt!(dxi, i, j, formalDiff2(co, j::PI, jm).DPhi)

        j : I := mm
        oldCo : L D := empty
        for co in eta  for i in ind2 repeat
            while j > i repeat
                oldCo := cons(0, oldCo)
                j := j-1
            oldCo := cons(co, oldCo)
            j := j-1
        if not zero? j then
            for i in 1..j repeat
                oldCo := cons(0, oldCo)
        oldDir : L JB := [U(i::PI)  for i in 1..mm]

        res : % := v
        for qq in 1..q repeat
            newCo : L D := empty
            newDir : L JB := empty
            for jv in oldDir  for co in oldCo repeat
                jm := jacobiMatrix [co]
                a := index jv
                mu := multiIndex jv
                for k in max(1, class(jv))..nn repeat
                    newjv := differentiate(jv, k::PI)::JB
                    newco := formalDiff2(co, k::PI, jm).DPhi
                    for i in ind1  for j in 1.. repeat
                        nu := copy mu
                        qsetelt!(nu, i, qelt(nu, i)+1)
                        newco := newco - qelt(dxi, j, k)*(Pm(a, nu)$JB::D)
                    res := res + newco*diff(newjv)
                    newCo := cons(newco, newCo)
                    newDir := cons(newjv, newDir)
            oldCo := newCo
            oldDir := newDir

        res

    -- -------------------- --
    -- Geometric Operations --
    -- -------------------- --

    eval(v : %, f : D) : D ==
        res : D := 0
        for c in v.Coeff  for jb in v.Dir repeat
            res := res + c*differentiate(f, jb)
        res

    commutator(v : %, w : %) : % ==
        rco : L D := empty
        rjb : L JB := empty
        for c1 in v.Coeff  for j1 in v.Dir repeat
            sum : D := 0
            for c2 in w.Coeff  for j2 in w.Dir repeat
                sum := sum + c2*differentiate(c1, j2)
            if not zero? sum then
                rco := cons(sum, rco)
                rjb := cons(j1, rjb)
        res1 : % := [reverse! rco, reverse! rjb]

        rco : L D := empty
        rjb : L JB := empty
        for c2 in w.Coeff  for j2 in w.Dir repeat
            sum : D := 0
            for c1 in v.Coeff  for j1 in v.Dir repeat
                sum := sum + c1*differentiate(c2, j1)
            if not zero? sum then
                rco := cons(sum, rco)
                rjb := cons(j2, rjb)
        res2 : % := [reverse! rco, reverse! rjb]
        res2 - res1

    table(lv : L %) : TwoDimensionalArray % ==
        len := #lv
        zero? len => error "empty list in table"
        res : TwoDimensionalArray % := new(len, len, 0)
        for i in 1..  until empty? lv repeat
            v1 := first lv
            lv := rest lv
            for v2 in lv  for j in (i+1).. repeat
                c := commutator(v1, v2)
                qsetelt!(res, i, j, c)
                qsetelt!(res, j, i, -c)
        res

    lie(v : %, w : %) : % == commutator(v, w)


)abbrev domain JDIFF JetDifferential
++ Description:
++  \spad{JetDifferential(JB, D)} implements differentials (one-forms)
++   over the jet bundle \spad{JB} with coefficients from \spad{D}.
++   The differentials operate on \spad{JetVectorField(JB, D)}.

JetDifferential(JB : JBC, D : JBFC JB) : Cat == Def where

  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  L    ==> List
  B    ==> Boolean
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory
  VF   ==> JetVectorField(JB, D)
  OUT  ==> OutputForm

  Cat ==> Module(D) with

    d : JB -> %
      ++ \spad{d(jb)} returns the differential of \spad{jb}.

    dX : PI -> %
      ++ \spad{dX(i)} returns the differential of \spad{X(i)}.

    dU : PI -> %
      ++ \spad{dU(i)} returns the differential of \spad{U(i)}.

    dP : (PI, L NNI) -> %
      ++ \spad{dP(i, mu)} returns the differential of \spad{P(i, mu)}.

    d : D -> %
      ++ \spad{d(f)} computes the differential of \spad{f}.

    coefficients : % -> L D
      ++ \spad{coefficients(om)} yields the coefficients of \spad{om}.

    differentials : % -> L JB
      ++ \spad{directions(om)} yields the differentials where \spad{om} has
      ++ non-vanishing coefficients.

    coefficient : (%, JB) -> D
      ++ \spad{coefficient(om, jb)} returns the coefficient of \spad{om} for
      ++ the differential of \spad{jb}.

    copy : % -> %
      ++ \spad{copy(om)} returns a copy of the differential \spad{om}.

    lie : (VF, %) -> %
      ++ \spad{lie(v, om)} calculates the Lie derivative of \spad{om} with
      ++ respect to \spad{v}.

    contract : (VF, %) -> D
      ++ \spad{contract(v, om)} computes the interior derivative of \spad{om}
      ++ with respect to \spad{v}.

    eval : (%, VF) -> D
      ++ \spad{eval(om, v)} applies the differential \spad{om} to the vector
      ++ field \spad{v}.

  Def ==> add

    -- -------------- --
    -- Representation --
    -- -------------- --

    Rep := Record(Coeff : L D, Diff : L JB)

    d(jb : JB) : % == [[1], [jb]]

    dX(i : PI) : % == d X(i)$JB

    dU(i : PI) : % == d U(i)$JB

    dP(i : PI, mu : L NNI) : % == d P(i, mu)$JB

    monom(c : D, jb : JB) : OUT ==
        one? c => hconcat(message("d"), jb::OUT)
        c::OUT * hconcat(message("d"), jb::OUT)

    coerce(om : %) : OUT ==
        empty?(om.Diff) => 0$D ::OUT
        one?(#om.Diff) => monom(first om.Coeff, first om.Diff)
        reduce("+", [monom(c, jb) for c in om.Coeff for jb in om.Diff])

    coefficients(om : %) : L D == copy om.Coeff

    differentials(om : %) : L JB == copy om.Diff

    coefficient(om : %, jb : JB) : D ==
        pos := position(jb, om.Diff)
        pos < minIndex(om.Diff) => 0
        qelt(om.Coeff, pos)

    copy(om : %) : % == [copy om.Coeff, copy om.Diff]

    -- ---------- --
    -- Arithmetic --
    -- ---------- --

    0 : % == [empty, empty]

    zero?(om : %) : B == empty? om.Diff

    - om : % == [[-$D c  for c in om.Coeff], om.Diff]

    om1 : % + om2 : % ==
        zero? om1 => om2
        zero? om2 => om1
        lc2 := copy om2.Coeff
        lj2 := copy om2.Diff
        resC := empty()$L(D)
        resJ := empty()$L(JB)

        for c1 in om1.Coeff  for j1 in om1.Diff repeat
            while not empty?(lj2) and first(lj2) < j1 repeat
                resC := cons(first lc2, resC)
                resJ := cons(first lj2, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            if not empty?(lj2) and first(lj2) = j1 then
                sum := c1 +$D first lc2
                if not zero? sum then
                    resC := cons(sum, resC)
                    resJ := cons(j1, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            else
                resC := cons(c1, resC)
                resJ := cons(j1, resJ)

        [concat!(reverse! resC, lc2), concat!(reverse! resJ, lj2)]

    f : D * om : % ==
        zero? f => 0
        [[f *$D c  for c in om.Coeff], om.Diff]

    -- -------------------- --
    -- Geometric Operations --
    -- -------------------- --

    d(f : D) : % ==
        JV := reverse! jetVariables f
        empty? JV => 0
        Co : L D := [differentiate(f, jv)  for jv in JV]
        [Co, JV]

    eval(om : %, v : VF) : D ==
        zero? om => 0
        zero? v => 0
        lc2 : L D := copy coefficients v
        lj2 : L JB := copy directions v
        res := 0$D

        for c1 in om.Coeff  for j1 in om.Diff repeat
            while not empty?(lj2) and first(lj2) < j1 repeat
                lc2 := rest lc2
                lj2 := rest lj2
            if not empty?(lj2) and first(lj2) = j1 then
                res := res + c1*first(lc2)
                lc2 := rest lc2
                lj2 := rest lj2

        res

    contract(v : VF, om : %) : D == eval(om, v)


)abbrev domain JDE JetDifferentialEquation
++ Description:
++ \spadtype{JetDifferentialEquation} provides the basic data structures and
++ procedures for differential equations as needed in the geometric theory.
++ Differential equation means here always a submanifold in the jet bundle.
++ The concrete equations which define this submanifold are called system.
++ In an object of the type \spadtype{JetDifferentialEquation} much more than
++ only the system is stored. \spad{D} denotes the class of functions allowed
++ as equations. It is assumed that the \spad{simplify} procedure of \spad{D}
++ returns only independent equations and a system with symbol in row echelon
++ form.

JetDifferentialEquation(JB : JBC, D : JBFC) : Cat == Def where

  B    ==> Boolean
  Sy   ==> Symbol
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  EQ   ==> Equation
  L    ==> List
  V    ==> Vector
  M    ==> Matrix
  VD   ==> V D
  MD   ==> M D
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory JB
  SEM  ==> SparseEchelonMatrix(JB, D)
  DIFF ==> JetDifferential(JB, D)

  MVREC  ==> Record(Rank : NNI, NumMultVar : NNI, Betas : L NNI)
  SREC   ==> Record(SDe : %, IC : L D)

  Cat ==> with

    order : % -> NNI
      ++ \spad{order(de)} yields the order of the differential equation
      ++ \spad{de}.

    coerce : % -> OUT
      ++ \spad{coerce(de)} transforms the differential equation \spad{de}
      ++ to \spadtype{OutputForm}.

    printSys : L D -> OUT
      ++ \spad{printSys(sys)} writes a list of functions as a vector of
      ++ equations (with right hand side 0) and coerces the result to
      ++ \spadtype{OutputForm}.

    display : % -> Void
      ++ \spad{display(de)} prints all information stored about the
      ++ differential equation \spad{de}. This comprises the system
      ++ ordered by the order of the equations, the Jacobi matrices
      ++ separately  for each order and the index of the independent
      ++ variable with respect to which the equation was lastly
      ++ differentiated (1 for not prolonged equations).

    copy : % -> %
      ++ \spad{copy(De)} returns a copy of the equation \spad{De}.

    retract : % -> L D
      ++ \spad{retract(de)} returns the system defining the differential
      ++ equation \spad{de}.

    jacobiMatrix : % -> L SEM
      ++ \spad{jacobiMatrix(De)} returns a list of Jacobi matrices sorted
      ++ by the order of the equations.

    makeSystem : L D -> %
      ++ \spad{makeSystem(sys)} creates a differential equation from a system.

    join : (%, %) -> %
      ++ \spad{join(de1, de2)} combines \spad{de1} and \spad{de2}
      ++ to a single differential equation.

    insert : (L D, %) -> %
      ++ \spad{insert(sys, de)} adds the system \spad{sys = 0}
      ++ to the differential equation \spad{de}.

    dimension : (%, NNI) -> NNI
      ++ \spad{dimension(de, q)} computes the dimension of the differential
      ++ equation \spad{de} as a submanifold of the \spad{q}-th order jet
      ++ bundle. The result is correct only, if \spad{de} is simplified.

    setSimpMode : NNI -> NNI
      ++ \spad{setSimpMode(i)} sets the flag controlling the used
      ++ simplifications and returns the old value. Current values are:
      ++ \spad{i = 0} -> No simplification modulo lower order equations.
      ++ \spad{i = 1} -> Simplification modulo lower order equations.
      ++ Default is 0.

    simplify : % -> SREC
      ++ \spad{simplify(de)} simplifies the equations of each order separately
      ++ using the procedure \spad{simplify} from \spad{D}. Found
      ++ integrability conditions are also returned separately.

    extractSymbol : (%, B) -> SEM
      ++ \spad{extractSymbol(de, solved?)} computes the symbol of the
      ++ differential equation \spad{de}. If \spad{solved?} is true,
      ++ the row echelon form of the symbol is computed at once.

    analyseSymbol : SEM -> MVREC
      ++ \spad{analyseSymbol(symb)} computes the multiplicative variables of
      ++ the symbol \spad{symb}.

    prolongSymbol : SEM -> SEM
      ++ \spad{prolongSymbol(symb)} prolongs directly the symbol \spad{symb}.

    prolongMV : MVREC -> MVREC
      ++ \spad{prolongMV(mv)} calculates the number of multiplicative variables
      ++ for the prolongation of an involutive symbol.

    project : (%, NNI) -> %
      ++ \spad{project(de, q)} projects the differential equation \spad{de}
      ++ of order higher than \spad{q} into the \spad{q}-th order jet bundle.

    prolong : % -> SREC
      ++ \spad{prolong(de)} prolongs the differential equation \spad{de}.
      ++ Additionally the arising integrability conditions are returned.

    prolong : (%, NNI) -> SREC
      ++ \spad{prolong(de, q)} is like \spad{prolong(de)}. However, only
      ++ equations of lower order than \spad{q} are prolonged.

    tableau : (SEM, DIFF) -> SEM
      ++ \spad{tableau(symb, chi)} computes the tableau parametrized by a given
      ++ one-form.

    tableau : (SEM, L DIFF) -> SEM
      ++ \spad{tableau(symb, lchi)} computes the extended tableau parametrized
      ++ by a given list of one-forms.

  Def ==> add

    nn : PI := numIndVar()$JB
    mm : PI := numDepVar()$JB
      -- global variables for the number of independent and dependent
      -- variables in JB

    simpMode : NNI := 0        -- global flag for simplification mode

    setSimpMode(i : NNI) : NNI ==
        j := simpMode
        simpMode := i
        j

    adapt(der : L NNI, pro? : L B, dep : Union("failed", L L NNI)) : _
          Record(Der : L NNI, Pro? : L B) ==
        -- Adapts Deriv and Prolonged? after simplification.
        -- Local function.
        dep case "failed" => [[1 for i in der], [false for i in der]]
        resDer : L NNI := empty
        resPro? : L B := empty
        for d in dep::L L NNI repeat
            if one?(#d) then
                resDer := cons(qelt(der, first d), resDer)
                resPro? := cons(qelt(pro?, first d), resPro?)
            else
                j : NNI := reduce(min, [qelt(der, i)  for i in d])
                b : B := reduce("and", [qelt(pro?, i)  for i in d])
                resDer := cons(j, resDer)
                resPro? := cons(b, resPro?)
        [reverse! resDer, reverse! resPro?]

    -- -------------- --
    -- Representation --
    -- -------------- --

    SysRec := Record(Eqs : L D, JM : SEM, Deriv : L NNI, Prolonged? : L B, _
                           Simp? : B, Dim? : B, Dim : NNI)
    Rep := Record(Sys : L SysRec, Order : L NNI)
    -- The equations in Sys are stored order by order. Order contains for
    -- each sublist the order. The first list contains the equations of
    -- highest order. The Jacobi matrix for each subsystem is in JM.
    -- Deriv tells for each equation the index of the independent variable
    -- with respect to which it was last differentiated. For new equations
    -- that is always one. Simp? contains flags whether the subsystems have
    -- already been simplified, Dim? whether the dimension at this order has
    -- already been computed. Dim contains the dimension. Prolonged? tells
    -- whether or not an equation has already been prolonged.

    copy(De : %) : % ==
        newSys : L SysRec := [[copy sys.Eqs, copy sys.JM, copy sys.Deriv, _
                      copy sys.Prolonged?, sys.Simp?, sys.Dim?, sys.Dim] _
                      for sys in De.Sys]
        newOrd := copy De.Order
        [newSys, newOrd]

    order(De : %) : NNI ==
        empty? De.Order => 0
        first De.Order

    retract(De : %) : L D ==
        LSys := [sys.Eqs  for sys in De.Sys]
        reduce(append, LSys, empty)

    jacobiMatrix(De : %) : L SEM == [sys.JM  for sys in De.Sys]

    printSys(sys : L D) : OUT ==
        -- Prints system as "vector" of equations
        empty? sys => empty
        leq : L EQ D := [eq = 0  for eq in sys]
        tmp : L OUT := empty
        for eq in leq repeat
            tmp := cons(eq::OUT, cons(message(" "), tmp))
        vconcat reverse tmp

    coerce(De : %) : OUT == printSys retract De

    display(De : %) : Void ==
        for sys in De.Sys  for ord in De.Order repeat
            print(hconcat(message("Order: "), ord::OUT))$OUT
            print(message("  System:"))$OUT
            print(hconcat(message("    "), printSys(sys.Eqs)))$OUT
            if sys.Simp? then
                print(message("    (system simplified)"))$OUT
            if sys.Dim? then
                print(hconcat(message("  Dimension: "), sys.Dim::OUT))$OUT
            print(message("  Jacobi matrix:"))$OUT
            print(hconcat(message("    "), sys.JM::OUT))$OUT
            print(hconcat(message("    "), allIndices(sys.JM)::OUT))$OUT
            print(message("  Last derivations:"))$OUT
            print(hconcat(message("    "), sys.Deriv::OUT))$OUT
        void

    -- --------------------------- --
    -- Basic Operations on Systems --
    -- --------------------------- --

    makeSystem2(sys : L D, jm : SEM, der : L NNI) : % ==
        -- Equations are sorted by order.
        -- No check for empty system.
        -- Local function.
        lord : L NNI := [order first row(jm, i).Indices  for i in 1..nrows(jm)]
        resOrd := reverse sort removeDuplicates lord
        nord := #resOrd
        inds := allIndices jm
        ljm : L SEM := empty
        for q in resOrd  repeat
            while order(first inds) > q repeat
                inds := rest inds
            ljm := cons(new(inds, 1), ljm)

        vsys : V L D := new(nord, empty)
        vder : V L NNI := new(nord, empty)
        vjm : V SEM := construct reverse! ljm
        for eq in reverse sys  for i in reverse der  for q in reverse lord _
                for j in nrows(jm)..1 by -1 repeat
            pos := position(q, resOrd)+1-minIndex(resOrd)
            if empty? qelt(vsys, pos) then
                qsetelt!(vsys, pos, [eq])
                setRow!(qelt(vjm, pos), 1, row(jm, j))
                qsetelt!(vder, pos, [i])
            else
                qsetelt!(vsys, pos, cons(eq, qelt(vsys, pos)))
                consRow!(qelt(vjm, pos), row(jm, j))
                qsetelt!(vder, pos, cons(i, qelt(vder, pos)))

        --for j in minIndex(vjm)..maxIndex(vjm) repeat
        --  elimZeroCols! qelt(vjm, i)
        resSys : L SysRec := empty
        for ord in resOrd  for i in minIndex(vsys).. repeat
            rec : SysRec := [qelt(vsys, i), qelt(vjm, i), qelt(vder, i), _
                             new(#qelt(vder, i), false), false, false, 0]
            resSys := cons(rec, resSys)
        [reverse! resSys, resOrd]

    makeSystem(sys : L D) : % ==
        empty? sys => [[], []]
        nsys := [numerator eq  for eq in sys]
        der : L NNI := [1  for eq in nsys]
        jm : SEM := jacobiMatrix nsys
        makeSystem2(nsys, jm, der)

    join(De1 : %, De2 : %) : % ==
        cDe1 := copy De1; cDe2 := copy De2
        sys1 := cDe1.Sys; sys2 := cDe2.Sys
        ord1 := cDe1.Order; ord2 := cDe2.Order
        resSys : L SysRec := empty
        resOrd : L NNI := empty

        while not(empty? ord1 and empty? ord2) repeat
            if empty? ord1 then
                resSys := concat!(reverse! sys2, resSys)
                resOrd := concat!(reverse! ord2, resOrd)
                ord2 := empty
            else if empty? ord2 then
                resSys := concat!(reverse! sys1, resSys)
                resOrd := concat!(reverse! ord1, resOrd)
                ord1 := empty
            else
                o1 := first ord1
                o2 := first ord2
                if o1 > o2 then
                    resSys := cons(first sys1, resSys)
                    resOrd := cons(o1, resOrd)
                    sys1 := rest sys1
                    ord1 := rest ord1
                else if o2 > o1 then
                    resSys := cons(first sys2, resSys)
                    resOrd := cons(o2, resOrd)
                    sys2 := rest sys2
                    ord2 := rest ord2
                else
                    rec1 := first sys1; rec2 := first sys2
                    rec : SysRec := [concat!(rec1.Eqs, rec2.Eqs), _
                            join(rec1.JM, rec2.JM), _
                            concat!(rec1.Deriv, rec2.Deriv), _
                            concat!(rec1.Prolonged?, rec2.Prolonged?), _
                            false, false, 0]
                    resSys := cons(rec, resSys)
                    resOrd := cons(o1, resOrd)
                    sys1 := rest sys1; sys2 := rest sys2
                    ord1 := rest ord1; ord2 := rest ord2

        [reverse! resSys, reverse! resOrd]

    insert(sys : L D, De : %) : % ==
        newDe : % := makeSystem sys
        join(De, newDe)

    dimension(De : %, q : NNI) : NNI ==
        -- The dimension is computed order by order
        -- Caution: Dim and Dim? are changed in De!
        empty? De.Order => dimJ(q)$JB
        simp? := true$B

        tsys := copy De.Sys
        tord := copy De.Order
        resSys := empty()$L(SysRec)

        while first(tord) > q repeat
            resSys := cons(first tsys, resSys)
            tsys := rest tsys
            tord := rest tord

        qq := q::I
        res := 0$NNI

        for sys in tsys  for ord in tord repeat
            for j in ord+1..qq repeat
                res := res + dimS(j)$JB
            qq := ord-1

            simp? := simp? and sys.Simp?
            if sys.Dim? then
                res := res + sys.Dim
            else
                d := orderDim(sys.Eqs, sys.JM, ord)$D
                res := res + d
                sys.Dim? := true
                sys.Dim := d
            resSys := cons(sys, resSys)

        if not simp? then
            print(message(
              "***** Warning: system not simplified in dimension"))$OUT
        if qq >= 0 then
            res := res + dimJ(qq::NNI)$JB
        De.Sys := reverse! resSys
        res

    -- -------------- --
    -- Simplification --
    -- -------------- --

    simplify(De : %) : SREC ==
        -- Simplification is performed order by order, starting with the highest
        -- order. If equations of lower order are generated, they are moved into
        -- the corresponding subsystem.
        resSys := empty()$L(SysRec)
        resOrd := empty()$L(NNI)
        ICs := empty()$L(D)

        cDe := copy De
        tsys := cDe.Sys
        tord := cDe.Order

        AllEqs := empty()$L(D)

        if simpMode > 0 then
            AllEqs := retract cDe

        while not empty? tord repeat
            q := first tord
            sys := first tsys
            if sys.Simp? then                      -- already simplified
                resSys := cons(sys, resSys)
                resOrd := cons(q, resOrd)
            else                                    -- not yet simplified
                if simpMode > 0 then
                    while not(empty?(AllEqs) or _
                          (order(first AllEqs) < q)) repeat
                        AllEqs := rest AllEqs

                -- simplify equations of highest order
                if simpMode > 0 then
                    tmp := simpMod(sys.Eqs, sys.JM, AllEqs)$D
                    tmp := simplify(tmp.Sys, tmp.JM)$D
                else
                    tmp := simplify(sys.Eqs, sys.JM)$D
                newEqs := tmp.Sys
                newJM := tmp.JM
                ad := adapt(sys.Deriv, sys.Prolonged?, tmp.Depend)
                newDer := ad.Der
                newPro? := ad.Pro?

                -- check for equations of lower order
                j : NNI := 0
                for eq in newEqs  for pro? in newPro?  for i in 1.. repeat
                    o := order first row(newJM, i-j).Indices
                    o > q => error "order raised in simplify"
                    if o < q then
                        ICs := cons(eq, ICs)
                        j := j+1
                        pos1 := i-j+1
                        pos2 := i-j+minIndex(newEqs)
                        newEqs := delete(newEqs, pos2)
                        newDer := delete(newDer, pos2)
                        newPro? := delete(newPro?, pos2)
                        djm : SEM := extract(newJM, pos1, pos1)
                        sortedPurge!(djm, order(#1) > o)
                        deleteRow!(newJM, pos1)

                        pos := position(o, tord)
                        if pos >= minIndex(tord) then
                            rec : SysRec := qelt(tsys, pos)
                            concat!(rec.Eqs, eq)
                            appendRow!(rec.JM, row(djm, 1))
                            concat!(rec.Deriv, 1)
                            concat!(rec.Prolonged?, pro?)
                            rec.Simp? := false
                            rec.Dim? := false
                            rec.Dim := 0
                            qsetelt!(tsys, pos, rec)
                        else
                            rec : SysRec := [[eq], djm, [1], [pro?], _
                                             false, false, 0]
                            hord : L NNI := empty
                            pos := minIndex(tord) - 1
                            while not empty? tord and first(tord) > o repeat
                                hord := cons(first tord, hord)
                                tord := rest tord
                                pos := pos + 1
                            if empty? tord then
                                tord := reverse! cons(o, hord)
                                concat!(tsys, rec)
                            else
                                tord := concat!(reverse! hord, cons(o, tord))
                                tsys := insert!(rec, tsys, pos)

                rec : SysRec := [newEqs, newJM, newDer, newPro?, true, false, 0]
                resSys := cons(rec, resSys)
                resOrd := cons(q, resOrd)

            tsys := rest tsys
            tord := rest tord

        -- check for inconsistencies or conditions on independent variables
        if zero? q then                        -- algebraic equations
            jm0 := first(resSys).JM
            for eq in first(resSys).Eqs  for i in 1.. repeat
                lj := row(jm0, i).Indices
                empty? lj => error "inconsistent system"
                u? : B := false
                for j in 1..mm  until u? repeat
                    u? := member?(U(j::PI)$JB, lj)
                not u? => error "independent variables not independent"

        [[reverse! resSys, reverse! resOrd], reverse! ICs]

    -- --------------------------- --
    -- Prolongation and Projection --
    -- --------------------------- --

    project(De : %, q : NNI) : % ==
        cDe := copy De
        q >= order De => cDe
        resSys := cDe.Sys
        resOrd := cDe.Order
        check : B := true

        while not empty? resOrd and first(resOrd) > q repeat
            check := check and first(resSys).Simp?
            resSys := rest resSys
            resOrd := rest resOrd

        if not check then
            print(message(
              "***** Warning: projection of not simplified system"))$OUT
        [resSys, resOrd]

    prolong(De : %) : SREC ==
        -- Prolonged equations are at once simplified. This yields the
        -- integrability conditions.

        -- prolong equations of highest order
        pEqs : L D := empty
        pDer : L NNI := empty
        pJV : L L JB := empty
        pIC : L D := empty
        rec := first De.Sys
        q := first De.Order
        for eq in rec.Eqs  for j in rec.Deriv  for k in 1.. repeat
            jmeq := extract(rec.JM, k, k)
            for i in nn..j by -1 repeat
                FDiff := formalDiff2(eq, i::PI, jmeq)
                pEqs := cons(FDiff.DPhi, pEqs)
                pDer := cons(i::NNI, pDer)
                pJV := cons(FDiff.JVars, pJV)
        pEqs := reverse! pEqs
        pJV := reverse! pJV
        pDer := reverse! pDer
        pJM := jacobiMatrix(pEqs, pJV)

        pRec : SysRec := [pEqs, pJM, pDer, [false for i in pDer], _
                          false, false, 0]
        pSys : L SysRec := [pRec]
        pOrd : L NNI := [q + 1]

        -- prolong remaining equations, if necessary
        -- this yields additional integrability conditions
        lastRec := copy rec
        lastRec.Prolonged? := [true  for j in rec.Deriv]
        lastOrd := q
        for rec in rest De.Sys  for ord in rest De.Order repeat
            pEqs := empty
            pDer := empty
            pJV := empty
            for eq in rec.Eqs  for j in rec.Deriv  for pro? in rec.Prolonged? _
                    for k in 1.. repeat
                if not pro? then
                    jmeq := extract(rec.JM, k, k)
                    for i in nn..j by -1 repeat
                        FDiff := formalDiff2(eq, i::PI, jmeq)
                        pEqs := cons(FDiff.DPhi, pEqs)
                        pDer := cons(i::NNI, pDer)
                        pJV := cons(FDiff.JVars, pJV)
            if empty? pEqs then
                pSys := cons(lastRec, pSys)
                pOrd := cons(lastOrd, pOrd)
            else
                pIC := append(pIC, pEqs)
                pJM := jacobiMatrix(pEqs, pJV)
                if ord+1 < lastOrd then
                    pRec := [pEqs, pJM, pDer, [false for i in pDer], _
                             false, false, 0]
                    pSys := cons(pRec, cons(lastRec, pSys))
                    pOrd := cons(ord + 1, cons(lastOrd, pOrd))
                else
                    pRec := [append(lastRec.Eqs, pEqs), _
                        join(lastRec.JM, pJM), append(lastRec.Deriv, pDer), _
                        append(lastRec.Prolonged?, [false for i in pDer]), _
                        false, false, 0]
                    pSys := cons(pRec, pSys)
                    pOrd := cons(lastOrd, pOrd)
            lastRec := copy rec
            lastRec.Prolonged? := [true  for j in rec.Deriv]
            lastOrd := ord

        pSys := cons(lastRec, pSys)
        pOrd := cons(lastOrd, pOrd)
        res : % := [reverse! pSys, reverse! pOrd]
        tmp := simplify res
        [tmp.SDe, concat!(pIC, tmp.IC)]

    prolong(De : %, q : NNI) : SREC ==
        -- Prolongs only equations of order lower than q.
        -- Prolonged equations are at once simplified. This yields the
        -- integrability conditions.
        cDe := copy De
        tsys := cDe.Sys
        tord := cDe.Order
        pSys : L SysRec := empty
        pOrd : L NNI := empty
        pIC : L D := empty

        while first(tord) > q repeat
            pSys := cons(first tsys, pSys)
            pOrd := cons(first tord, pOrd)
            tsys := rest tsys
            tord := rest tord

        if not first(tord) = q then

            -- prolong equations of highest order (< q)
            pEqs : L D := empty
            pDer : L NNI := empty
            pJV : L L JB := empty
            rec := first tsys
            ord := first tord
            for eq in rec.Eqs  for j in rec.Deriv  for k in 1.. repeat
                jmeq := extract(rec.JM, k, k)
                for i in nn..j by -1 repeat
                    FDiff := formalDiff2(eq, i::PI, jmeq)
                    pEqs := cons(FDiff.DPhi, pEqs)
                    pDer := cons(i::NNI, pDer)
                    pJV := cons(FDiff.JVars, pJV)
            pEqs := reverse! pEqs
            pJV := reverse! pJV
            pDer := reverse! pDer
            pJM := jacobiMatrix(pEqs, pJV)
            pIC := pEqs

            pRec : SysRec := [pEqs, pJM, pDer, [false for i in pDer], _
                              false, false, 0]
            pSys := cons(pRec, pSys)
            pOrd := cons(ord + 1, pOrd)

        lastRec := first tsys
        lastOrd := first tord

        -- prolong remaining equations, if necessary
        for rec in rest tsys  for ord in rest tord repeat
            pEqs : L D := empty
            pDer : L NNI := empty
            pJV : L L JB := empty
            for eq in rec.Eqs  for j in rec.Deriv  for pro? in rec.Prolonged? _
                    for k in 1.. repeat
                if not pro? then
                    jmeq := extract(rec.JM, k, k)
                    for i in nn..j by -1 repeat
                        FDiff := formalDiff2(eq, i::PI, jmeq)
                        pEqs := cons(FDiff.DPhi, pEqs)
                        pDer := cons(i::NNI, pDer)
                        pJV := cons(FDiff.JVars, pJV)
            if empty? pEqs then
                pSys := cons(lastRec, pSys)
                pOrd := cons(lastOrd, pOrd)
            else
                pEqs := reverse! pEqs
                pJV := reverse! pJV
                pDer := reverse! pDer
                pJM := jacobiMatrix(pEqs, pJV)
                pIC := append(pIC, pEqs)
                if (ord+1) < lastOrd then
                    pRec : SysRec := [pEqs, pJM, pDer, [false for i in pDer], _
                                      false, false, 0]
                    pSys := cons(pRec, cons(lastRec, pSys))
                    pOrd := cons(ord + 1, cons(lastOrd, pOrd))
                else
                    pRec : SysRec := [concat!(lastRec.Eqs, pEqs), _
                        join(lastRec.JM, pJM), concat!(lastRec.Deriv, pDer), _
                        concat!(lastRec.Prolonged?, [false for i in pDer]), _
                        false, false, 0]
                    pSys := cons(pRec, pSys)
                    pOrd := cons(lastOrd, pOrd)
                rec.Prolonged? := [true  for j in rec.Deriv]
            lastRec := rec
            lastOrd := ord

        pSys := cons(lastRec, pSys)
        pOrd := cons(lastOrd, pOrd)
        res : % := [reverse! pSys, reverse! pOrd]
        tmp := simplify res
        [tmp.SDe, concat!(pIC, tmp.IC)]

    -- --------------------- --
    -- Operations on Symbols --
    -- --------------------- --

    extractSymbol(De : %, solved? : B) : SEM ==
        res := extractSymbol(first(De.Sys).JM)$D
        if solved? then
            res := rowEchelon(res).Ech
        res

    analyseSymbol(Symb : SEM) : MVREC ==
        tmp := rowEchelon Symb
        ech := tmp.Ech

        pivs := pivots ech
        MSum := 0$NNI
        BetaI := 0$NNI
        LastClass : NNI := nn
        LBeta : L NNI := empty

        for jv in pivs.Indices repeat
            CurClass := class jv
            if CurClass = LastClass then
                BetaI := BetaI + 1
            else
                LBeta := cons(BetaI, LBeta)
                MSum := MSum + BetaI*LastClass
                for k in 2..LastClass-CurClass repeat
                    LBeta := cons(0, LBeta)
                BetaI := 1
                LastClass := CurClass

        LBeta := cons(BetaI, LBeta)
        MSum := MSum + BetaI*LastClass
        for k in 2..LastClass repeat
            LBeta := cons(0, LBeta)
        [tmp.Rank, MSum, LBeta]

    prolongSymbol(Symb : SEM) : SEM ==
        -- Direct prolongation of a symbol without differentiation.
        oldInds := allIndices Symb
        newInds : L JB := empty
        for jv in reverse oldInds repeat
            for i in 1..nn repeat
                newInds := cons(differentiate(jv, i::PI)::JB, newInds)
        newInds := sort!((x, y) +-> y < x, removeDuplicates! newInds)
        res : SEM := new(newInds, nn*nrows Symb)
        for j in 1..nrows(Symb) repeat
            r := row(Symb, j)
            for i in nn..1 by -1 repeat
                ninds := [differentiate(jv, i::PI)::JB  for jv in r.Indices]
                setRow!(res, nn*j-i+1, ninds, r.Entries)
        res

    prolongMV(mv : MVREC) : MVREC ==
        oldBeta := reverse mv.Betas
        newBeta : L NNI := empty
        sum : NNI := 0
        rank : NNI := 0
        msum : NNI := 0
        for beta in oldBeta  for k in nn..1 by -1 repeat
            sum := sum + beta
            rank := rank + sum
            msum := msum + k*sum
            newBeta := cons(sum, newBeta)
        [rank, msum, reverse! newBeta]

    -- ---------------------- --
    -- Operations on Tableaux --
    -- ---------------------- --

    power(lc : L D, mu : L NNI, mask : L PI) : D ==
        -- local function to compute the monomial generated by the
        -- one-form with coefficients lc and the multi-index mu.
        -- mask tells which coefficients are not zero.
        res : D := 1
        k : PI := 1
        while not empty? mask repeat
            while k < first(mask) repeat
                mu := rest mu
                k := k + 1
            res := res * first(lc)^first(mu)
            lc := rest lc
            mask := rest mask
            mu := rest mu
            k := k + 1
        res

    extPower(llc : MD, mu : L NNI, nu : L NNI) : D ==
        -- the rows of the matrix llc contain the coefficients of the one-forms
        -- nu determines the repeated indices; mu the exponents
        snu := allRepeated(nu)$JB
        rmu := m2r(mu)$JB
        q := #first(snu)
        res : D := 0
        for s in snu repeat
            prod : D := 1
            for si in s  for mi in rmu repeat
                prod := prod * qelt(llc, nn-si+1, mi)
            res := res + prod
        res

    tableau(Symb : SEM, chi : DIFF) : SEM ==
        diffs := differentials chi
        last(diffs) > X(nn)$JB => error "illegal differential in tableau"
        coeffs := coefficients chi
        cinds := [index d  for d in diffs]
        res : SEM := new([U(i::PI)  for i in mm..1 by -1], nrows(Symb))

        for k in 1..nrows(Symb) repeat
            r := row(Symb, k)
            sum : VD := new(mm, 0)
            for jv in r.Indices   for ent in r.Entries repeat
                a := index jv
                mu := multiIndex jv
                qsetelt!(sum, a, qelt(sum, a) + ent*power(coeffs, mu, cinds))
            li : L JB := empty
            le : L D := empty
            for i in 1..mm  for s in entries sum repeat
                if not zero? s then
                    li := cons(U(i::PI), li)
                    le := cons(s, le)
            setRow!(res, k, li, le)

        res

    tableau(Symb : SEM, lchi : L DIFF) : SEM ==
        q := order first allIndices Symb
        inds := variables(q, (nn-#lchi+1)::PI)$JB
        mco : MD := new(#lchi, nn, 0)
        for i in 1..  for chi in lchi repeat
            for j in 1..nn repeat
                qsetelt!(mco, i, j, coefficient(chi, X(j::PI)$JB))
        res : SEM := new(inds, nrows(Symb))

        for vv in reverse inds repeat
            a := index vv
            nu := multiIndex vv
            for k in 1..nrows(Symb) repeat
                r := row(Symb, k)
                s : D := 0
                for jv in r.Indices  for ent in r.Entries repeat
                    if index(jv) = a then
                        mu := multiIndex jv
                        s := s + ent*extPower(mco, mu, nu)
                if not zero? s then
                    rres := row(res, k)
                    rres.Indices := cons(vv, rres.Indices)
                    rres.Entries := cons(s, rres.Entries)
                    setRow!(res, k, rres)

        res


)abbrev package CKP CartanKuranishi
++ Description:
++ \spadtype{CartanKuranishi} is a package for the completion of a
++ given differential equation to an involutive equation.
++ Procedures for Cartan characters and Hilbert polynomial are also provided.
++ Based on the Cartan-Kuranishi theorem as it is used in formal theory.

CartanKuranishi(JB : JBC, D : JBFC) : Cat == Def where

  L      ==>  List
  V      ==>  Vector
  I      ==>  Integer
  B      ==>  Boolean
  Sy     ==>  Symbol
  PI     ==>  PositiveInteger
  NNI    ==>  NonNegativeInteger
  OUT    ==>  OutputForm
  FI     ==>  Fraction Integer
  PFR    ==>  SparseUnivariatePolynomial(FI)
  JBC    ==>  JetBundleCategory
  JBFC   ==>  JetBundleFunctionCategory JB
  DE     ==>  JetDifferentialEquation(JB, D)
  SEM    ==>  SparseEchelonMatrix(JB, D)
  TEX    ==>  TexFormat

  CREC   ==>  Record(IDe : DE, ISys : L D, _
                   Order : NNI, NumProj : NNI, Dim : NNI, CarChar : L NNI)
  NREC   ==>  Record(I : NNI, K : NNI, Q : NNI)
  MVREC  ==> Record(Rank : NNI, NumMultVar : NNI, Betas : L NNI)

  errmsg1 ==> "independent equations lost during prolongation!!!"

  Cat ==> with

      setOutMode : NNI -> NNI
        ++ \spad{setOutput(i)} controls amount of generated output
        ++ during the completion algorithm:
        ++ \spad{i = 0} --> no display,
        ++ \spad{i = 1} --> result is displayed,
        ++ \spad{i = 2} --> Cartan characters are displayed,
        ++ \spad{i = 3} --> integrability conditions are traced,
        ++ \spad{i = 4} --> intermediate dimensions are traced,
        ++ \spad{i = 5} --> all intermediate systems are traced,
        ++ \spad{i = 6} --> all intermediate systems and symbols are traced,
        ++ if \spad{i > 10} then TeX output is produced.
        ++ Default is 0. The old value is returned.

      setSimpMode : NNI -> NNI
        ++ \spad{setSimpMode(i)} sets the simplification mode used in
        ++ \spad{JetDifferentialEquation}. Returns old value.

      setRedMode : NNI -> NNI
        ++ \spad{setRedMode(i)} sets the flag for the reduction mode.
        ++ Returns old value. Current values are:
        ++ \spad{i = 0} --> No reduction of integrability conditions etc.
        ++ \spad{i = 1} --> Autoreduction of complete system and reduction
        ++                 of all integrability conditions.
        ++ Default is 0.

      stirling : (NNI, NNI, NNI) -> NNI
        ++ \spad{stirling(i, k, q)} computes the corresponding modified
        ++ Stirling number.

      alpha : (NNI, L NNI) -> L NNI
        ++ \spad{alpha(q, beta)} computes the Cartan characters for a
        ++ differential equation of order \spad{q} and with characters
        ++ \spad{beta}.

      hilbert : L NNI -> PFR
        ++ \spad{hilbert(cc)} computes the Hilbert polynomial to the
        ++ Cartan characters \spad{cc}.

      alphaHilbert : PFR -> L NNI
        ++ \spad{alphaHilbert(hp)} computes the Cartan characters for the
        ++ Hilbert polynomial \spad{hp}.

      arbFunctions : (NNI, I, L NNI) -> L I
        ++ \spad{arbFunctions(q, j, cc)} uses the Cartan characters \spad{cc}
        ++ to compute the number of arbitrary functions of differentiation
        ++ order \spad{j} in the general solution of a differential equation
        ++ of order \spad{q}.

      gauge : (NNI, I, L NNI) -> L I
        ++ \spad{gauge(q, j, gamma)} computes the gauge corrections to the
        ++ number of arbitrary functions of differentiation order \spad{j}
        ++ for a system of order \spad{q} with \spad{gamma} gauge functions.

      gaugeHilbert : (NNI, L NNI) -> PFR
        ++ \spad{gaugeHilbert(q, gamma)} computes the gauge correction to
        ++ the Hilbert polynomial for a system of order \spad{q} with
        ++ \spad{gamma} gauge functions.

      bound : (NNI, NNI, NNI) -> NNI
        ++ \spad{bound(n, m, q)} computes an upper bound for the number of
        ++ prolongations needed to make the symbol of an equation of order
        ++ \spad{q} with \spad{n} independent and \spad{m} dependent
        ++ variables involutive.

      complete : DE -> Void
        ++ \spad{complete(de)} completes \spad{de} to an involutive equation.
        ++ No result is returned; the display depends of the setting of the
        ++ output flags with \spadfun{setOutput}.

      complete2 : DE -> CREC
        ++ \spad{complete2(de)} is like \spadfun{complete} but returns
        ++ the involutive equation \spad{IDe}, a basis \spad{ISys} for the
        ++ involutive system without prolongations, its order \spad{Order},
        ++ the number \spad{NumProj} of needed projections and the Cartan
        ++ characters \spad{CarChar}.

  Def ==> add

      import from JetDifferentialEquation(JB, D)

      n : PI := numIndVar()$JB
      m : PI := numDepVar()$JB
        -- global constants for number of independent and dependent variables
      ode : B := one? n

      -- ----- --
      -- Flags --
      -- ----- --

      redMode : NNI := 0          -- global flag for reduction mode
      TeX : B   := false        -- global flag for TeX output
      Out : NNI := 0            -- global flag for amount of tracing

      setSimpMode(i : NNI) : NNI == setSimpMode(i)$DE

      setRedMode(i : NNI) : NNI ==
          j := redMode
          redMode := i
          j

      setOutMode(i : NNI) : NNI ==
          j := Out
          if TeX then
              j := j+10
          TeX := (i > 10)
          if TeX then
              Out := i rem 10
          else
              Out := i
          j

      -- ------------------ --
      -- Display of results --
      -- ------------------ --

      write(str : OUT) : Void ==
          -- Prints str according to the setting of TeX.
          if TeX then
              display(str::TEX)$TEX
          else
              print(str)$OUT
          void

      outR(q : NNI, s : NNI) : OUT ==
          -- Output form for R(q, s).
          zero? s => sub(message "R", q::OUT)
          supersub(message "R", [q::OUT, paren(s::OUT)])

      outM(q : NNI, s : NNI) : OUT ==
          -- Output form for M(q, s).
          zero? s => sub(message "M", q::OUT)
          supersub(message "M", [q::OUT, paren(s::OUT)])

      info(flag : NNI, q : NNI, s : NNI, dim : NNI) : Void ==
          -- Displays some trace information.
          Out < 4 => void
          write message(" ")
          if flag = 1 then
              write(hconcat [message("Symbol "), outM(q, s),
                             message(" involutive! "),
                             message("Dimension: "), dim::OUT])
          else if flag = 2 then
              write(hconcat [message("Symbol "), outM(q, s),
                             message(" not involutive! "),
                             message("Dimension: "), dim::OUT])
          else
              write(hconcat [message("Equation "), outR(q, s),
                             message(" not involutive! "),
                             message("Dimension: "), dim::OUT])
          void

      display(q : NNI, s : NNI, Sys : L D, Symb : SEM, DimRq : NNI,
              DimMq : NNI) : Void ==
          -- Displays intermediate systems and symbols.
          Out < 5 => void
          write message(" ")
          write message("****************************************")
          write message(" ")
          write hconcat(message("Order: "), q::OUT)
          write hconcat(message("Projections: "), s::OUT)
          write hconcat(message(
             "System without prolonged equations. Dimension: "),
                          DimRq::OUT)
          write printSys Sys
          if Out > 5 then
              write message(" ")
              write hconcat(message("Symbol. Dimension: "), DimMq::OUT)
              write(Symb::OUT)
          void

      displayIntCond(s : NNI, Cond : L D) : Void ==
          -- Displays integrability conditions.
          Out < 3 => void
          write message(" ")
          write hconcat [message("======= "), s::OUT,
                         message(". Projection =======")]
          write message("Integrability condition(s)")
          write printSys Cond
          write message("=============================")
          void

      displayCartan(Sys : L D, dim : NNI, q : NNI, s : NNI,
                    CarChar : L NNI) : Void ==
          -- Displays final result.
          Out = 0 => void
          write message(" ")
          write message("*************** Final Result ***************")
          write message(" ")
          write hconcat [message("Equation "), outR(q, s),
                         message(" involutive!")]
          write hconcat(
             message("System without prolonged equations. Dimension: "),
                        dim::OUT)
          write printSys Sys
          if Out > 1 then
              write message(" ")
              if zero? reduce("+", CarChar, 0) then
                  write message("System of finite type.")
              else
                  write hconcat(message("Cartan characters: "), _
                          commaSeparate [cc::OUT for cc in CarChar])
          void

      -- ----------------- --
      -- Cartan Characters --
      -- ----------------- --

      -- stirling uses a recursion. To avoid unnecessary recomputations a
      -- table with already computed values is set up.

      remember : Table(NREC, NNI) := dictionary()

      stirling(i : NNI, k : NNI, q : NNI) : NNI ==
          -- Evaluates the symmetric polynomial of degree k in i variables
          -- for the values q+1, ..., q+i.
          k > i => error "Symmetric polynomial not defined"
          zero? i => 1
          zero? k => 1
          ans := search([i, k, q], remember)
          ans case NNI => ans::NNI

          if one? k then
              res := reduce("+", [q + j for j in 1..i])
          else if k = i then
              res := reduce("*", [q + j for j in 1..i])
          else
              res := stirling((i - 1)::NNI, k, q) + _
                     (q + i)*stirling((i - 1)::NNI, (k - 1)::NNI, q)
          setelt!(remember, [i, k, q], res)

      alpha(q : NNI, beta : L NNI) : L NNI ==
          -- Computes Cartan characters from numbers of
          -- multiplicative variables.
          [(m*binomial(q+n-i-1, q-1)$I-bi)::NNI  for bi in beta for i in 1..n]

      hilbert(CarChar : L NNI) : PFR ==
          -- Construction of Hilbert polynomial.
          res : PFR := 0
          ifac : I := 1
          for i in 0..(n - 1) repeat
              coeff : FI := 0
              kfac := ifac
              for k in i..(n - 1) repeat
                  if k > 0 then
                      kfac := k*kfac
                  coeff := coeff + qelt(CarChar, k + 1) * _
                               stirling(k::NNI, (k - i)::NNI, 0)/kfac
              res := res + monomial(retract(coeff), i::NNI)
              if i > 0 then
                  ifac := i*ifac
          res

      alphaHilbert(hilp : PFR) : L NNI ==
          -- Cartan characters from Hilbert polynomial
          res : L NNI := empty
          ifac := factorial(n)$I
          for i in n..1 by -1 repeat
              sum : FI := 0
              kfac := ifac
              ifac := ifac quo i
              for k in (i + 1)..n repeat
                  sum := sum + stirling((k - 1)::NNI, (k - i)::NNI, 0)* _
                                        qelt(res, k - i)/kfac
                  kfac := k*kfac
              ai : I := retract(ifac*(coefficient(hilp, (i - 1)::NNI) - sum))
              res := cons(ai::NNI, res)
          res

      arbFunctions(q : NNI, j : I, CarChar : L NNI) : L I ==
          -- Number of arbitrary functions of differentiation order j
          -- in general solution.
          res : L I := [CarChar.n]
          ifac := factorial(n - 1)$I
          for i in (n-1)..1 by -1 repeat
              t : FI := 0
              ifac := ifac quo i
              kfac := ifac
              for k in i..(n-1) repeat
                  ki := (k - i + 1)::NNI
                  kfac := k*kfac
                  t := t + (qelt(CarChar, k + 1)*stirling(k::NNI, ki, 0) - _
                      qelt(res, ki)*stirling(k::NNI, ki, (q + j)::NNI))/kfac
              t := qelt(CarChar, i)::FI + t*ifac
              res := cons(retract(t), res)
          res

      gauge(q : NNI, j : I, gamma : L NNI) : L I ==
          -- Gauge corrections to number of arbitrary functions of
          -- differentiation order j.
          gp := #gamma
          zero? gp => new(n, 0)
          res : L I := [reduce("+", gamma)]
          n1 : I := n-1
          ifac := factorial(n1)$I
          rnf : FI := 1/ifac
          for i in n1..1 by -1 repeat
              t : FI := 0
              for l in 0..(gp-1) for g in gamma repeat
                  t := t + (g*stirling(n1::NNI, (n - i)::NNI,
                                       (q + l)::NNI))::I::FI
              t := t*rnf
              ifac := ifac quo i
              kfac := ifac
              for k in i..n1 repeat
                  ki := (k - i + 1)::NNI
                  kfac := k*kfac
                  t := t - qelt(res, ki)*stirling(k::NNI, ki, (q+j)::NNI)/kfac
              t := t*ifac
              res := cons(retract(t), res)
          res

      gaugeHilbert(q : NNI, gamma : L NNI) : PFR ==
          -- Gauge correction to Hilbert polynomial.
          gp := #gamma
          zero? gp => 0
          res : PFR := 0
          rnf : FI := 1/factorial(n - 1)$I
          for k in 0..(n - 1) repeat
              t : NNI := 0
              for l in 0..(gp - 1) for g in gamma repeat
                  t := t + g*stirling((n - 1)::NNI, (n - k - 1)::NNI, _
                                      (q + l)::NNI)
              res := res + monomial(t*rnf, k)
          res

      -- -------------------- --
      -- Completion Algorithm --
      -- -------------------- --

      bound(nn : NNI, mm : NNI, qq : NNI) : NNI ==
          -- Upper bound for number of needed prolongations.
          one? qq =>
              zero? nn => 0
              tmp := bound((nn - 1)::NNI, mm, 1)
              (1 + tmp + mm*binomial(nn + tmp, nn - 1)$I)::NNI
          bound(nn, (mm*binomial(qq + nn - 1, nn)$I)::NNI, 1)

      complete(De : DE) : Void ==
          tmp := complete2 De
          void

      complete2(De : DE) : CREC ==
          -- Completion procedure.
          -- In the loop all variables with prefix Prev refer to objects
          -- of order q; all with prefix Cur are of order q+1.
          PrevDe, CurDe, ProjDe : DE
          PrevSymb, CurSymb : SEM
          PrevSymbDim, CurSymbDim : NNI
          PrevDeDim, CurDeDim, ProjDeDim : NNI
          PrevMV, CurMV : MVREC

          PrevDe := simplify(De).SDe
          CompSys := retract PrevDe             -- basis for complete system
          if redMode > 0 then
              CompSys := autoReduce CompSys
          PD := prolong PrevDe
          CurDe := PD.SDe
          ICs := PD.IC                          -- integrability conditions
          if (redMode > 0) and not(empty? ICs) then
              ICs := autoReduce reduceMod(ICs, CompSys)

          q := order De                         -- counter for order
          s := 0$NNI                            -- counter for projections
          q1 := q + 1
          dimSq := dimS(q)$JB
          dimSq1 := dimS(q1)$JB
          InvDe : B := false
          InvSymb : B := ode
          solved? : B := (Out > 5)

          until InvDe repeat
              PrevDeDim := dimension(PrevDe, q)
              CurDeDim := dimension(CurDe, q1)
              if not ode then
                  PrevSymb := extractSymbol(PrevDe, solved?)
                  PrevMV := analyseSymbol PrevSymb
                  PrevSymbDim := (dimSq - PrevMV.Rank)::NNI
                  if zero? PrevSymbDim then
                      CurSymb := prolongSymbol PrevSymb
                      CurMV := prolongMV PrevMV
                      CurSymbDim := 0$NNI
                  else
                      CurSymb := extractSymbol(CurDe, solved?)
                      CurMV := analyseSymbol CurSymb
                      CurSymbDim := (dimSq1 - CurMV.Rank)::NNI
                  InvSymb := (PrevMV.NumMultVar = CurMV.Rank)

              display(q, s, CompSys, PrevSymb, PrevDeDim, PrevSymbDim)

              while not InvSymb repeat
                  CurMV.Rank < PrevMV.NumMultVar => error errmsg1
                  info(2, q, s, PrevSymbDim)
                  q := q1                           -- prolongation
                  q1 := q1+1
                  dimSq := dimSq1
                  dimSq1 := dimS(q1)$JB

                  PrevDe := CurDe
                  PrevSymb := CurSymb
                  PrevMV := CurMV
                  PrevDeDim := CurDeDim
                  PrevSymbDim := CurSymbDim

                  PD := prolong PrevDe
                  CurDe := PD.SDe
                  if zero? PrevSymbDim then
                      CurSymb := prolongSymbol PrevSymb
                      CurMV := prolongMV PrevMV
                      CurSymbDim := 0$NNI
                  else
                      CurSymb := extractSymbol(CurDe, solved?)
                      CurMV := analyseSymbol CurSymb
                      CurSymbDim := (dimSq1 - CurMV.Rank)::NNI
                  CurDeDim := dimension(CurDe, q1)
                  if not empty? PD.IC then
                      if redMode > 0 then
                          ICs := autoReduce concat!(ICs,
                                              reduceMod(PD.IC, CompSys))
                      else
                          ICs := concat!(ICs, PD.IC)
                  InvSymb := (PrevMV.NumMultVar = CurMV.Rank)

              if ode then
                  ProjDe := project(CurDe, q)
                  ProjDeDim := dimension(ProjDe, q)
              else
                  info(1, q, s, PrevSymbDim)
                  ProjDeDim := (CurDeDim - CurSymbDim)::NNI
              InvDe := (ProjDeDim = PrevDeDim)

              if not InvDe then
                  info(3, q, s, PrevDeDim)
                  s := s + 1                          -- projection
                  displayIntCond(s, ICs)
                  if redMode > 0 then
                      CompSys := autoReduce concat!(CompSys, ICs)
                  else
                      CompSys := concat!(CompSys, ICs)
                  if ode then
                      PrevDe := ProjDe
                  else
                      PrevDe := project(CurDe, q)
                  PD := prolong(CurDe, q1)
                  CurDe := PD.SDe
                  if not empty? PD.IC then
                      if redMode > 0 then
                          ICs := autoReduce reduceMod(PD.IC, CompSys)
                      else
                          ICs := PD.IC
                  else
                      ICs := empty

          if ode then
              PrevSymb := extractSymbol(PrevDe, false)
              Cartan : L NNI := [rowEchelon(PrevSymb).Rank]
          else
              Cartan := alpha(q, PrevMV.Betas)
          displayCartan(CompSys, PrevDeDim, q, s, Cartan)

          [PrevDe, CompSys, q, s, PrevDeDim, Cartan]


)abbrev domain JBSA JetBundleSymAna
++ Description:
++  \spad{JetBundleSymAna} is only necessary to have a valid return type for
++  some procedures in \spad{SymmetryAnalysis}. It is essentially identical
++  with \spad{JetBundle} but computes its parameters in a more complicated
++  way.

JetBundleSymAna(JB1 : JBC, xi : US, eta : US) : Cat == Def where

  Sy   ==> Symbol
  L    ==> List
  US   ==> Union(Sy, L Sy)
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  EI   ==> Expression Integer
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory

  Cat ==> JBC with

    coerce : Sy -> %
      ++ \spad{coerce(s)} allows for the input of jet variables as symbols.

    D : (Sy, L Sy) -> %
     ++ \spad{D(u, der)} generates a derivative.

  Def ==> add

    nn : PI := numIndVar()$JB1
    mm : PI := numDepVar()$JB1

    vars : L JB1 := concat!([X(i::PI)$JB1  for i in 1..nn], _
                          [U(i::PI)$JB1  for i in 1..mm])
    indVars : L(Sy) := [name(jv)  for jv in vars]
    depVars : L(Sy) := empty()
    if xi case Sy then
        if nn > 1 then
            depVars := [superscript(xi::Sy, [i::OUT])  for i in 1..nn]
        else
            depVars := [xi::Sy]
    else
        depVars := xi::L(Sy)
    if eta case Sy then
        if mm > 1 then
            depVars := append(depVars, _
                          [superscript(eta::Sy, [i::OUT])  for i in 1..mm])
        else
            depVars := append(depVars, [eta::Sy])
    else
        depVars := append(depVars, eta::L(Sy))

    Rep := JetBundle(indVars, depVars)

    setNotation(s : Sy) : Sy ==
        print(message("only repeated index notation possible"))$OUT
        'Repeated

    getNotation() : Sy == 'Repeated

    multiIndex(jv : %) : L NNI == multiIndex(jv)$Rep

    index(jv : %) : PI == index(jv)$Rep

    type(jv : %) : Sy == type(jv)$Rep

    X(up : PI) : % == X(up)$Rep

    U(up : PI) : % == U(up)$Rep

    Pm(up : PI, lo : L NNI) : % == Pm(up, lo)$Rep

    coerce(s : Sy) : % == coerce(s)$Rep

    D(u : Sy, der : L Sy) : % == D(u, der)$Rep

    1 : % == 1$Rep

    numIndVar() : PI == (nn+mm)::PI

    numDepVar() : PI == (nn+mm)::PI

    name(jv : %) : Sy == name(jv)$Rep

    coerce(jv : %) : EI == coerce(jv)$Rep


)abbrev package SYMANA SymmetryAnalysis
++ Description:
++ \spad{SymmetryAnalysis(JB, xi, eta)} provides procedures for the symmetry
++ analysis of differential equations over a given jet bundle. Currently there
++ exist only some procedures to set up the determining system for the symmetry
++ generators of Lie point symmetries.

SymmetryAnalysis(JB1 : JBC, xi : US, eta : US) : Cat == Def where

  Sy   ==> Symbol
  L    ==> List
  US   ==> Union(Sy, L Sy)
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  EQ   ==> Equation
  EI   ==> Expression Integer
  K    ==> Kernel EI
  BOP  ==> BasicOperator
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory
  JBE1 ==> JetBundleExpression JB1
  JB2  ==> JetBundleSymAna(JB1, xi, eta)
  JBX2 ==> JetBundleXExpression JB2
  JBE2 ==> JetBundleExpression JB2
  JBL2 ==> JetBundleLinearFunction(JB2, JBX2)
  JP1  ==> SparseMultivariatePolynomial(EI, JB1)
  VF1  ==> JetVectorField(JB1, JBE1)

  Indep ==> "Indep"::Sy
  Dep   ==> "Dep"::Sy


  Cat ==> with

    ansatz : () -> VF1
      ++ \spad{ansatz()} returns a general ansatz for a symmetry generator.

    transform : JBE1 -> JBE2
      ++ \spad{transform(f)} transforms expressions between the different
      ++ function types involved.

    linearize : L JBE2 -> L JBL2
      ++ \spad{linearize(sys)} tries to retract all equations in \spad{sys}
      ++ to a linear one. If that is not possible, an error occurs.

    detSys : L JBE1 -> L JBE2
      ++ \spad{detSys(sys)} computes the determining system for symmetry
      ++ generators of the system \spad{sys}. It is assumed that each
      ++ equation can be solved for its leading derivative.

    detSys : (L JBE1, VF1) -> L JBE1
      ++ \spad{detSys(sys, vf)} computes the determining system for symmetry
      ++ generators of the system \spad{sys} with a given ansatz for the
      ++ generators. It is assumed that each equation can be solved for its
      ++ leading derivative.

    detSys : (L JBE1, L JB1, VF1) -> L JBE1
      ++ \spad{detSys(sys, sjb, vf)} computes the determining system for symmetry
      ++ generators of the system \spad{sys} with a given ansatz for the
      ++ generators. \spad{sjb} contains jet variables for which the individual
      ++ equations can be solved.

    ncDetSys : L JBE1 -> L JBE2
      ++ \spad{ncDetSys(sys)} computes the determining system for generators of
      ++ conditional symmetries of \spad{sys}. It makes the same assumptions as
      ++ \spad{detSys}.

    ncDetSys : (L JBE1, VF1) -> L JBE1
      ++ \spad{ncDetSys(sys, vf)} computes the determining system for generators
      ++ of conditional symmetries of \spad{sys} with a given ansatz for the
      ++ vector fields.

    ncDetSys : (L JBE1, L JB1, VF1) -> L JBE1
      ++ \spad{ncDetSys(sys, sjb, vf)} computes the determining system for
      ++ generators of conditional symmetries of \spad{sys}. The meaning of the
      ++ further arguments is the same as in \spad{detSys}.

    detSysNS : L JBE1 -> L JBE2
      ++ \spad{detSysNS(sys, vf)} computes the determining system for symmetry
      ++ generators without assuming solvability of the equations for some
      ++ derivatives.

    detSysNS : (L JBE1, VF1) -> L JBE1
      ++ \spad{detSysNS(sys, vf)} computes the determining system for symmetry
      ++ generators without assuming solvability of the equations for some
      ++ derivatives.


  Def ==> add

    import from VF1

    nn : PI := numIndVar()$JB1
    mm : PI := numDepVar()$JB1
    -- global variables for the number of variables

    vars : L JB1 := concat!([X(i::PI)$JB1  for i in 1..nn], _
                            [U(i::PI)$JB1  for i in 1..mm])
    indVars : L Sy := [name(jv)  for jv in vars]
    depVars : L Sy := empty
    if xi case Sy then
        if nn > 1 then
            depVars : L Sy := [superscript(xi::Sy, [i::OUT])  for i in 1..nn]
        else
            depVars : L Sy := [xi::Sy]
    else
        depVars : L Sy := xi::L Sy
    if eta case Sy then
        if mm > 1 then
            depVars := append(depVars, _
                          [superscript(eta::Sy, [i::OUT])  for i in 1..mm])
        else
            depVars := append(depVars, [eta::Sy])
    else
        depVars : L Sy := append(depVars, eta::L Sy)
    JVars : L JBE1 := [jv::JBE1  for jv in vars]


    -- --------- --
    -- Utilities --
    -- --------- --

    ansatz() : VF1 ==
        -- returns most general ansatz for a vector field
        -- on the base bundle.
        res : VF1 := 0
        for i in 1..nn repeat
            s := qelt(depVars, i)
            f : JBE1 := function(s, JVars, 0)
            res := res + f*diffX(i::PI)

        for i in 1..mm repeat
            s := qelt(depVars, nn + i)
            f : JBE1 := function(s, JVars, 0)
            res := res + f*diffU(i::PI)

        res


    transform(f : JBE1) : JBE2 ==
        JV : L EI := empty
        SubL : L K := empty
        LKernels := tower f
        LOps := [operator Ke  for Ke in LKernels]
        for Ke in LKernels  for Op in LOps repeat
            has?(Op, "%jet"::Sy)$BOP =>
                typ := property(Op, "%jet"::Sy)::None pretend Sy
                typ = 'Deriv =>
                    error "function contains illegal jet variables in transform"
                ind : I := retract second argument Ke
                JV := cons(X(ind::PI)$JB2::EI, JV)
                if ind > nn then
                    SubL := cons(first kernels(U((ind - nn)::PI)$JB1::EI), SubL)
                else
                    SubL := cons(first kernels(X(ind::PI)$JB1::EI), SubL)
            fname := name Op
            pos := position(fname, depVars)
            if pos >= minIndex(depVars) then
                arg := argument Ke
                if #arg > 3 then
                    arg := rest arg
                    num : I := retract first arg
                    arg := rest rest arg
                    rarg : L JBE1 := empty
                    for i in 1..num repeat
                        rarg := cons(first arg, rarg)
                        arg := rest arg
                    rarg := reverse! rarg
                    diff : L JBE1 := arg
                    if empty? diff then
                        JV := cons(U(pos::PI)$JB2::EI, JV)
                        SubL := cons(first kernels(Ke::JBE1::EI), SubL)
                    else
                        up := pos::PI
                        lower : L PI := empty
                        for d in diff repeat
                            id : I := retract d
                            --a := qelt(rarg, id)
                            lower := cons(id::PI, lower)
                        lower := reverse! lower
                        JV := cons(Pr(up, lower)$JB2::EI, JV)
                        SubL := cons(first kernels(Ke::JBE1::EI), SubL)

        g : EI := eval(f::EI, SubL, JV)
        g::JBE2


    --linearize(sys : L JBE2) : L JBL2 ==
    --  res : L JBL2 := empty
    --  for eq in sys repeat
    --    tmp : Union(JBL2, "failed") := retractIfCan(eq)$JBL2
    --    tmp case "failed" => error "non-linear equation in linearize"
    --    res := cons(tmp::JBL2, res)
    --  reverse! res


    -- ------------------ --
    -- Determining System --
    -- ------------------ --

    detSys(sys : L JBE1) : L JBE2 ==
        ds := detSys(sys, [leadingDer eq  for eq in sys], ansatz())
        [transform eq  for eq in ds]


    detSys(sys : L JBE1, vf : VF1) : L JBE1 ==
        detSys(sys, [leadingDer eq  for eq in sys], vf)


    detSys(sys : L JBE1, sjb : L JB1, vf : VF1) : L JBE1 ==
        -- solving equations for given jet variable
        solEq : L EQ JBE1 := empty
        for eq in sys   for jv in sjb repeat
            tmp := solveFor(eq, jv)
            tmp case "failed" => error "cannot solve in detsys"
            solEq := cons(jv::JBE1 = tmp::JBE1, solEq)
        solEq := reverse! solEq

        -- determining conditions
        ol : L NNI := [order eq  for eq in sys]
        o := reduce(max, ol, 0)
        -- o := reduce(max, [order(eq)$JBE1  for eq in sys], 0)
        pvf := prolong(vf, o)
        crit : L JBE1 := [eval(pvf, eq)  for eq in sys]
        pcrit : L JP1 := [numerJP eval(eq, solEq)  for eq in crit]
        coL := [coefficients jp  for jp in pcrit]
        conds := reduce(append, coL, empty)
        -- conds := reduce(append, [coefficients jp  for jp in pcrit], empty)
        [co::JBE1  for co in conds]


    -- ---------------------- --
    -- Conditional Symmetries --
    -- ---------------------- --

    ncDetSys(sys : L JBE1) : L JBE2 ==
        ds := ncDetSys(sys, [leadingDer eq  for eq in sys], ansatz())
        [transform eq  for eq in ds]


    ncDetSys(sys : L JBE1, vf : VF1) : L JBE1 ==
        ncDetSys(sys, [leadingDer eq  for eq in sys], vf)


    ncDetSys(sys : L JBE1, sjb : L JB1, vf : VF1) : L JBE1 ==
        dirs := directions vf
        coeffs := coefficients vf
        Xi : L JBE1 := empty
        tmp : L JBE1 := empty
        ind1 : L PI := empty
        ind2 : L PI := empty

        -- separating independent and dependent variables
        for jv in dirs  for co in coeffs repeat
            jt := type jv
            if jt = Indep then
                Xi := cons(co, Xi)
                ind1 := cons(index(jv), ind1)
            else if jt = Dep then
                tmp := cons(co, tmp)
                ind2 := cons(index(jv), ind2)
            else
                error "Only independent and dependent variables allowed"

        -- closing gaps in eta
        j : I := mm
        Eta : L JBE1 := empty
        for co in tmp  for i in ind2 repeat
            while j > i repeat
                Eta := cons(0, Eta)
                j := j-1
            Eta := cons(co, Eta)
            j := j-1
        if not zero? j then
            for i in 1..j repeat
                Eta := cons(0, Eta)

        -- invariant surface conditions
        isc : L JBE1 := empty
        ijb : L JB1 := empty
        for e in Eta  for j in 1..mm repeat
            cond : JBE1 := -e
            jv : JB1 := 1
            for x in Xi  for i in ind1 repeat
                if not zero? x then
                    jv := Pr(j::PI, [i::PI])$JB1
                    cond := cond + x*(jv::JBE1)
            one? jv => error "cannot solve invariant surface condition"
            ijb := cons(jv, ijb)
            isc := cons(cond, isc)

        detSys(append(isc, sys), append(ijb, sjb), vf)


)abbrev domain JLF JetLazyFunction
++ Description:
++  \spadtype{JetLazyFunction} takes as argument a domain in
++  \spadtype{JetBundleFunctionCategory} and returns another domain in the
++  same category. This domain has basically the same properties as the
++  argument domain, but there is a lazy evaluation mechanism for derivatives.
++  This means that differentiations are not immediately performed. Instead a
++  pointer is established to the function to be differentiated. Only when the
++  exact value of the derivative is needed, the differentiation is executed.
++  Special care is taken for leading derivatives and jet variables to avoid as
++  much as possible the need to evaluate expressions. This entails that the
++  result of \spad{jetVariables} may contain spurious variables. Furthermore
++  many functions in \spadtype{JetLazyFunction} destructively change their
++  arguments. This affects, however, only their internal representation, not
++  the value obtained after full evaluation.

JetLazyFunction(JB : JBC, D : JBFC) : Cat == Def where

  Sy   ==> Symbol
  B    ==> Boolean
  L    ==> List
  M    ==> Matrix
  I    ==> Integer
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  OUT  ==> OutputForm
  REF  ==> Reference
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory JB
  SEM  ==> SparseEchelonMatrix(JB, %)
  UDS  ==> Union(D, %)

  SREC     ==> Record(Dep : L NNI, Fun : %)
  SIMPREC  ==> Record(Sys : L %, JM : SEM, Depend : Union("failed", L L NNI))

  Const  ==> "Const"::Sy
  Null   ==> "0"::Sy


  Cat ==> JBFC with

    lazyRepresentation
      ++ The representation contains a lazy evaluation scheme.

    coerce : D -> %
      ++ \spad{coerce(d)} coerces an element of \spad{D} into the new domain.
      ++ This includes the calculation of its leading derivative and its jet
      ++ variables.

    coerce : % -> D
      ++ \spad{coerce(exp)} retracts an element to the base domain \spad{D}.
      ++ This looses all information about its leading derivative and its
      ++ jet variables and requires complete evaluation of the expression.

    collect : % -> %
      ++ \spad{collect(exp)} "collects" former lazy terms which have been
      ++ meanwhile evaluated.

    eval1 : % -> %
      ++ \spad{eval1(exp)} explicitly evaluates the next term in \spad{exp}.
      ++ \spad{exp} is destructively altered.

    eval : % -> %
      ++ \spad{eval(exp)} explicitly evaluates all terms in \spad{exp}.
      ++ \spad{exp} is destructively altered.

    ground? : % -> B
      ++ \spad{ground(exp)} is true, if \spad{exp} contains only fully
      ++ evaluated parts.

    "*" : (D, %) -> %
      ++ \spad{d*exp} is provided mainly for internal use, as basically all
      ++ calculations should be performed within \spadtype{JetLazyFunction}.

    eqRep? : (%, %) -> B
      ++ \spad{eqRep?(x, y)} compares the representations of \spad{x} and
      ++ \spad{y} without any evaluation. Thus it is much weaker than \spad{=}
      ++ and cannot decide equality of the evaluated expressions.

    statistics : () -> Void
      ++ \spad{statistics()} prints a statistic on the use of the lazy
      ++ evaluation mechanism. It displays the number of lazy differentiations
      ++ performed and how many of them had to be executed explicitly later on.

  Def ==> add

    LazyDiff : NNI := 0
    LazyEval : NNI := 0
      -- global variables for statistics

    statistics() : Void ==
        print(assign(message("Number of lazy differentiations"),
                     LazyDiff::OUT))$OUT
        print(assign(message("Number of subsequent evaluations"),
                     LazyEval::OUT))$OUT
        void


    -- -------------- --
    -- Representation --
    -- -------------- --

    -- The representation consists of a three layer hierarchy connected by
    -- references. The evaluation routines will always reset the references
    -- in order to affect all elements containing them. The flags store
    -- information about the evaluation done so far. LD and LLD represent
    -- upper bounds for the leading derivative, Sharp? and LSharp? indicate
    -- whether they are sharp. If DEval? is true, then the differentiation
    -- was already performed and DFun contains the result. Otherwise DFun
    -- should be differentiated wrt DX. JV1 contains the jet variables of
    -- which it is known that they occur in the expression; the ones in JV2
    -- may or may not occur.

    LazyDer := Record(DEval? : B, DX : Union(JB, Sy), DFun : UDS)

    LazyTerm := Record(LLD : JB, LSharp? : B, LEval? : B, _
                       LCoeff : UDS, LDer : REF LazyDer)

    RepRec := Record(LD : JB, Sharp? : B, Ground? : B, JV1 : L JB, JV2 : L JB, _
                     Lazy : L REF LazyTerm)

    Rep := REF RepRec


    -- --------------- --
    -- Local Functions --
    -- --------------- --

    emptyDer : LazyDer := [true, Null, 1$D]

    zeroRec : RepRec := [1$JB, true, true, empty, empty, _
                       [ref [1$JB, true, true, 0$D, ref emptyDer]]]


    emptyDer?(der : LazyDer) : B ==
        der.DX ~= Null => false
        der.DFun case % => false
        one?(der.DFun::D)$D


    groundFlag?(exp : %) : B == deref(exp).Ground?


    extract(exp : %) : D ==
        -- assumes that ground?(exp) = true!
        deref(first(deref(exp).Lazy)).LCoeff::D


    jetVars(f : UDS) : L JB ==
        f case D => jetVariables(f::D)$D
        jetVariables(f::%)


    greater(lt1 : REF LazyTerm, lt2 : REF LazyTerm) : B ==
        deref(lt1).LLD > deref(lt2).LLD


    lazyTerm(d : D) : LazyTerm ==
        [leadingDer(d)$D, true, true, d, ref emptyDer]$LazyTerm


    convert(lt : LazyTerm) : % ==
        JV := removeDuplicates! _
              merge(">", jetVars(lt.LCoeff), jetVars(deref(lt.LDer).DFun))
        ref [lt.LLD, lt.LSharp?, lt.LEval?, empty, JV, [ref lt]]


    adapt(rec : RepRec, newLazy : L REF LazyTerm) : RepRec ==
        -- adapts values for LD etc. to new list newLazy
        empty? newLazy => zeroRec
        lt := deref first newLazy
        newLD := lt.LLD
        newSharp? := lt.LSharp? and _
                   (empty?(rest newLazy) or (newLD > deref(second(newLazy)).LLD))
        newJV1 := rec.JV1
        while not(empty? newJV1) and first(newJV1) > newLD repeat
            newJV1 := rest newJV1
        newJV2 := rec.JV2
        while not(empty? newJV2) and first(newJV2) > newLD repeat
            newJV2 := rest newJV2
        [newLD, newSharp?, rec.Ground?, newJV1, newJV2, newLazy]


    zeroU?(f : UDS) : B ==
        f case D => zero?(f::D)$D
        zero?(f::%)


    oneU?(f : UDS) : B ==
        f case D => one?(f::D)$D
        one?(f::%)


    minus(f : UDS) : UDS ==
        f case D => -$D (f::D)
        fs := f::%
        groundFlag? f => -$D extract fs
        - fs


    mult(f : UDS, g : UDS) : UDS ==
        f case D =>
            fd := f::D
            g case D => fd *$D (g::D)
            gs := g::%
            groundFlag? gs => fd *$D extract gs
            fd * gs
        fs := f::%
        g case D => (g::D) * fs
        gs := g::%
        groundFlag? gs => extract(gs) * fs
        fs * gs


    multLazy(rlt1 : REF LazyTerm, rlt2 : REF LazyTerm) : REF LazyTerm ==
        resLD : JB
        resSharp?, resEval? : B
        resCoeff : UDS
        resDer : REF LazyDer
        lt1 := deref rlt1
        lt2 := deref rlt2
        if lt1.LLD > lt2.LLD then
            resLD := lt1.LLD
            resSharp? := lt1.LSharp?
        else if lt1.LLD < lt2.LLD then
            resLD := lt2.LLD
            resSharp? := lt2.LSharp?
        else
            resLD := lt1.LLD
            resSharp? := lt1.LSharp? or lt2.LSharp?
        resEval? := false
        if lt1.LEval? then
            resCoeff := mult(lt1.LCoeff, lt2.LCoeff)
            if lt2.LEval? then
                resDer := ref emptyDer
                resEval? := true
            else
                resDer := lt2.LDer
        else if lt2.LEval? then
            resCoeff := mult(lt1.LCoeff, lt2.LCoeff)
            resDer := lt1.LDer
        else
            resCoeff := mult(convert(lt1), lt2.LCoeff)
            resDer := lt2.LDer
        ref [resLD, resSharp?, resEval?, resCoeff, resDer]$LazyTerm


    -- --------- --
    -- Coercions --
    -- --------- --

    coerce(jv : JB) : % ==
        ref [jv, true, true, [jv], empty, _
             [ref [jv, true, true, jv::D, ref emptyDer]$LazyTerm]]$RepRec


    coerce(d : D) : % ==
        ld := leadingDer(d)$D
        JV := jetVariables(d)$D
        ref [ld, true, true, JV, empty, _
             [ref [ld, true, true, d, ref emptyDer]$LazyTerm]]$RepRec


    coerce(exp : %) : D ==
        exp := eval exp
        extract exp


    printFun(fun : UDS) : OUT ==
        fun case D => fun::D::OUT
        fun::%::OUT


    printDiff(der : LazyDer) : OUT ==
        der.DEval? => printFun der.DFun
        prefix(message("diff"@String), [printFun(der.DFun), (der.DX)::OUT])


    printLazyTerm(lt : LazyTerm) : OUT ==
        lt.LEval? => printFun lt.LCoeff
        co := lt.LCoeff
        printFun(co) * printDiff(deref lt.LDer)


    printLazy(llt : L REF LazyTerm) : OUT ==
        #llt = 1 => printLazyTerm deref first llt
        --reduce("+", [printLazyTerm(deref lt)  for lt in llt], empty$OUT)
        printLazyTerm(deref first llt) + printLazy rest llt


    coerce(exp : %) : OUT ==
        groundFlag? exp => extract(exp)::OUT
        printLazy deref(exp).Lazy


    -- --------------- --
    -- Lazy Evaluation --
    -- --------------- --

    -- All of the following functions change destructively their argument.

    collect(exp : %) : % ==
        -- Collects all ground terms.
        -- This checks especially whether since the last call some terms
        -- have been evaluated.
        rec := deref exp
        empty? rec.Lazy =>
            setref(exp, zeroRec)
            exp
        d : D := 0
        res : B := true
        newLazy : L REF LazyTerm := empty

        for rlt in rec.Lazy repeat
            lt := deref rlt
            if lt.LEval? then                -- term already evaluated
                d := d +$D (lt.LCoeff::D)
            else                             -- test for evaluated derivative
                der := deref lt.LDer
                if der.DEval? then                  -- derivative evaluated
                    if emptyDer? der then
                        prod := lt.LCoeff
                    else
                        prod := mult(der.DFun, lt.LCoeff)
                    if (prod case D) or ground?(prod::%) then
                        if prod case D then
                            newCoeff : UDS := prod
                        else
                            newCoeff : UDS := extract(prod::%)
                        newEval? := true
                        newLD := leadingDer(newCoeff::D)
                        newSharp? : B := true
                        d := d +$D (newCoeff::D)
                    else                  -- coefficient not yet evaluated
                        newEval? := false
                        newCoeff : UDS := prod
                        newLD := lt.LLD
                        newSharp? := lt.LSharp?
                        res := false
                    setref(rlt, [newLD, newSharp?, newEval?, newCoeff, _
                           ref emptyDer]$LazyTerm)
                    if not newEval? then
                        newLazy := append(newLazy, [rlt])
                else                     -- nothing evaluated  -> recursion!
                    if (lt.LCoeff case %) and ground?(lt.LCoeff::%) then
                        co := extract(lt.LCoeff::%)
                        if zero?(co)$D then
                            setref(rlt, lazyTerm 0$D)
                        else
                            lt.LCoeff := co
                            setref(rlt, lt)
                            res := false
                            newLazy := append(newLazy, [rlt])
                    else
                        res := false
                        newLazy := append(newLazy, [rlt])

        if not zero?(d)$D then
            newLazy := merge(greater, newLazy, [ref lazyTerm d])
        rec := adapt(rec, newLazy)
        rec.Ground? := res
        setref(exp, rec)
        exp


    ground?(exp : %) : B ==
        groundFlag? collect exp


    evalDeriv(rder : REF LazyDer) : REF LazyDer ==
        -- Evaluates a lazy derivative
        der := deref rder
        der.DEval? => rder
        if zeroU? der.DFun then
            dfun : D := 0
        else
            fun : D :=
                der.DFun case D => der.DFun::D
                der.DFun::%::D                          -- recursion!!!
            LazyEval := LazyEval + 1
            dfun : D :=
                der.DX case JB => differentiate(fun, der.DX::JB)$D
                differentiate(fun, der.DX::Sy)$D
        setref(rder, [true, Null, dfun])
        rder


    evalTerm(rlt : REF LazyTerm) : REF LazyTerm ==
        -- Completely evaluates a lazy term
        lt := deref rlt
        lt.LEval? => rlt
        co : D :=
            lt.LCoeff case D => lt.LCoeff::D
            lt.LCoeff::%::D                         -- recursion!!!
        zero?(co)$D =>
            setref(rlt, lazyTerm 0$D)
            rlt
        res := co *$D (deref(evalDeriv lt.LDer).DFun::D)
        setref(rlt, lazyTerm res)
        rlt


    eval1(exp : %) : % ==
        -- Evaluates the next (or more) term in Lazy.
        -- Evaluation of terms depend on leading derivatives.
        -- If all terms are already evaluated, collect is called.
        rec := deref exp
        rec.Ground? => exp
        lazy := rec.Lazy
        empty? lazy =>
            setref(exp, zeroRec)
            exp
        rlt := first lazy
        rco := deref rlt
        d : D := 0
        ld := rco.LLD
        until empty?(lazy) or (deref(first lazy).LLD < ld) repeat
            while rco.LEval? repeat
                d := d +$D (rco.LCoeff::D)
                lazy := rest lazy
                empty? lazy => return d::%
                rlt := first lazy
                rco := deref rlt
            lazy := rest lazy
            co := (deref evalTerm rlt).LCoeff::D
            d := d +$D co
            rlt := ref lazyTerm d
            ld := deref(rlt).LLD
        if not zero? d then
            lazy := merge(greater, lazy, [rlt])
        setref(exp, adapt(rec, lazy))
        exp


    eval(exp : %) : % ==
        while not ground?(exp) repeat
            exp := eval1 exp
        exp


    -- ----------- --
    -- Arithmetics --
    -- ----------- --

    0 : % == ref zeroRec


    1 : % == ref [1$JB, true, true, empty, empty, _
                  [ref [1$JB, true, true, 1$D, ref emptyDer]$LazyTerm]]$RepRec


    zero?(exp : %) : B ==
        ground? exp => zero?(extract exp)$D
        ld := leadingDer exp
        type(ld) = Const => zero?(extract eval exp)$D
        false


    eqRep?(x : %, y : %) : B == (deref(x) = deref(y))


    x : % = y : % ==
        eqRep?(x, y) => true
        zero?(x - y)


    one?(exp : %) : B ==
        ground? exp => one?(extract exp)$D
        ld := leadingDer exp
        type(ld) = Const => one?(extract eval exp)$D
        false


    numerator(exp : %) : % == exp


    denominator(exp : %) : % == 1


    -- The arithmetic operations are implemented as simple as possible. They
    -- do not perform any evaluation or simplification with the exception of
    -- the multiplication where collect is called to reduce if possible the
    -- number of terms.

    - x : % ==
        rec := deref x
        resLazy : L REF LazyTerm := _
          [(lt := deref rlt; _
             ref [lt.LLD, lt.LSharp?, lt.LEval?, minus lt.LCoeff, lt.LDer]) _
           for rlt in rec.Lazy]
        ref [rec.LD, rec.Sharp?, rec.Ground?, rec.JV1, rec.JV2, resLazy]


    x : % + y : % ==
        xrec := deref x
        yrec := deref y
        resLazy := merge(greater, xrec.Lazy, yrec.Lazy)
        if xrec.LD > yrec.LD then
            resLD := xrec.LD
            resSharp? := xrec.Sharp?
        else if yrec.LD > xrec.LD then
            resLD := yrec.LD
            resSharp? := yrec.Sharp?
        else
            resLD := xrec.LD
            resSharp? := false
        xJV := removeDuplicates! append(xrec.JV1, xrec.JV2)
        yJV := removeDuplicates! append(yrec.JV1, yrec.JV2)
        resJV1 := sort!(">", concat!(setDifference(xrec.JV1, yJV), _
                                  setDifference(yrec.JV1, xJV)))
        resJV2 := sort!(">", setDifference(concat!(xJV, yJV), resJV1))
        ref [resLD, resSharp?, false, resJV1, resJV2, resLazy]


    i : I * x : % ==
        rec := deref x
        resLazy : L REF LazyTerm := empty
        for rlt in rec.Lazy repeat
            lt := deref rlt
            resLazy := concat!(resLazy, [ref [lt.LLD, _
                lt.LSharp?, lt.LEval?, mult(i::D, lt.LCoeff), lt.LDer]])
        ref [rec.LD, rec.Sharp?, rec.Ground?, rec.JV1, rec.JV2, resLazy]


    d : D * x : % == (d::%) * x


    x : % * y : % ==
        eqRep?(x, 0) or eqRep?(y, 0) => 0
        ground?(x) and ground?(y) =>
            (extract(x) *$D extract(y))::%
        xrec := deref x
        yrec := deref y
        resLazy : L REF LazyTerm := empty
        for xlt in xrec.Lazy repeat
            for ylt in yrec.Lazy repeat
                resLazy := merge(greater, resLazy, [multLazy(xlt, ylt)])
            resJV1 := removeDuplicates! append(xrec.JV1, yrec.JV1)
            resJV2 := removeDuplicates! append(xrec.JV2, yrec.JV2)

        if xrec.LD > yrec.LD then
            resLD := xrec.LD
        else if yrec.LD > xrec.LD then
            resLD := yrec.LD
        else
            resLD := xrec.LD
        resSharp? := xrec.Sharp? and yrec.Sharp?
                          -- both necessary as otherwise one factor may be zero!

        ref [resLD, resSharp?, false, resJV1, resJV2, resLazy]


    recip(exp : %) : Union(%, "failed") ==
        ground? exp =>
            rd := recip(extract exp)$D
            rd case "failed" => "failed"
            rd::D::%
        "failed"


    -- -------------- --
    -- JBFC Functions --
    -- -------------- --

    const?(exp : %) : B ==
        rec := deref exp
        empty? rec.JV1 => const?(exp::D)$D
        false


    order(exp : %) : NNI == order leadingDer exp


    class(exp : %) : NNI == class leadingDer exp


    jetVariables(exp : %) : L JB ==
        -- result may contain spurious variables
        rec := deref exp
        merge(">", rec.JV1, rec.JV2)


    differentiate(exp : %, jv : JB) : % ==
        rec := deref exp
        ld := rec.LD
        jv > ld => 0
        newJV := removeDuplicates! merge(">", rec.JV1, rec.JV2)
        not member?(jv, newJV) => 0
        LazyDiff := LazyDiff + 1
        ref [ld, false, false, empty, newJV, _
             [ref [ld, false, false, 1$D, ref [false, jv, exp]]]]


    differentiate(exp : %, x : Sy) : % ==
        LazyDiff := LazyDiff + 1
        rec := deref exp
        ld := rec.LD
        newJV := removeDuplicates! merge(">", rec.JV1, rec.JV2)
        ref [ld, false, false, empty, newJV, _
             [ref [ld, false, false, 1$D, ref [false, x, exp]]]]


    formalDiff2(Sys : L %, i : PI, JM : SEM
               ) : Record(DSys : L %, JVars : L L JB) ==
        -- Basically as the default implementation in JBFC;
        -- only eqRep? is used instead of zero?.
        inds := allIndices JM
        empty? inds => [[0 for eq in Sys], [empty for eq in Sys]]
        LRes : L % := empty
        LJV : L L JB := empty

        -- compute formal derivative for each function
        for l in 1..nrows(JM)   for f in Sys repeat
            r := row(JM, l)
            res : % := 0
            JV : L JB := empty
            for df in reverse r.Entries  for jv in reverse r.Indices repeat
                if not eqRep?(df, 0) then
                    djv := differentiate(jv, i)
                    if djv case "0" then
                        JV := cons(jv, JV)
                    else if one?(djv::JB) then
                        res := res + df
                        JV := cons(jv, JV)
                    else
                        res := res + df*(djv::JB::%)
                        JV := append([jv, djv::JB], JV)
            if deref(f).Sharp? then
                deref(res).Sharp? := true
            LRes := cons(res, LRes)
            JV := sort!(">", removeDuplicates! JV)
            LJV := cons(JV, LJV)

        [reverse! LRes, reverse! LJV]


    -- -------------- --
    -- Simplification --
    -- -------------- --

    -- Most of the procedures here need to completely evaluate their
    -- arguments. Notable exception are leadingDer and simplify both
    -- trying to avoid evaluation as long as possible.

    leadingDer(exp : %) : JB ==
        -- Evaluates as many terms as necessary to get sharp bound LD
        rec := deref exp
        while not(rec.Sharp? or ground? exp) repeat
            exp := eval1 exp
            rec := deref exp
        rec.Sharp? => rec.LD
        leadingDer(exp::D)$D


    freeOf?(exp : %, jv : JB) : B ==
        -- Can be decided without evaluation only if jv in JV1
        while not(member?(jv, deref(exp).JV1) or ground?(exp)) repeat
             exp := eval1 exp
        member?(jv, deref(exp).JV1) => false
        freeOf?(exp::D, jv)$D


    solveFor(exp : %, jv : JB) : Union(%, "failed") ==
        sf := solveFor(exp::D, jv)$D
        sf case "failed" => "failed"
        sf::D::%


    subst(exp : %, jv : JB, sub : %) : % ==
        -- Substitution requires complete evaluation of both exp and sub,
        -- as we don't know how subst works in D. Otherwise we could at least
        -- avoid the evaluation of sub.
        subst(exp::D, jv, sub::D)$D ::%


    ld(r : SREC) : JB == deref(r.Fun).LD



    greaterLD(r1 : SREC, r2 : SREC) : B == (ld(r1) > ld(r2))
        -- local function for sorting purposes



    simpLD(l : L SREC) : L SREC ==
        -- assumes l is sorted using greaterLD
        #l < 2 => l
        cur := first l
        cld := ld cur
        l := rest l
        cld ~= ld(first l) => cons(cur, simpLD l)
        eqLD : L SREC := [cur]
        while not(empty? l) and (cld = ld(fl : SREC := first l)) repeat
            eqLD := cons(fl, eqLD)
            l := rest l

        -- try to solve one equation and substitute in the other ones
        solvable? : B := false
        for eq in eqLD  until solvable? repeat
            s := solveFor(eq.Fun, cld)
            solvable? := (s case %)
            seq := eq
        newL : L SREC := empty
        if solvable? then
            for eq in eqLD | eq ~= seq repeat
                neweq := numerator subst(eq.Fun, cld, s::%)
                if not zero? neweq then
                    newld := leadingDer neweq
                    newL := merge(greaterLD, newL,
                             [[append(eq.Dep, seq.Dep), neweq]$SREC])
        else
            -- evaluate and use simplify of D
            sys := [eq.Fun::D  for eq in eqLD]
            oldDep := [eq.Dep  for eq in eqLD]
            tmp := simplify(sys, jacobiMatrix(sys))$D
            if tmp.Depend = "failed" then
                dep := removeDuplicates! reduce(append, oldDep, empty)
                newDep : L L NNI := [dep  for eq in tmp.Sys]
            else
                newDep : L L NNI := empty
                for dep in tmp.Depend::L L NNI repeat
                    ndep : L NNI := empty
                    for d in dep repeat
                        ndep := removeDuplicates! concat!(ndep, qelt(oldDep, d))
                    newDep := cons(ndep, newDep)
                newDep := reverse! newDep
            newL := [[dep, deq::%]  for deq in tmp.Sys  for dep in newDep]
            newL := sort!(greaterLD, newL)
        cons(seq, simpLD merge(greaterLD, l, newL))


    simplify(sys : L %, jm : SEM) : SIMPREC ==
        sl : L SREC := [[[i::NNI], f]  for f in sys  for i in 1..]
        --print("SIMPLIFY")$OUT
        --print(assign("sl", sl::OUT))$OUT
        sl := simpLD sort!(greaterLD, sl)
        --print(assign("sl", sl::OUT))$OUT
        resSys := [collect l.Fun  for l in sl]
        resDep := [l.Dep  for l in sl]

        -- adjust Jacobi matrix
        inds := allIndices jm
        resJM : SEM := new(inds, #sl)
        for eq in resSys  for dep in resDep  for i in 1.. repeat
            if one?(#dep) then
                r := row(jm, first(dep))
            else
                tmp := jacobiMatrix([eq], [inds])
                r := row(tmp, 1)
            setRow!(resJM, i, r)

        [resSys, resJM, resDep]

)if false
    simpOne(sys : L %) : L % ==
        -- Simplifies only evaluated equations
        groundSys : L D := empty()
        remSys : L % := empty
        for exp in sys repeat
            if ground? exp then
                groundSys := cons(extract exp, groundSys)
            else
                remSys := cons(exp, remSys)
        concat!([d::%  for d in simpOne(groundSys)$D], remSys)
)endif

    reduceMod(sys1 : L %, sys2 : L %) : L % ==
        sys1D := [extract eval exp  for exp in sys1]
        sys2D := [extract eval exp  for exp in sys2]
        [d::%  for d in reduceMod(sys1D, sys2D)$D]


    autoReduce(sys : L %) : L % ==
        sysD := [extract eval exp  for exp in sys]
        [d::%  for d in autoReduce(sysD)$D]


)abbrev package LUD LUDecomposition
++ Description:
++  \spadtype{LUDecomposition} contains procedures to solve linear systems of
++  equations or to compute inverses using a LU decomposition.

LUDecomposition(D : Field) : Cat == Def where

  L   ==> List
  V   ==> Vector
  VD  ==> Vector D
  MD  ==> Matrix D
  I   ==> Integer
  NNI ==> NonNegativeInteger
  B   ==> Boolean
  OUT ==> OutputForm

  Cat ==> with

    LUDecomp : MD -> Record(LU : MD, Perm : V I, Pivots : L D)
      ++ \spad{LUDecomp(A)} computes a LU decomposition of \spad{A}
      ++ using the algorithm of Crout. \spad{LU} contains both triangular
      ++ matrices; \spad{Perm} is the permutation used for partial
      ++ pivoting and \spad{Pivots} yields the used pivots.

    LUSolve : (MD, V I, VD) -> VD
      ++ \spad{LUSolve(LU, Perm, B)} uses a previously computed LU
      ++ decomposition to solve a linear system with right hand side
      ++ \spad{B}. \spad{LU} and \spad{Perm} are as given by
      ++ \spad{LUDecomp}.

    LUInverse : MD -> Record(Inv : MD, Pivots : L D)
      ++ \spad{LUInverse(A)} computes the inverse of \spad{A} using a LU
      ++ decomposition.

  Def ==> add

    LUDecomp(AA : MD) : Record(LU : MD, Perm : V I, Pivots : L D) ==
        -- LU decomposition using Crout`s algorithm with partial pivoting.
        A := copy AA
        minR := minRowIndex A; maxR := maxRowIndex A
        minC := minColIndex A; maxC := maxColIndex A
        maxR ~= maxC => error "LU decomposition only of square matrices"
        PermV : V I := new((maxR - minR + 1)::NNI, 0)
        Pivs : L D := empty

        for j in minC..maxC repeat
            for i in minR..(j-1) repeat
                s := qelt(A, i, j)
                for k in minR..(i-1) repeat
                    s := s - qelt(A, i, k)*qelt(A, k, j)
                qsetelt!(A, i, j, s)

            i0 : I := -1
            for i in j..maxR repeat
                s := qelt(A, i, j)
                for k in minC..(j-1) repeat
                    s := s - qelt(A, i, k)*qelt(A, k, j)
                qsetelt!(A, i, j, s)
                if not(zero? s) and i0 < 0 then
                    i0 := i            -- first non-zero pivot

            i0 < 0 => error "singular matrix in LUDecomp"
            if j ~= i0 then
                swapRows!(A, j, i0)
            qsetelt!(PermV, j, i0)
            Pivs := cons(qelt(A, j, j), Pivs)

            if j ~= maxC then
                d := 1/qelt(A, j, j)
                for k in (j+1)..maxR repeat
                    qsetelt!(A, k, j, d*qelt(A, k, j))

        [A, PermV, Pivs]

    LUSolve(LU : MD, Perm : V I, XX : VD) : VD ==
        -- Solves LU decomposed linear system for right hand side XX
        X := copy XX
        minR := minRowIndex LU; maxR := maxRowIndex LU
        maxIndex(X) ~= maxR => error "Wrong dimensions in LUSolve"
        ii : I := -1

        for i in minR..maxR repeat               -- forward substitution
            ip := qelt(Perm, i)
            s := qelt(X, ip)
            qsetelt!(X, ip, qelt(X, i))
            if ii >= 0 then
                for j in ii..(i-1) repeat
                    s := s - qelt(LU, i, j)*qelt(X, j)
            else
                if not zero? s then ii := i
            qsetelt!(X, i, s)

        for i in maxR..minR by -1 repeat       -- back substitution
            s := qelt(X, i)
            for j in (i+1)..maxR repeat
                s := s - qelt(LU, i, j)*qelt(X, j)
            qsetelt!(X, i, s/qelt(LU, i, i))

        X

    LUInverse(A : MD) : Record(Inv : MD, Pivots : L D) ==
        -- Inversion via LU decomposition
        Alu := LUDecomp A
        n := ncols A
        res : MD := new(n, n, 0)

        for i in minRowIndex(A)..maxRowIndex(A) repeat
            v : V D := new(n, 0)
            qsetelt!(v, i, 1)
            res := setColumn!(res, i, LUSolve(Alu.LU, Alu.Perm, v))

        [res, Alu.Pivots]


)abbrev package JCT JetCoordinateTransformation
++ Description:
++  \spadtype{JetCoordinateTransformation} implements changes of local
++  coordinates. Given are the changes of the coordinates of the base space,
++  i.e. the independent and dependent variables. The transformations of the
++  derivatives are computed via the chain rule. \spad{Y} (\spad{W})
++  contains expressions for the old variables in terms of the new ones.

JetCoordinateTransformation(JB1, JB2, Y, W) : Cat == Def where

  Sy   ==> Symbol
  L    ==> List
  V    ==> Vector
  M    ==> Matrix
  EI   ==> Expression Integer
  PI   ==> PositiveInteger
  E1   ==> JBE JB1
  E2   ==> JBE JB2
  JBC  ==> JetBundleCategory
  JBE  ==> JetBundleExpression
  LUD  ==> LUDecomposition E2

  Const ==> "Const"::Sy
  Indep ==> "Indep"::Sy
  Dep   ==> "Dep"::Sy
  Deriv ==> "Deriv"::Sy


  JB1, JB2 : JBC
  Y, W     : V E2


  Cat ==> with

    transform : JB1 -> E2
      ++ \spad{transform(jv)} transforms a jet variable \spad{jv}
      ++ into a function of the new coordinates.

    transform : E1 -> E2
      ++ \spad{transform(f)} rewrites a function of the old coordinates
      ++ in the new ones.


  Def ==> add

    -- ---------------- --
    -- Global Constants --
    -- ---------------- --

    -- Checks for compatible charts.

    errmsg ==> "Number of variables must match"

    num1() : PI ==
        numIndVar()$JB1 ~= numIndVar()$JB2 => error errmsg
        numIndVar()$JB1 ~= #Y => error errmsg
        numIndVar()$JB1

    num2() : PI ==
        numDepVar()$JB1 ~= numDepVar()$JB2 => error errmsg
        numDepVar()$JB1 ~= #W => error errmsg
        numDepVar()$JB1

    nn := num1()     -- number of independent variables
    mm := num2()     -- number of dependent variables


    -- transform is an expensive operation due to its recursive definition.
    -- Hence a table with already computed values is set up.

    remember : Table(EI, E2) := dictionary()


    -- inverse of (total) Jacobi matrix is precomputed

    jacobi(y : V E2) : M E2 ==
        ly := entries y
        JM := jacobiMatrix ly
        res : M E2 := new(#y, nn, 0)
        for i in 1..nn repeat
            tmp := formalDiff2(ly, i::PI, JM)
            res := setColumn!(res, i, vector tmp.DSys)
        res

    DYI := LUInverse(jacobi Y)$LUD


    -- ------------------ --
    -- Exported Functions --
    -- ------------------ --

    transform(jv : JB1) : E2 ==
        -- first check memory
        ans := search(jv::EI, remember)
        ans case E2 => ans::E2

        jt := type jv
        if jt = Const then      res := 1$E2
        else if jt = Indep then res := qelt(Y, index(jv)+minIndex(Y)-1)
        else if jt = Dep then   res := qelt(W, index(jv)+minIndex(W)-1)
        else
          i := class jv
          pint := integrate(jv, i::PI)$JB1
          qint := transform pint
          res := reduce("+", [qelt(DYI.Inv, i, k)*formalDiff(qint, k::PI) _
                             for k in 1..nn], 0)
        setelt!(remember, jv::EI, res)


    transform(e1 : E1) : E2 ==
        JV := jetVariables e1
        JE := [jv::EI::E2  for jv in JV]
        e2 := e1::EI::E2
        for jv in JV  for je in JE repeat
            e2 := eval(e2, je = transform(jv))
        e2


)abbrev domain JBP JetBundlePolynomial
++ Description:
++ \spadtype{JetBundlePolynomial} implements polynomial sections over
++ a jet bundle. The order is not fixed, thus jet variables of any order
++ can appear.

JetBundlePolynomial(R : Ring, JB : JBC) : Cat == Def where

  L    ==> List
  NNI  ==> NonNegativeInteger
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory JB
  DP   ==> DirectProduct(#LJV, NNI)
  IE   ==> IndexedExponents JB
  PC   ==> PolynomialCategory(R, IE, JB)
  SMP  ==> SparseMultivariatePolynomial(R, JB)
  JGB  ==> JetGroebner(R, JB, LJV, %, DP)

  Cat ==> Join(JBFC, PC) with

    if R has GcdDomain then
      groebner : L % -> L %
        ++ \spad{groebner(lp)} computes a Groebner basis for the ideal
        ++ generated by \spad{lp} wrt a lexicographic ordering.


  Def ==> SMP add

    Rep := SMP
    -- In principle, a distributed representation would be better for the
    -- Groebner bases computations, but this requires a fixed number of
    -- unknowns. Hence, we transform to polynomials in a finite number of
    -- jet variables, before we compute Groebner bases.

    jetVariables(p : %) : L JB == variables p

    subst(p : %, jv : JB, exp : %) : % == eval(p, jv, exp)

    numerator(l : %) : % == l

    denominator(l : %) : % == 1

    if R has Field then

        solveFor(p : %, jv : JB) : Union(%, "failed") ==
            -- p must be linear in jv with constant coefficient
            c := differentiate(p, jv)
            ground? c =>
                cc : R := retract c
                (1/cc) * p - jv::%
            "failed"

    else

        solveFor(p : %, jv : JB) : Union(%, "failed") ==
            -- p must be linear in jv with constant coefficient
            c := differentiate(p, jv)
            ground? c =>
                cc : R := retract c
                rc := recip cc
                rc case "failed" => "failed"
                rc::R * p - jv::%
            "failed"

    if R has GcdDomain then
        groebner(lp : L %) : L % ==
            print(message("groebner"))$OUT
            lj : L L JB := [jetVariables p  for p in lp]
            LJV : L JB := reduce(setUnion, lj, empty)
            print(assign(message("LJV"), LJV::OUT))$OUT
            groebner(lp)$JGB


)abbrev domain DJBP DistributedJetBundlePolynomial
++ Description:
++ \spadtype{DistributedJetBundlePolynomial} implements polynomials
++ in a distributed representation. The unknowns come from a finite list of
++ jet variables. The implementation is basically a copy of the one of
++ \spadtype{GeneralDistributedMultivariatePolynomial}.

DistributedJetBundlePolynomial(R, JB, LJV, E) : Cat == Def where

  B    ==> Boolean
  L    ==> List
  NNI  ==> NonNegativeInteger
  VN   ==> Vector NNI
  OUT  ==> OutputForm
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory JB
  DPC  ==> DirectProductCategory(#LJV, NNI)
  PCD  ==> PolynomialCategory(R, E, JB)
  SUP  ==> SparseUnivariatePolynomial
  PGCD ==> PolynomialGcdPackage(E, JB, R, %)
  GBP  ==> GroebnerPackage(R, E, %)
  JBP  ==> JetBundlePolynomial(R, JB)

  R   : Ring
  E   : DPC
  JB  : JBC
  LJV : L JB

  Cat ==> PCD with

    convert : JBP -> %
      ++ \spad{convert(p)} converts a polynomial \spad{p} in recursive
      ++ representation into a polynomial in distributive representation.

    convert : % -> JBP
      ++ \spad{convert(p)} converts a polynomial \spad{p} in distributive
      ++ representation into a polynomial in recursive representation.

    const : % -> R
      ++ \spad{const(p)} coerces a polynomial into an element of the
      ++ coefficient ring, if it is constant. Otherwise an error occurs.

    if R has GcdDomain then
      groebner : L % -> L %
        ++ \spad{groebner(lp)} computes a Groebner basis for the ideal
        ++ generated by the list of polynomials \spad{lp}.


  Def ==> PolynomialRing(R, E) add

    LJVO : L OUT := [jv::OUT  for jv in LJV]
    nl : NNI := #LJV

    -- -------------- --
    -- Representation --
    -- -------------- --

    Term := Record(k : E, c : R)
    Rep := L Term

    lookup(jv : JB) : NNI ==
        -- "Index" of a jet variable in LJV.
        -- Local function.
        for i in 1..nl  for ljv in LJV repeat
            if ljv = jv then return i::NNI
        error "illegal jet variable"

    monomial(p : %, jv : JB, e : NNI) : % ==
        j := lookup jv
        v : VN := zero nl
        qsetelt!(v, j, e)
        p*monomial(1, directProduct v)

    coerce(jv : JB) : % == monomial(1, jv, 1)

    zero?(p : %) : B == empty?(p::Rep)

    ground?(p : %) : B == mainVariable(p) case "failed"

    monomial?(p : %) : B ==
        l : Rep := p::Rep
        empty?(l) or empty? rest(l)

    numberOfMonomials(p : %) ==
        l : Rep := p::Rep
        empty? l => 1
        #l

    mainVariable(p : %) : Union(JB, "failed") ==
        zero? p => "failed"
        tdeg := degree p
        for i in 1..nl  for jv in LJV repeat
            if not zero? tdeg.i then return jv
        "failed"

    variables(p : %) : L JB ==
        maxdeg : VN := new(nl, 0)
        while not zero? p repeat
            tdeg := degree p
            p := reductum p
            for i in 1..nl repeat
                maxdeg.i := max(maxdeg.i, tdeg.i)
        [jv  for jv in LJV  for i in 1..nl | maxdeg.i ~= 0]

    coerce(p : %) : OUT ==
        zero? p => 0$R ::OUT
        lt : L OUT := empty
        for t in reverse p repeat
            l : L OUT := empty
            for i in 1..nl repeat
                t.k.i = 0 => l
                t.k.i = 1 => l := cons(LJVO.i, l)
                l := cons(LJVO.i ^ t.k.i::OUT, l)
            l := reverse l
            if (t.c ~= 1) or empty? l then
                l := cons(t.c::OUT, l)
            if #l = 1 then
                lt := cons(first l, lt)
            else
                lt := cons(reduce("*", l), lt)
        #lt = 1 => first lt
        reduce("+", lt)

    -- --------------- --
    -- Transformations --
    -- --------------- --

    convert(p : JBP) : % ==
        (xx := mainVariable p) case "failed" =>
            cc : R := retract p
            cc::%
        x := xx::JB
        not member?(x, LJV) => error "illegal jet variable"
        up := univariate(p, x)
        res : % := 0
        while not zero? up repeat
            res := res + monomial(convert leadingCoefficient up, _
                                    x, degree up)
            up := reductum up
        res

    convert(p : %) : JBP ==
        (xx := mainVariable p) case "failed" =>
            cc : R := retract p
            cc::JBP
        x := xx::JB
        up := univariate(p, x)
        res : JBP := 0
        while not zero? up repeat
            res := res + monomial(convert leadingCoefficient up, _
                                    x, degree up)
            up := reductum up
        res

    const(p : %) : R ==
        not ground? p => error "not a constant"
        leadingCoefficient p

    retractIfCan(p : %) : Union(R, "failed") ==
        ground? p => leadingCoefficient p
        "failed"

    retract(p : %) : R == const p

    univariate(p : %, jv : JB) : SUP(%) ==
        zero? p => 0
        exp := degree p
        j := lookup jv
        deg : NNI := 0
        nexp := directProduct([if j = i then (deg := exp.i; 0) else exp.i _
                                for i in 1..nl]$VN)
        monomial(monomial(leadingCoefficient p, nexp), deg) + _
            univariate(reductum p, jv)

    univariate(p : %) : SUP(R) ==
        pv := mainVariable(p)$%
        pv case "failed" => monomial(leadingCoefficient p, 0)
        up := univariate(p, pv::JB)
        res : SUP(R) := 0
        while not zero? up repeat
            res := res + monomial(const leadingCoefficient up, degree up)
            up := reductum up
        res

    multivariate(p1 : SUP(%), jv : JB) : % ==
        zero? p1 => 0
        zero? degree p1 => leadingCoefficient p1
        leadingCoefficient(p1)*(jv::%)^degree(p1) + _
          multivariate(reductum p1, jv)

    multivariate(p : SUP(R), jv : JB) : % ==
        zero? p => 0
        leadingCoefficient(p)*monomial(1, jv, degree p) + _
            multivariate(reductum p, jv)

    -- ------- --
    -- Degrees --
    -- ------- --

    totalDegree p ==
        zero? p => 0
        "max"/[reduce("+", (t.k)::VN, 0)  for t in p]

    degree(p : %, jv : JB) : NNI == degree(univariate(p, jv))

    degree(p : %, ljv : L JB) : L NNI == [degree(p, jv)  for jv in ljv]

    minimumDegree(p : %, jv : JB) : NNI == minimumDegree(univariate(p, jv))

    minimumDegree(p : %, ljv : L JB) == [minimumDegree(p, jv)  for jv in ljv]

    -- ---------- --
    -- Evaluation --
    -- ---------- --

    eval(p : %, jv : JB, val : %) : % == univariate(p, jv)(val)

    eval(p : %, jv : JB, val : R) : % == eval(p, jv, val::%)$%

    eval(p : %, ljv : L JB, lval : L R) : % ==
        empty? ljv => p
        eval(eval(p, first ljv, (first lval)::%)$%, rest ljv, rest lval)$%

    evalSortedVarlist(p : %, Ljvar : L JB, Lpval : L %) : % ==
        -- assumes Lvar are sorted correctly
        -- local function
        j := mainVariable p
        j case "failed" => p
        pv := j::JB
        empty? Ljvar or empty? Lpval => p
        mvar := Ljvar.first
        mvar > pv => evalSortedVarlist(p, Ljvar.rest, Lpval.rest)
        pval := Lpval.first
        pts : SUP(%) := map(x +-> evalSortedVarlist(x, Ljvar, Lpval),
                            univariate(p, pv))
        mvar = pv => pts(pval)
        multivariate(pts, pv)

    eval(p : %, Ljvar : L JB, Lpval : L %) : % ==
        nljvar : L JB := sort((x, y) +-> lookup(x) < lookup(y), Ljvar)
        nlpval :=
            Ljvar = nljvar => Lpval
            nlpval := [Lpval.position(mvar, Ljvar)  for mvar in nljvar]
        evalSortedVarlist(p, nljvar, nlpval)

    -- ----------- --
    -- Arithmetics --
    -- ----------- --

    differentiate(p : %, jv : JB) ==
        multivariate(differentiate(univariate(p, jv)), jv)

    if R has Field then
        p : % / r : R == inv(r) * p

    if R has GcdDomain then
        content(p : %) : R ==
            zero?(p) => 0
            "gcd"/[t.c  for t in p]

        if R has EuclideanDomain and not R has Field then
            gcd(p1 : %, p2 : %) : % == gcd(p1, p2)$PGCD
        else
            gcd(p1 : %, p2 : %) : % ==
                r : R
                (pv1 := mainVariable(p1)) case "failed" =>
                    zero? (r := leadingCoefficient p1) => p2
                    gcd(r, content p2)::%
                (pv2 := mainVariable(p2)) case "failed" =>
                    zero? (r := leadingCoefficient p2) => p1
                    gcd(r, content p1)::%
                pv1 < pv2 => gcd(p1, content univariate(p2, pv2))
                pv2 < pv1 => gcd(p2, content univariate(p1, pv1))
                multivariate(gcd(univariate(p1, pv1), univariate(p2, pv2)), pv1)

        groebner(lp : L %) : L % ==
            print(message("groebner$DJBP"))$OUT
            groebner(lp)$GBP


)abbrev package JGB JetGroebner
++ Description:
++  \spadtype{JetGroebner} provides a procedure to compute Groebner bases for
++  arbitrary domains of jet polynomials. Two internal procedures transform
++  to and from \spadtype{DistributedJetBundlePolynomial} where the actual
++  computation is done. The argument \spad{LJV} contains all jet variables
++  effectively occurring in the polynomials. The ordering is determined by
++  the ordering in \spad{P}.

JetGroebner(R, JB, LJV, P, E) : Cat == Def where

  L    ==> List
  NNI  ==> NonNegativeInteger
  JBC  ==> JetBundleCategory
  JBFC ==> JetBundleFunctionCategory JB
  DPC  ==> DirectProductCategory(#LJV, NNI)
  IE   ==> IndexedExponents JB
  PC   ==> PolynomialCategory(R, IE, JB)
  DJBP ==> DistributedJetBundlePolynomial(R, JB, LJV, E)


  R   : GcdDomain
  E   : DPC
  JB  : JBC
  LJV : L JB
  P   : Join(JBFC, PC)


  Cat ==> with

    groebner : L P -> L P
      ++ \spad{groebner(lp)} computes a Groebner basis for the ideal
      ++ generated by the polynomials \spad{lp}.


  Def ==> add

    convert1(p : P) : DJBP ==
        (xx := mainVariable p) case "failed" =>
            cc : R := retract p
            cc::DJBP
        x := xx::JB
        not member?(x, LJV) => error "illegal jet variable"
        up := univariate(p, x)
        res : DJBP := 0
        while not zero? up repeat
            lcup := leadingCoefficient up
            clcup := convert1 lcup
            m := monomial(clcup, x, degree up)
            res := res + monomial(convert1 leadingCoefficient up, _
                                  x, degree up)
            up := reductum up
        res

    convert2(p : DJBP) : P ==
        (xx := mainVariable p) case "failed" =>
            cc : R := retract p
            cc::P
        x := xx::JB
        up := univariate(p, x)
        res : P := 0
        while not zero? up repeat
            res := res + monomial(convert2 leadingCoefficient up, _
                                  x, degree up)
            up := reductum up
        res

    groebner(lp : L P) : L P ==
        nlp : L DJBP := [convert1 p  for p in lp]
        gb := groebner(nlp)$DJBP
        [convert2 dp  for dp in gb]


)if false
-- Does not compile
-- )abbrev domain JBQLF JetBundleQuasiLinearFunction
++ Description:
++  \spadtype{JetBundleQuasiLinearFunction} implements non-linear functions
++  over a jet bundle. It tries to represent them as quasi-linear functions,
++  i.e. as functions which are linear in the highest derivatives. All
++  operations try to exploit and to maintain this quasi-linear structure.
++  Truly non-linear expression must be of the argument domain \spad{D}

JetBundleQuasiLinearFunction(JB, D) : Cat == Def where

  V    ==> Vector
  M    ==> Matrix
  Sy   ==> Symbol
  PI   ==> PositiveInteger
  NNI  ==> NonNegativeInteger
  I    ==> Integer
  B    ==> Boolean
  L    ==> List
  JBC  ==> JetBundleCategory
  JBE  ==> JetBundleExpression JB
  JBFC ==> JetBundleFunctionCategory JB
  MCF  ==> MatrixCategoryFunctions2(%, V %, V %, M %, D, V D, V D, M D)
  MCFD ==> MatrixCategoryFunctions2(D, V D, V D, M D, %, V %, V %, M %)
  OUT  ==> OutputForm
  SEM  ==> SparseEchelonMatrix(JB, %)
  SEMD ==> SparseEchelonMatrix(JB, D)

  SIMPREC ==> Record(Sys : L %, JM : SEM, Depend : Union("failed", L L NNI))

  Const   ==> "Const"::Sy
  Indep   ==> "Indep"::Sy
  Dep     ==> "Dep"::Sy
  Deriv   ==> "Deriv"::Sy


  JB : JBC
  D  : Join(JBFC, CommutativeRing)


  Cat ==> Join(JBFC, Module D, CoercibleTo D) with

    nonlinear? : % -> B
      ++ \spad{nonlinear?(q)} checks whether \spad{q} is a truly non-linear
      ++ function, i.e. not quasi-linear.

    convert : D -> %
      ++ \spad{convert(q)} tries to write an element of \spad{D} as a
      ++ quasi-linear function.

    if D has Field then
      Field


  Def ==> add

    -- -------------- --
    -- Representation --
    -- -------------- --

    Rep := Record(hCoeff : L D, hJV : L JB, low : D, ord : NNI, nonl? : B)
      -- ord gives the order of the function which is linear in the
      -- jet variables hJV of this order. hCoeff contains the corresponding
      -- coefficients; low the lower order terms. hJV is always ordered.
      -- nonl? is false for quasi-linear functions.


    nonlinear?(q : %) : B == q.nonl?


    order(q : %) : NNI == q.ord


    coerce(jv : JB) : % == [[1], [jv], 0, order(jv), false]


    coerce(q : %) : D ==
        nonlinear? q => q.low
        q.low + reduce("+", [c *$D jv::D  for c in q.hCoeff  for jv in q.hJV], 0)


    monom(c : D, jv : JB) : OUT ==
        one?(c)$D => jv::OUT
        one? jv => c::OUT
        c::OUT * jv::OUT


    coerce(q : %) : OUT ==
        zero? q => 0$NNI::OUT
        nonlinear? q => q::D::OUT
        res : OUT := monom(first(q.hCoeff), first(q.hJV))
        for c in rest q.hCoeff  for jv in rest q.hJV repeat
            res := res + monom(c, jv)
        zero? q.low => res
        res + (q.low)::OUT


    convert(ex : D) : % ==
        oe := order(ex)$D
        JV := jetVariables(ex)$D
        empty? JV => [[ex], [1$JB], 0, 0, false]

        resJV : L JB := empty
        resCo : L D := empty
        l := ex
        for jv in JV  while order(jv) = oe repeat
            c := differentiate(l, jv)$D
            if order(c)$D < oe then
                resJV := cons(jv, resJV)
                resCo := cons(c, resCo)
                l := l - c*jv::D
            else    -- not quasi-linear!
                return [[], [], ex, oe, true]

        [resCo, resJV, l, oe, false]


    numerator(q : %) : % ==
        nonlinear? q => convert numerator(q.low)$D
        q


    denominator(q : %) : % ==
        nonlinear? q => convert denominator(q.low)$D
        1


    -- ----------- --
    -- Arithmetics --
    -- ----------- --

    q1 : % = q2 : % ==
        nonlinear? q1 =>
            nonlinear? q2 => q1.low =$D q2.low
            q1.low =$D q2::D
        nonlinear? q2 => q2.low =$D q1::D
        q1.ord = q2.ord =>
            (q1.hJV = q2.hJV) and (q1.hCoeff = q2.hCoeff) and (q1.low = q2.low)
        false


    0 : % == [[0$D], [1$JB], 0$D, 0, false]


    1 : % == [[1$D], [1$JB], 0$D, 0, false]


    zero?(q : %) : B ==
        zero?(q.low)$D =>
            empty?(q.hJV) or ((first(q.hJV) = 1$JB) and zero?(first q.hCoeff)$D)
        false


    one?(q : %) : B ==
        zero?(q.low)$D =>
            empty?(q.hJV) => false
            (first(q.hJV) = 1$JB) and one?(first q.hCoeff)$D
        one?(q.low)$D and empty? q.hJV


    - q : % == [[-$D c  for c in q.hCoeff], q.hJV, -$D q.low, q.ord, q.nonl?]


    q1 : % + q2 : % ==
        nonlinear?(q1) or nonlinear?(q2) => convert(q1::D +$D q2::D)
        o1 := order q1
        o2 := order q2
        o1 > o2 => [q1.hCoeff, q1.hJV, q1.low +$D q2::D, o1, false]
        o2 > o1 => [q2.hCoeff, q2.hJV, q2.low +$D q1::D, o2, false]

        resC : L D := empty
        resJ : L JB := empty
        lc2 := copy q2.hCoeff
        lj2 := copy q2.hJV

        for c1 in q1.hCoeff  for j1 in q1.hJV  repeat
            while not empty?(lj2) and first(lj2) > j1 repeat
                resC := cons(first lc2, resC)
                resJ := cons(first lj2, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            if not empty?(lj2) and first(lj2) = j1 then
                sum := c1 +$D first lc2
                if not zero? sum then
                    resC := cons(sum, resC)
                    resJ := cons(j1, resJ)
                lc2 := rest lc2
                lj2 := rest lj2
            else
                resC := cons(c1, resC)
                resJ := cons(j1, resJ)
        resC := concat!(reverse! resC, lc2)
        resJ := concat!(reverse! resJ, lj2)

        empty? resJ => convert(q1.low +$D q2.low)
        [resC, resJ, q1.low +$D q2.low, o1, false]


    i : I * q : % ==
        zero? i or zero? q => 0
        [[i *$D c  for c in q.hCoeff], q.hJV, i *$D q.low, q.ord, q.nonl?]


    ex : D * q : % ==
        zero? ex or zero? q => 0
        oe := order ex
        oq := order q
        oe > oq =>
            qx := convert ex
            nonlinear? qx => [[], [], ex *$D q::D, oe, true]
            qe := q::D
            [[qe *$D c  for c in qx.hCoeff], qx.hJV, qe *$D qx.low, oe, false]
        oe = oq => [[], [], ex *$D q::D, oe, true]
        [[ex *$D c  for c in q.hCoeff], q.hJV, ex *$D q.low, oq, q.nonl?]


    q1 : % * q2 : % ==
        o1 := order q1
        o2 := order q2
        o1 > o2 => q2::D * q1
        o2 > o1 => q1::D * q2
        [[], [], q1::D *$D q2::D, o1, true]


    recip(q : %) : Union(%, "failed") ==
        r := recip(q::D)$D
        r case "failed" => "failed"
        convert(r::D)


    if D has Field then

        q1 : % / q2 : % == convert(q1::D /$D q2::D)


    -- -------------- --
    -- JBFC Functions --
    -- -------------- --

    jetVariables(q : %) : L JB ==
        nonlinear? q => jetVariables(q.low)$D
        jetC : L L JB := [jetVariables(c)$D  for c in q.hCoeff]
        res : L JB := reduce(setUnion, jetC, empty)
        one? first q.hJV => sort(">", setUnion(res, jetVariables(q.low)$D))
        sort(">", append(q.hJV, setUnion(res, jetVariables(q.low)$D)))


    differentiate(q : %, s : Sy) : % ==
        dl := differentiate(q.low, s)$D
        nonlinear? q => convert dl
        resC : L D := empty
        resJ : L JB := empty
        for c in q.hCoeff  for jv in q.hJV repeat
            dc := differentiate(c, s)$D
            if not zero? dc then
                resC := cons(dc, resC)
                resJ := cons(jv, resJ)
        empty? resJ => convert dl
        [reverse! resC, reverse! resJ, dl, q.ord, false]


    differentiate(q : %, jv : JB) : % ==
        dl := differentiate(q.low, jv)$D
        nonlinear? q => convert dl
        oj := order jv
        oq := order q
        oj > oq => 0
        oj = oq =>
            pos := position(jv, q.hJV)
            pos < minIndex(q.hJV) => 0
            convert qelt(q.hCoeff, pos)
        resC : L D := empty
        resJ : L JB := empty
        for c in q.hCoeff  for j in q.hJV repeat
            dc := differentiate(c, jv)$D
            if not zero? dc then
                resC := cons(dc, resC)
                resJ := cons(j, resJ)
        empty? resJ => convert dl
        [reverse! resC, reverse! resJ, dl, oq, false]

    SEM_to_SEMD(jm : SEM) : SEMD == error "unimplemented"

    dimension(sys : L %, jm : SEM, q : NNI) : NNI ==
        -- Assumes that sys is simplified and that no equation is of
        -- higher order than q.
        reduce("or", [nonlinear? eq  for eq in sys], false) =>
            sysd : L D := [eq::D  for eq in sys]
            -- jmd : M D := map(coerce, jm.Mat)$MCF
            -- dimension(sysd, [jmd, jm.Ind, jm.Echelon?], q)$D
            jmd := SEM_to_SEMD(jm)
            dimension(sysd, jmd, q)$D
        (dimJ(q)$JB - #sys)::NNI


    orderDim(sys : L %, jm : SEM, q : NNI) : NNI ==
        -- Assumes that sys is simplified and that all equations are of order q.
        reduce("or", [nonlinear? eq  for eq in sys], false) =>
            sysd : L D := [eq::D  for eq in sys]
            -- jmd : M D := map(coerce, jm.Mat)$MCF
            -- orderDim(sysd, [jmd, jm.Ind, jm.Echelon?], q)$D
            jmd := SEM_to_SEMD(jm)
            orderDim(sysd, jmd, q)$D
        (dimS(q)$JB - #sys)::NNI

    -- -------------- --
    -- Simplification --
    -- -------------- --

    leadingDer(q : %) : JB ==
        nonlinear? q => leadingDer(q.low)$D
        first q.hJV


    freeOf?(q : %, jv : JB) : B ==
        oj := order jv
        oq := order q
        oj > oq => true
        nonlinear? q => freeOf?(q.low, jv)$D
        oj = oq => not member?(jv, q.hJV)
        freeOf?(q.low, jv) and _
            reduce("and", [freeOf?(c, jv)$D  for c in q.hCoeff], true)


    solveFor(q : %, jv : JB) : Union(%, "failed") ==
        -- solves only for highest-order derivatives
        -- if they have an invertible coefficient
        nonlinear? q =>
            s := solveFor(q.low, jv)$D
            s case D => convert s
            "failed"
        pos := position(jv, q.hJV)
        pos < minIndex(q.hJV) => "failed"
        dr := recip(q.hCoeff.pos)$D
        dr case "failed" => "failed"
        d : D := - (dr::D)
        #q.hJV = 1 => convert(d *$D q.low)
        [[d *$D c  for c in delete(q.hCoeff, pos)], delete(q.hJV, pos), _
         d *$D q.low, q.ord, false]


    subst(q : %, jv : JB, exp : %) : % ==
        -- lazy-bone!!!
        convert subst(q::D, jv, exp::D)$D


    ground(q : %) : % ==
        -- local function; returns lower order part
        convert q.low

)if false
    rewrite(jm : SEM) : L % ==
        -- local function; transforms a matrix into a system
        -- assumes all jet variables in jm.Ind are of the same order and
        -- that jm.Mat is in row echelon form
        res : L % := empty
        finished? : B := false
        minR := minRowIndex jm.Mat; maxR := maxRowIndex jm.Mat
        minC := minColIndex jm.Mat; maxC := maxColIndex jm.Mat

        o := order first jm.Ind
        col := minC
        JV := jm.Ind
        for i in minR..maxR  until finished? repeat
            resC : L D := empty
            resJ : L JB := empty
            for jv in JV  for j in col..maxC _
                    while zero? qelt(jm.Mat, i, j) repeat
                col := col + 1
                JV := rest JV
            for jv in JV  for j in col..maxC repeat
                d := qelt(jm.Mat, i, j)::D
                if not zero? d then
                    resC := cons(d, resC)
                    resJ := cons(jv, resJ)
            finished? := empty? resJ
            if not finished? then
                res := cons([reverse! resC, reverse! resJ, 0$D, o, true], res)

        reverse! res
)endif

    SEMD_to_SEM(jmd : SEMD) : SEM == error "unimplemented"

    M_to_SEM(m: M %) : SEM == error "unimplemented"

    simplify(sys : L %, jm : SEM) : SIMPREC ==
        -- It is assumed that the columns of the Jacobi matrix are ordered.
        -- If sys contains truly non-linear functions, the simplify of D is
        -- called. Otherwise the highest-order part of sys is made triangular.
        print("simplify")$OUT
        reduce("or", [nonlinear? eq  for eq in sys], false) =>
            sysd : L D := [eq::D  for eq in sys]
            -- jmd : M D := map(coerce, jm.Mat)$MCF
            -- tmp := simplify(sysd, [jmd, jm.Ind, jm.Echelon?])$D
            jmd := SEM_to_SEMD(jm)
            tmp := simplify(sysd, jmd)$D
            nsys : L % := [convert eq  for eq in tmp.Sys]
            -- njm : M % := map(convert, tmp.JM.Mat)$MCFD
            njm := SEMD_to_SEM(tmp.JM)
            [nsys, njm, tmp.Depend]
        print("quasi-linear system")$OUT
        -- jm.Echelon? => [sys, jm, [[i::NNI]  for i in 1..#sys]]
        -- print("noch nicht in Dreiecksform")$OUT

        q : NNI := 0
        for eq in sys repeat
            q := max(q, order eq)

        -- sort out all equations of lower order
        fsys : L % := empty
        fdep : L L NNI := empty
        ssys : L % := empty
        sind : V NNI := new(#sys, 0)
        lsjm : L L % := empty
        lfjm : L L % := empty
        k : I := 0
        jmm := jm::M(%)
        for eq in reverse sys  for i in #sys..1 by -1 repeat
            rjm : V % := row(jmm, i)
            if order(eq) < q then
                fsys := cons(eq, fsys)
                fdep := cons([i::NNI], fdep)
                lfjm := cons(entries rjm, lfjm)
            else
                k := k+1
                ssys := cons(eq, ssys)
                qsetelt!(sind, k, i::NNI)
                lsjm := cons(entries rjm, lsjm)
        zero? k => [sys, jm, fdep]
        sjm : M % := matrix lsjm

        -- split Jacobi matrix in columns for p of highest order
        -- and for remaining jet variables
        i1 : I := minRowIndex sjm
        i2 : I := maxRowIndex sjm
        j1 : I := minColIndex sjm
        j2 : I := maxColIndex sjm
        js : I := 0
        JV : L JB := allIndices(jm)
        for jv in allIndices(jm)  while order(jv) = q repeat
            js := js + 1
            JV := rest JV
        mat1 : M % := subMatrix(sjm, i1, i2, j1, js + j1 - 1)
        print(message("Symbol"))$OUT
        print(mat1::OUT)$OUT
        print(assign(message("JV"), JV::OUT))$OUT
        if j1 + js <= j2 then
            mat2 : M % := subMatrix(sjm, i1, i2, js + j1, j2)

        -- make symbol triangular
        -- (non-linear part must be computed separately)
        RRec := rowEchelon(M_to_SEM(mat1))$SEM
        Trafo := RRec.Lt
        minR := minRowIndex Trafo
        maxR := maxRowIndex Trafo
        qlinSys := rewrite [RRec.R, first(jm.Ind, js::NNI), true]$MATREC
        groundSys := [ground eq  for eq in sys]
        redGSys : L % := empty
        redInd : L I := empty
        for g in groundSys  for j in minR.. repeat
            if not zero? g then
                redGSys := cons(g, redGSys)
                redInd := cons(j, redInd)
        if empty? redInd then
            newEq := qlinSys
        else
            newEq : L % := empty
            for eq in qlinSys  for i in minR.. repeat
                neq := eq
                for g in redGSys  for j in redInd repeat
                    neq := neq + g*qelt(Trafo, i, j)
                newEq := cons(neq, newEq)
            if #qlinSys < nrows(Trafo) then
                for i in (#qlinSys + minR)..maxR repeat
                    neq : % := 0
                    for g in redGSys  for j in redInd repeat
                        neq := neq + g*qelt(Trafo, i, j)
                    newEq := cons(neq, newEq)
            newEq := reverse! newEq

        -- complete Jacobi matrix
        if j1 + js <= j2 then
            NMat := horizConcat(RRec.R, Trafo*mat2)
        else
            NMat := RRec.R
        i2 := i2 + #newEq - #sys
        NMat := subMatrix(NMat, i1, i2, j1, j2)

        -- adjust Jacobi matrix for non-constant entries in trafo
        -- and build dependency list
        dep : L L NNI := empty
        for j in maxIndex(newEq)..minIndex(newEq) by -1 repeat
            depj : L NNI := empty
            for k in maxR..minR by -1 repeat
                t : % := qelt(Trafo, j, k)
                kb := k + minIndex(sys) - minR
                if not zero? t then
                    depj := _
                        cons((qelt(sind, k) - minR + minIndex(depj))::NNI, depj)
                    for jv in JV  for pos in j+1.. repeat
                      if not freeOf?(t, jv) then
                          qsetelt!(NMat, j, pos, qelt(NMat, j, pos) + _
                                     qelt(sys, kb)*differentiate(t, jv))
            dep := cons(depj, dep)

        empty? lfjm => [newEq, [NMat, jm.Ind, true], dep]
        fjm : M % := matrix lfjm
        [concat!(newEq, fsys), [vertConcat(NMat, fjm), jm.Ind, false], _
         concat!(dep, fdep)]


    simpOne(sys : L %) : L % ==
        res : L % := empty
        for eq in sys repeat
            if nonlinear? eq then
                res := cons(convert first simpOne [eq.low], res)
            else if (one?(#eq.hJV) and zero?(eq.low)$D) then
                res := cons([ [1$D], eq.hJV, 0$D, eq.ord, false], res)
            else
                res := cons(eq, res)
        res
)endif
