/Users/mourrain/Devel/mmx/basix/src/mmx_texmacs.cpp

Go to the documentation of this file.

/******************************************************************************
* MODULE     : mmx_texmacs.cpp
* DESCRIPTION: Conversion into TeXmacs markup
* COPYRIGHT  : (C) 2000  Joris van der Hoeven
*******************************************************************************
* This software falls under the GNU general public license and comes WITHOUT
* ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for more details.
* If you don't have this file, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************/

#include <basix/string.hpp>
#include <basix/table.hpp>
#include <basix/literal.hpp>
#include <basix/compound.hpp>
#include <basix/row_tuple.hpp>
#include <basix/lisp_syntax.hpp>
namespace mmx {

#define DATA_BEGIN   ((char) 2)
#define DATA_END     ((char) 5)
#define DATA_ESCAPE  ((char) 27)
#define DATA_COMMAND '\20'

generic print_mmx (const generic& g);
string as_texmacs_snippet (const generic& g);

/******************************************************************************
* Handling auxiliary TeXmacs commands
******************************************************************************/

static string texmacs_pending= "";

void
texmacs_command (const string& cmd) {
  texmacs_pending << " " << cmd << "\n";
}

string
texmacs_flush_commands () {
  if (texmacs_pending == "") return "";
  string s=
    string (DATA_BEGIN) *
    "command:(begin" * texmacs_pending * ")" *
    string (DATA_END);
  texmacs_pending= "";
  return s;
}

void
texmacs_dynamic_event (const string& id, const generic& val) {
  string v= as_texmacs_snippet (as_generic (flatten (val)));
  texmacs_command ("(locus-set \"" * id * "\" '" * v * ")");
}

/******************************************************************************
* Mode annotation
******************************************************************************/

generic add_modes (const generic& g, int mode);

generic
add_modes (const generic& g, int mode, int new_mode) {
  // mmerr << as_lisp (g) << ", " << mode << ", " << new_mode << "\n";
  generic r= add_modes (g, new_mode);
  if (is_func (r, "$concat", 1)) r= r[1];
  if (mode == new_mode) return r;
  else if (is_func (r, "$math", 1)) return r;
  else if (is_func (r, "$text", 1)) return r;
  else if (new_mode == 1) return gen ("$math", r);
  else if (new_mode == 2) return gen ("$text", r);
  else return r;
}

generic
add_modes (const generic& g, int mode) {
  // mmerr << as_lisp (g) << ", " << mode << "\n";
  if (!is<compound> (g) || !is<literal> (g[0])) return g;
  if (is_func (g, "$math", 1)) return add_modes (g[1], mode, 1);
  if (is_func (g, "$text", 1)) return add_modes (g[1], mode, 2);
  if (is_func (g, "$inmath", 1)) return add_modes (g[1], 1);
  if (is_func (g, "$intext", 1)) return add_modes (g[1], 2);
  vector<generic> v= copy (compound_to_vector (g));
  for (nat i=1; i<N(v); i++) v[i]= add_modes (v[i], mode);
  return vector_to_compound (v);
}

/******************************************************************************
* Initialize tables
******************************************************************************/

static void
init (table<generic,generic>& t, const generic& key, const generic& val) {
  t[key]= val;
}

static table<generic,generic>
texmacs_symbol_table () {
  table<generic,generic> t;

  init (t, "/\\", "tm$wedge");
  init (t, "mathcatalan", "tm$mathcatalan");
  init (t, "@", "tm$circ");
  init (t, "><", "tm$join");
  init (t, "derivative", "D");
  init (t, "mathe", "tm$mathe");
  init (t, "<=>", "tm$Leftrightarrow");
  init (t, "matheuler", "tm$matheuler");
  init (t, ">", "tm$gtr");
  init (t, ">=", "tm$geqslant");
  init (t, ">>", "tm$gg");
  init (t, "mathi", "tm$mathi");
  init (t, "=>", "tm$Rightarrow");
  init (t, "Infty", "tm$infty");
  init (t, "->", "tm$rightarrow");
  init (t, "<", "tm$less");
  init (t, "<=", "tm$leqslant");
  init (t, "<<", "tm$ll");
  init (t, ":->", "tm$mapsto");
  init (t, ".!", "!");
  init (t, "!", "tm$neg");
  init (t, "\\/", "tm$vee");
  init (t, "partial", "tm$partial");
  init (t, "mathpi", "tm$mathpi");
  init (t, ".'", "'");
  init (t, ".`", "`");
  init (t, "..", "tm$ldots");
  init (t, "::", "tm$colons");
  init (t, ":>", "tm$transtype");
  init (t, "!=", "tm$neq");
  init (t, "|", "|");
  init (t, "||", "tm$||");
  init (t, "xor", "tm$veebar");
  init (t, ":=", "tm$assign");
  init (t, "+=", "tm$plusassign");
  init (t, "-=", "tm$minusassign");
  init (t, "*=", "tm$astassign");
  init (t, "/=", "tm$overassign");

  init (t, "alpha", "tm$alpha");
  init (t, "beta", "tm$beta");
  init (t, "gamma", "tm$gamma");
  init (t, "delta", "tm$delta");
  init (t, "epsilon", "tm$varepsilon");
  init (t, "zeta", "tm$zeta");
  init (t, "eta", "tm$eta");
  init (t, "theta", "tm$theta");
  init (t, "iota", "tm$iota");
  init (t, "kappa", "tm$kappa");
  init (t, "lambda", "tm$lambda");
  init (t, "mu", "tm$mu");
  init (t, "nu", "tm$nu");
  init (t, "xi", "tm$xi");
  init (t, "omicron", "tm$omicron");
  init (t, "pi", "tm$pi");
  init (t, "rho", "tm$rho");
  init (t, "sigma", "tm$sigma");
  init (t, "tau", "tm$tau");
  init (t, "upsilon", "tm$upsilon");
  init (t, "phi", "tm$varphi");
  init (t, "chi", "tm$chi");
  init (t, "psi", "tm$psi");
  init (t, "omega", "tm$omega");

  init (t, "Alpha", "tm$Alpha");
  init (t, "Beta", "tm$Beta");
  init (t, "Gamma", "tm$Gamma");
  init (t, "Delta", "tm$Delta");
  init (t, "Epsilon", "tm$Epsilon");
  init (t, "Zeta", "tm$Zeta");
  init (t, "Eta", "tm$Eta");
  init (t, "Theta", "tm$Theta");
  init (t, "Iota", "tm$Iota");
  init (t, "Kappa", "tm$Kappa");
  init (t, "Lambda", "tm$Lambda");
  init (t, "Mu", "tm$Mu");
  init (t, "Nu", "tm$Nu");
  init (t, "Xi", "tm$Xi");
  init (t, "Omicron", "tm$Omicron");
  init (t, "Pi", "tm$Pi");
  init (t, "Rho", "tm$Rho");
  init (t, "Sigma", "tm$Sigma");
  init (t, "Tau", "tm$Tau");
  init (t, "Upsilon", "tm$Upsilon");
  init (t, "Phi", "tm$Phi");
  init (t, "Chi", "tm$Chi");
  init (t, "Psi", "tm$Psi");
  init (t, "Omega", "tm$Omega");

  return t;
}

/******************************************************************************
* TeXmacs conversion routines
******************************************************************************/

bool
is_infix (const generic& g, const generic& op) {
  return is_func (g, "$infix", 3) && g[2] == op;
}

generic
unbracket (const generic& g) {
  if (is_func (g, "$bracket", 3)) return g[2];
  else return g;
}

bool
is_alpha (const generic& g) {
  if (!is<literal> (g)) return false;
  string s= literal_to_string (g);
  for (nat i=0; i<N(s); i++)
    if ((s[i] < 'a' || s[i] > 'z') &&
        (s[i] < 'A' || s[i] > 'Z'))
      return false;
  return true;
}

void
concat_append (vector<generic>& v, const generic& g) {
  if (g == "");
  else if (is_func (g, "$concat")) {
    vector<generic> w= compound_to_vector (g);
    for (nat i=1; i<N(w); i++) concat_append (v, w[i]);
  }
  else if (N(v) == 0) v << g;
  else if (is<literal> (v[N(v)-1]) && is<literal> (g))
    v[N(v)-1]= generic (literal_to_string (v[N(v)-1]) * literal_to_string (g));
  else if (is_func (v[N(v)-1], "$lprime", 1) && is_func (g, "$lprime", 1)) {
    generic p (literal_to_string (v[N(v)-1][1]) * literal_to_string (g[1]));
    v[N(v)-1]= gen ("$lprime", p);
  }
  else if (is_func (v[N(v)-1], "$rprime", 1) && is_func (g, "$rprime", 1)) {
    generic p (literal_to_string (v[N(v)-1][1]) * literal_to_string (g[1]));
    v[N(v)-1]= gen ("$rprime", p);
  }
  else v << g;
}

generic
as_texmacs (const generic& g) {
  if (is<literal> (g)) {
    if (g == "$lf") return gen ("$lf");
    if (g == "$cr") return gen ("$cr");
    if (g == "$spc") return gen (" ");
    static table<generic,generic> t= texmacs_symbol_table ();
    generic h= g;
    if (contains (t, h)) h= t[h];
    if (!is<literal> (h)) return h;
    string s= literal_to_string (h);
    if (starts (s, "tm$"))
      return generic ("<" * s (3, N(s)) * ">");
    string r;
    for (nat i=0; i<N(s); i++)
      if (s[i] == '<') r << "<less>";
      else if (s[i] == '>') r << "<gtr>";
      else r << s[i];
    return r;
  }
  else if (is_func (g, "$concat")) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++)
      concat_append (v, as_texmacs (g[i]));
    if (N(v) == 0) return generic ("");
    else if (N(v) == 1) return v[0];
    else return gen ("$concat", v);
  }
  else if (is_func (g, "$keyword", 1))
    return as_texmacs (gen ("$strong", g[1]));
  else if (is_func (g, "$keyword", 2))
    return as_texmacs (gen ("$concat", gen ("$strong", g[1]), "$spc", g[2]));
  else if (is_func (g, "$bracket", 3))
    return as_texmacs (gen ("$around*", g[1], g[2], g[3]));
  else if (is_func (g, "$prefix", 2)) {
    if (g[1] == "'" || g[1] == "`")
      return as_texmacs (gen ("$concat", gen ("$lprime", g[1]), g[2]));
    else return as_texmacs (gen ("$concat", g[1], g[2]));
  }
  else if (is_func (g, "$postfix", 2)) {
    if (g[2] == "'" || g[2] == "`")
      return as_texmacs (gen ("$concat", g[1], gen ("$lprime", g[2])));
    else return as_texmacs (gen ("$concat", g[1], g[2]));
  }
  else if (is_func (g, "$infix", 3)) {
    if (g[2] == "/")
      return as_texmacs (gen ("$frac", unbracket (g[1]), unbracket (g[3])));
    else if (g[2] == "^")
      return as_texmacs (gen ("$concat",
                              g[1], gen ("$rsup", unbracket (g[3]))));
    else if (g[2] == "|" || g[2] == "||")
      return as_texmacs (gen ("$concat", g[1], gen ("$mid", g[2]), g[3]));
    else {
      generic op= as_texmacs (g[2]);
      if (is_alpha (op))
        op= gen ("$concat", "$spc", gen ("$strong", op), "$spc");
      return as_texmacs (gen ("$concat", g[1], g[2], g[3]));
    }
  }
  else if (is_func (g, "$bigop") && N(g) >= 3) {
    vector<generic> v;
    if (g[1] == GEN_PLUS && is_func (g[2], GEN_MINUS, 1))
      v << generic ("-") << g[2][1];
    else v << g[2];
    for (nat i=3; i<N(g); i++) {
      if (g[1] == GEN_PLUS && is_func (g[i], GEN_MINUS, 1))
        v << generic ("-") << g[i][1];
      else
        v << g[1] << g[i];
    }
    return as_texmacs (gen ("$concat", v));
  }
  else if (is_func (g, "$operate", 2)) {
    if (is_func (g[2], "$bracket", 3) && g[2][1] == "[")
      return as_texmacs (gen ("$concat",
                              g[1], gen ("$rsub", unbracket (g[2]))));
    else return as_texmacs (gen ("$concat", g[1], g[2]));
  }
  else if (is_func (g, "$hlist")) {
    if (N(g) == 1) return generic ("");
    vector<generic> v= vec (g[1]);
    for (nat i=2; i<N(g); i++) v << generic (",") << g[i];
    return as_texmacs (gen ("$concat", v));
  }
  else if (is_func (g, "$vlist")) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++)
      if (is_func (g[i], "$hlist"))
        v << gen ("$row", cdr (compound_to_vector (g[i])));
    if (N(v) == 0) return generic ("");
    return as_texmacs (gen ("$tabular*", gen ("$table", v)));
  }
  else if (is_func (g, "$indent")) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++)
      concat_append (v, as_texmacs (g[i]));
    return gen ("$concat", gen ("$indent", gen ("$concat", v)), gen ("$lf"));
  }
  else if (is_func (g, "$text", 1))
    return gen ("$text", as_texmacs (g[1]));
  else if (is_func (g, "$math", 1))
    return gen ("$math", as_texmacs (g[1]));
  else if (is_func (g, "$dynamic"))
    return gen ("$locus", gen ("$id", as_texmacs (g[1])), as_texmacs (g[2]));
  else if (is<compound> (g)) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++)
      v << as_texmacs (g[i]);
    return gen (g[0], v);
  }
  else ERROR ("not implemented");
}

