reduce-historical/r38/packages/mathml/om2ir.red

omfuncs!*:=
'((oma . (omaIR))
(oms . (omsIR))
(omi . (omiIR))
(omv . (omvIR))
(omf . (omfIR))
(omstr . (omstrIR))
(ombind . (ombindIR))
(omattr . (omattrIR)));

symbolic procedure om2ir();
begin scalar res;
 % Initialisation of important variables used by the lexer.

 res:=nil;
 FLUID '(safe_atts char ch atts count temp space temp2);
 space:=int2id(32);
 count:=0;
 ch:=readch();
 temp2:=nil;

 % Begining of lexing and parsing

 lex();
 if char='(o m o b j) then <<
     lex();
     res:=omobj();
 >>
   else errorML("<omobj>",2);

 lex();

 if char='(!/ o m o b j) then
   terpri()
   else errorML("</omobj>",19);

 return res;            
end;

symbolic procedure omobj();
begin scalar aa, res;
  % We check what the OpenMath tag is and call the appropriate function. The relationship
  % between OpenMath tag and function to be called is in table omfuncs!*.
  if (aa:=assoc(compress!* char, omfuncs!*)) then return apply(cadr aa, nil);
end;

% The following function recursively reads in objects as defined in
% the OpenMath grammar in the OpenMath standard.

symbolic procedure omobjs();
begin scalar obj, objs;
  if char neq '(!/ o m a) then <<
    obj:=omobj();
    lex();
    objs:=omobjs();
    if obj eq nil then 
     return append(obj, objs)
    else 
     return cons(obj, objs);
  >>;
end;

% Checks if the current token is equivalent to the given tag.

symbolic procedure checkTag(tag);
begin;
  if char neq tag then errorML("Problem", "problem");
end;

% This function returns the symbol read within an <OMS> tag.
% It will also check in the mmleq!* table what the equivalent
% MathML symbol is. If there isnt any it encodes the symbol
% for use in a <semantic> tag.