/******************************************************************************
* Replace line feeds
******************************************************************************/

generic
replace_lf (const generic& g) {
  if (is<literal> (g)) return g;
  else if (is_func (g, "$concat")) {
    bool block= false;
    vector<generic> d;
    vector<generic> c;
    for (nat i=1; i<N(g); i++) {
      if (is_func (g[i], "$lf", 0)) {
        if (N(c) == 0) d << generic ("");
        else if (N(c) == 1) d << c;
        else if (N(c) > 1) d << gen ("$concat", c);
        c= vector<generic> ();
      }
      else if (is_func (g[i], "$cr", 0)) block= true;
      else c << replace_lf (g[i]);
    }
    if (N(c) == 1) d << c;
    else if (N(c) != 0) d << gen ("$concat", c);
    if (N(d) != 1 || block) return gen ("$document", d);
    return d[0];
  }
  else if (is<compound> (g)) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++)
      v << replace_lf (g[i]);
    return gen (g[0], v);
  }
  else {
    mmout << "g= " << g << ": " << type_name (g) << "\n";
    ERROR ("TeXmacs document expected");
  }
}

/******************************************************************************
* Expand TeXmacs (FIXME: should be replaced by something less ad hoc)
******************************************************************************/

generic
texmacs_expand (const generic& g) {
  if (is_func (g, "tm$with"))
    return texmacs_expand (g[N(g)-1]);
  else if (is_func (g, "tm$itemize", 1) || is_func (g, "tm$enumerate", 1))
    return gen ("$indent", texmacs_expand (g[1]));
  else if (is_func (g, "tm$item", 0))
    return generic ("* ");
  else if (is_func (g, "tm$folded", 2))
    return gen ("$varindent",
                gen ("$concat",
                     generic ("o "), texmacs_expand (g[1])));
  else if (is_func (g, "tm$unfolded", 2))
    return gen ("$varindent",
                gen ("$concat",
                     generic ("* "), texmacs_expand (g[1]),
                     generic ("$lf"), texmacs_expand (g[2])));
  else if (is_func (g, "tm$folded-explain", 2))
    return texmacs_expand (g[1]);
  else if (is_func (g, "tm$unfolded-explain", 2))
    return gen ("$concat", texmacs_expand (g[1]),
                generic ("$lf"), generic ("$lf"), texmacs_expand (g[2]));
  else if (is_func (g, "tm$explain", 2))
    return gen ("$concat", texmacs_expand (g[1]), generic ("$lf"),
                gen ("$indent", texmacs_expand (g[2])));
  else if (is_func (g, "tm$explain-synopsis", 1))
    return gen ("$concat", generic (" --- "), texmacs_expand (g[1]));
  else if (is<compound> (g)) {
    vector<generic> v;
    for (nat i=1; i<N(g); i++) v << texmacs_expand (g[i]);
    if (is<literal> (g[0]) && starts (literal_to_string (g[0]), "tm$")) {
      if (N(v) == 1) return v[0];
      else return gen ("$concat", v);
    }
    else return gen (g[0], v);
  }
  else return g;
}

/******************************************************************************
* TeXmacs to Scheme
******************************************************************************/

static void
texmacs_to_scheme (string& s, const generic& g) {
  //mmerr << "g= " << as_lisp (g) << "\n";
  if (is<literal> (g)) s << quote (literal_to_string (g));
  else if (is<compound> (g) && is<literal> (g[0]) &&
           literal_to_string (g[0]) == " ")
    s << "\" \"";
  else if (is<compound> (g) && is<literal> (g[0])) {
    string op= literal_to_string (g[0]);
    if (starts (op, "tm$")) op= op (2, N(op));
    if (!starts (op, "$")) {
      mmerr << "op  = " << op << "\n";
      mmerr << "args= " << compound_to_vector (g) << "\n";
    }
    ASSERT (starts (op, "$"), "invalid TeXmacs markup");
    s << "(" << op (1, N(op));
    for (nat i=1; i<N(g); i++) {
      s << " ";
      texmacs_to_scheme (s, g[i]);
    }
    s << ")";
  }
  else ERROR ("invalid TeXmacs markup");
}

string
as_texmacs_snippet (const generic& g) {
  string  r= "";
  generic h= print_mmx (g);
  generic m= add_modes (h, 0, 1);
  generic t= as_texmacs (m);
  generic l= replace_lf (t);
  texmacs_to_scheme (r, l);
  return r;
}