symbolic procedure omsIR();
begin scalar cd, name, sem, aa, bb, cd, attr, symb, validcd;
  attr:=nil;

  % We read in from the input the name and CD contained
  % in the OMS tag.

  name:= intern find(atts, 'name);
  cd:= intern find(atts, 'cd);

  % We check if the symbol has a MathML equivalent
  % in the mmleq!* table. 
  % But when dealing with a vector, REDUCE works differently
  % hence we have to deal with vectors independently.

  if explode name = '(v e c t o r) then aa:='(vectorml linalg1)
  else aa:=member (intern name, mmleq!*);


  % If nothing was found, we check to see if we are
  % dealing with a special case.
  % If so, we retrieve from the table special_cases!*
  % the equivalent MathML symbol and the correct
  % attribute to add.
 
  if aa=nil then <<
    if (aa:=assoc(name, special_cases!*)) then <<
      attr:=car reverse aa;
      if attr neq nil then attr:=list attr;
      aa:=cadr reverse aa . reverse cddr reverse cdr aa
    >>
    else
      % Here we call special case functions
      % because the tranlation needs some care. 
      if (bb:=assoc(name, special_cases2!*)) neq nil then <<
        return apply(cadr bb, cddr bb)
      >>;
  >>;




  % We now check if aa is still nothing, or if the CD
  % given in the input does not match one of the CDs 
  % contained in aa which map to MathML. If so, we 
  % envelope the input into a semantic tag.


  if aa neq nil then validcd:= assoc(car aa, valid_om!*);
  if validcd neq nil then validcd:=cadr validcd;
  %debug("validcd: ",validcd);

  if aa eq nil OR cd=validcd eq nil then <<
    sem:=encodeIR(name);
    return sem;
  >>;

  % If we are dealing with a vector, we change it to IR rep which
  % is vectorml

  return list(car aa, attr);
end;

% The following function encodes an unknown symbol into a
% valid representation for use within <semantic> tags.

symbolic procedure encodeIR(name);
begin scalar sem;
  sem:=append(char, cons('!  , atts));
  sem:=delall('!$, sem);
  return cons('semantic, list cons(name, list sem));
end;

lisp operator om2mml;

symbolic procedure omiIR();
begin scalar int;
  lex();
  int := compress char;
  lex();
  return int;
end;

symbolic procedure omvIR();
begin scalar name;
  name:=find(atts, 'name);
  if find(atts, 'hex) neq nil then errorML("wrong att", 2);
  if find(atts, 'dec) neq nil then errorML("wrong att", 2);
  return name;
end;

symbolic procedure variablesIR();
begin scalar var, vars;
  if char neq '(!/ o m b v a r) then <<
    var:=omvIR();
  lex();
    vars:=variablesIR();
    if var eq nil then 
     return append(var, vars)
    else 
     return cons(var, vars);
  >>;  
end;

symbolic procedure omfIR();
begin scalar float;
  float:=find(atts, 'dec);
  if find(atts, 'name) neq nil then errorML("wrong att", 2);
  return float;
end;

symbolic procedure omstrIR();
begin scalar str;
  lex();
  str := compress char;
  lex();
  return cons('string, list str);
end;

symbolic procedure omaIR();
begin scalar obj, elems;
  lex();
  obj:=omobj();

  % If we are dealing with a matrix the following code
  % is not executed because the MatrixIR function
  % does the input reading and checks when it has 
  % reached the closing </OMA> tag.

  if car obj neq 'matrix then <<
    lex();
    elems:=omobjs();
    checkTag('(!/ o m a));
  >>;

  return append(obj, elems);
end;

symbolic procedure ombindIR();
begin scalar symb, vars, obj;
  lex();
  symb:=omobj();
  lex();
  vars:=toBvarIR variablesIR();
  lex();
  obj:=omobj();
  lex();
  checkTag('(!/ o m b i n d));
  return append(symb , append(vars, list obj));
end;

symbolic procedure omattrIR();
begin scalar omatp, var;
  lex();
  omatp:=omatpIR();
  lex();
  var:=omobj();
  lex();
  checkTag('(!/ o m a t t r));
  if PAIRP omatp then if cadar omatp = 'csymbol then return (var . list nil);
  if NUMBERP var then return list('cn, omatp, var);
  return list('ci, omatp, var);
end;

symbolic procedure omatpIR();
begin scalar symb ,obj;
  lex();
  symb:=car omsIR();

  lex();
  obj:=car omobj();

  lex();
  checkTag('(!/ o m a t p));

  return list (symb . list obj); 
end;

% The following function transforms a list of variables
% into a list of bvar constructs. ie: (x y)->((bvar x 1)(bvar y 1))

symbolic procedure toBvarIR(bv);
begin;
  if bv neq nil then return cons(cons('bvar, list(car bv, 1)), toBvarIR(cdr bv));
end;


% From here onwards, functions necessary to deal with 
% OpenMath special operators are defined. This is where 
% matrix, int, sum, prod, diff etc... are treated.

symbolic procedure matrixIR();
begin scalar res;
  lex();
  res:=omobjs();
  if caadr cadr res = 'matrixcolumn then res := 'matrixcolumn . list matrixelems(res)
  else res := 'matrixrow . list matrixelems(res);
  return 'matrix . nil . res;
end;

symbolic procedure matrixelems(elem);
  if elem neq nil then cons(cddr car elem, matrixelems cdr elem);  

symbolic procedure sum_prodIR();
begin scalar var, fun, int, name;
  name:=intern find(atts, 'name);
  lex();
  int:=omobj();
  int:='lowupperlimit . (cdr int);
  lex();
  fun:=omobj();
  var:=lambdaVar fun;
  fun:=lambdaFun fun;
  return append(list(name , nil) , append(var  , int . list fun));
  return name . nil . var . int . list fun; 
end;

symbolic procedure integralIR();
begin scalar int, fun, var, tag;
  tag:=intern find(atts, 'name);

  var:=list '(bvar x 1);
  int:=nil;

  % if dealing with defint, determine the interval
  % and store inside variable int

  if tag = 'defint then <<
    lex();
    int:=omobj();
  >>;

  lex();
  fun:=omobj();

  if PAIRP fun then if car fun = 'lambda then << 
      var:=lambdaVar fun; 
      fun:=lambdaFun fun; 
  >>;
  return append(list(tag , nil) , append(var  , list fun));
end;

symbolic procedure partialdiffIR();
begin scalar lis, fun, var, tag, vars;
  tag:=intern find(atts, 'name);

  lex();
  lis:=omobj();

  if car lis='list then lis:=cddr lis
  else errorML("",3);

  lex();
  fun:=omobj();

  if PAIRP fun then 
    if car fun = 'lambda then << 
       var:=lambdaVar fun; 
       fun:=lambdaFun fun; 
       vars:= pdiffvars(lis, var);
    >>;
  
  return append(list('partialdiff , nil) , append(vars  , list fun));
end;

symbolic procedure pdiffvars(ind, v);
begin;
  return if ind neq nil then nth(v, car ind) . pdiffvars(cdr ind, v);
end;

symbolic procedure selectIR();
begin scalar name, cd, a,b, c, tag;
  name:=intern find(atts, 'name);
  cd:=intern find(atts, 'cd);
  tag:=list 'selector;
  if member(cd, '(linalg3)) eq nil then tag:=encodeIR(name);
  lex();
  a:=omobj();
  if name='matrix_selector then <<
  lex();
  b:=omobj();
  >>;
  lex();
  c:=omobj();
  if name='matrix_selector then <<
    return append(tag,  nil . c . a . list b);       
  >>;
  return append(tag,  nil . c . list a);   
end;


symbolic procedure limitIR();
begin scalar val, type, cd, fun, var, res, tag;
  cd:=intern find(atts, 'cd);
  tag:=list 'limit;
  if member(cd, '(limit1)) eq nil then tag:=encodeIR('limit);
  lex();
  val:=omobj();
  lex();
  type:=omobj();
  lex();
  fun:=omobj();


                                                                           

  % Extract the necessary information from the OpenMath read in just above.
  type:=caadr type;

  if member(type, '(below above both_sides null)) eq nil then errorML("wrong method of approach", 2); 
  if type='null then type:='both_sides;

  var:= lambdaVar fun;
  fun:= lambdaFun fun;

  % Transform that information into intermediate representation.
  res:= append(tag, (nil . var ));
  if type neq 'both_sides then
    res:= append(res , list ('condition . list ('tendsto . list ('type . list type) . cadr car var . list val)))
  else
    res:= append(res , list ('condition . list ('tendsto . nil . cadr car var . list val)));
  res:= append(res, list fun);

  return res;
end;

symbolic procedure numIR();
begin scalar base, a1, a2, tag;
  tag:=intern find(atts, 'name);
  lex();
  a1:=omobj();
  lex();
  a2:=omobj();

  if tag = 'complex_cartesian then <<
    if IDP a1 OR IDP a2 then return 'plus . nil . a1 . list ('times . nil . a2 . list '!&imaginaryi!;)
  >>;

  if tag = 'complex_polar then <<
    if IDP a1 OR IDP a2 then return 'times . nil . a1 . list ('exp . nil . list ('times . nil . a2 . list '!&imaginaryi!;))
  >>;

  if tag = 'rational then <<
    if IDP a1 OR IDP a2 then return 'divide . nil . a1 . list a2;
  >>;

  return tag . nil . a1. list a2;

end;

% The following function deals with OpenMath symbols 
% not taking any arguments such as false, true, zero, etc...

symbolic procedure unaryIR(validcd, tag);
begin scalar name, cd;
  name:=intern find(atts, 'name);
  cd:=intern find(atts, 'cd);
  if cd neq validcd then return encodeIR name;
  return tag;
end;

% Returns the first main variable of a lambda expression

symbolic procedure lambdaVar(l);
begin;
  return cdr reverse cddr l; 
end;

symbolic procedure lambdaVar2(l);
begin;
  return cadr caddr l;
end;

% Returns the function of a lambda expression

symbolic procedure lambdaFun(l);
begin;
  return car reverse l;
end;


% This function is the one the user types to 
% translate OpenMath to MathML.


symbolic procedure om2mml();
begin scalar ir;
  ir:=om2ir();
  terpri!* t;
  princ "Intermediate representation:";
  terpri!* t;
  princ ir;
  terpri!* t;
  ir2mml ir;
end;

end;