string
as_texmacs_scheme (const generic& g) {
  string  r= "(document ";
  generic h= print_mmx (g);
  generic m= add_modes (h, 0, 1);
  generic t= as_texmacs (m);
  generic l= replace_lf (t);
  texmacs_to_scheme (r, l);
  r << ")";
  return r;
}

/******************************************************************************
* Scheme to tm
******************************************************************************/

static string
spaces (nat indent) {
  string s;
  for (nat i=0; i<indent; i++)
    s << " ";
  return s;
}

static void
write (string& r, const string& s) {
  nat i, n=N(s);
  for (i=0; i<n; i++) {
    char c= s[i];
    if (c == ' ' && ends (r, " ")) r << "\\ ";
    else if (c == '\n') r << "\\n";
    else if (c == '\t') r << "\\t";
    else if (c == '\0') r << "\\0";
    else if (c == '\\') r << "\\\\";
    else if (c == '<') r << "\\<";
    else if (c == '|') r << "\\|";
    else if (c == '>') r << "\\>";
    else if (c == '\34') r << c;
    else if (((unsigned char) c) < ' ') r << '\\' << (c+'@');
    else r << c;
  }
}

static void
scheme_to_tm (string& s, const generic& g, int indent) {
  //mmout << "Converting " << g << "\n";
  if (is<literal> (g))
    write (s, unquote (literal_to_string (g)));
  else if (is_func (g, "concat")) {
    for (nat i=1; i<N(g); i++)
      scheme_to_tm (s, g[i], indent);
  }
  else if (is_func (g, "document")) {
    for (nat i=1; i<N(g); i++) {
      if (i>1) {
        if (ends (s, "\n")) s << "\\;";
        s << "\n\n" << spaces (indent);
      }
      scheme_to_tm (s, g[i], indent);
    }
  }
  else if (is<compound> (g) && N(g) > 0 && is<literal> (g[0])) {
    string func= literal_to_string (g[0]);
    vector<generic> args= cdr (compound_to_vector (g));
    int i, last, n=N(args);
    for (i=n-1; i>=0; i--)
      if (is_func (args[i], "document"))
        break;
    last= i;
    if (last >= 0) {
      for (i=0; i<=n; i++) {
        bool flag= (i<n) && is_func (args[i], "document");
        if (i==0) s << "<\\" << func;
        else if (i==last+1) s << "</" << func;
        else if (is_func (args[i-1], "document")) s << "<|" << func;
        if (i==n) { s << ">"; break; }

        if (flag) {
          s << ">";
          if (!ends (s, "\n")) s << "\n" << spaces (indent + 2);
          scheme_to_tm (s, args[i], indent + 2);
          if (!ends (s, "\n")) s << "\n" << spaces (indent);
        }
        else {
          s << "|";
          scheme_to_tm (s, args[i], indent);
        }
      }
    }
    else {
      s << "<" << func;
      for (i=0; i<n; i++) {
        s << "|";
        scheme_to_tm (s, args[i], indent);
      }
      s << ">";
    }    
  }
  else ERROR ("invalid scheme markup");
}

static string
as_snippet (const generic& g) {
  string  r= "";
  generic h= print_mmx (g);
  generic m= h;//add_modes (h, 0, 1);
  generic t= as_texmacs (m);
  generic l= replace_lf (t);
  texmacs_to_scheme (r, l);
  return r;
}

string
flatten_as_tm (const generic& x) {
  string r;
  generic g= as_generic (flatten (x));
  g= parse_lisp (as_snippet (g), true);
  if (is_func (g, "text", 1)) g= g[1];
  scheme_to_tm (r, g, 0);
  return r;
}

string
flatten_as_tm (const generic& x, const string& style) {
  string r;
  generic g= as_generic (flatten (x));
  g= parse_lisp (as_snippet (g), true);
  if (is_func (g, "text", 1)) g= g[1];
  if (!is_func (g, "document")) g= gen ("document", g);
  g= gen ("document", gen ("TeXmacs", string ("1.0.7.8")),
          gen ("style", style), gen ("body", g));
  scheme_to_tm (r, g, 0);
  return r;
}

} // namespace mmx