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

%  Description: This module defines all functions necessary to pass from the
%		intermediate representation to OpenMath. They print out the
%		OpenMath expression on the screen.
%
%  Date: 2 May 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%      

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The following tables are used by the functions in this file 	%	
% in order to map properly intermediate representation tokens	%
% to OpenMath elements and symbols.				%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

mmltypes!*:=
'((complex_cartesian . (complex_cartesian_type))
(complex_polar . (complex_polar_type))
(constant . (constant_type))
(integer . (integer_type))
(list . (list_type))
(matrix . (matrix_type))
(rational . (rational_type))
(real . (real_type))
(set . (set_type)));              

% Maps MathML <interval> attribute values
% to OpenMath symbols

interval!*:=
'((open . (interval_oo))
(closed . (interval_cc))
(open!-closed . (interval_oc))
(closed!-open . (interval_co)));

% Maps MathML constants to OpenMath constant symbols 
% and their CDs.

constantsOM!*:=
'((!&ImaginaryI!; . (nums1 i))
(!&ExponentialE!; . (nums1 e)) 
(!&pi!; . (nums1 pi)) 
(!&NotANumber!; . (nums1 nan))
(!&gamma!; . (nums1 gamma)) 
(!&infin!; . (nums1 infinity)) 
(!&false!; . (logic1 false)) 
(!&true!; . (logic1 true))); 

  
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The function ir2om starts the process of translating intermediate  %
% representation into OpenMath         IR->OpenMath		     %	
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


symbolic procedure ir2om( elem );
begin;
   ind:=2;
   indent:=0;
   printout("<OMOBJ>");
   indent!* t;
   objectOM( elem );
   indent!* nil;
   printout("</OMOBJ>");
end;

symbolic procedure objectOM(elem);
begin scalar aa;;
   if PAIRP elem then <<
    if (aa:=assoc(car elem, ir2mml!*)) then <<
      apply(cadddr aa, list elem)
     >>
    else fnOM(elem);
   >>
   else basicOM(elem);
end;

symbolic procedure strOM(elem);
begin;
  printout "<OMSTR> ";princ cadr elem; princ " </OMSTR>";
end;

% Recieves an element which is not a list
% and prints out OpenMath accordingly.

symbolic procedure basicOM(elem);
begin;
  if NUMBERP elem then <<
    if FIXP elem then integerOM(elem);
    if FLOATP elem then floatOM(elem)
  >>
  else
    if IDP elem then variableOM(elem);
end;                                   

% Prints out integers

symbolic procedure integerOM(elem);
begin;
   printout("<OMI> ");
   princ elem;
   princ " </OMI>"
end;       

% Prints out decimal floats

symbolic procedure floatOM(elem);
begin;
   printout("<OMF ");
   princ "dec="""; princ elem; princ """/>";
end;     

% Prints out OpenMath variables

symbolic procedure variableOM(elem);
begin scalar aa;
 aa:=assoc(intern elem, constantsOM!*);   
 if aa neq nil then <<
    printout("<OMS ");
    princ "cd="""; 
    princ cadr aa; 
    princ """ "; 
    princ "name="""; 
    princ caddr aa; 
    princ """/>";
   >>
   else <<
     if elem neq nil then <<
       printout("<OMV ");
       princ "name="""; princ elem; princ """/>";
    >>
  >>;
end;              



% Prints out all OpenMath symbols of 1, 2, or more arguments
% constructed by application.

symbolic procedure naryOM(elem);
begin scalar cd, name;
  name:=car elem;
  if name='var then name:='variance;
  cd := assoc(name, valid_om!*);
  if cd neq nil then cd:=cadr cd;
  if cadr elem neq nil then <<
    if cadr elem = 'multiset then cd:=cadr elem;
  >>;
  printout "<OMA>";
  indent:=indent+2;
  printout "<OMS cd="""; princ cd; princ """ name="""; princ name; princ """>";
  multiOM(cddr elem);
  indent:=indent-2;
  printout "</OMA>";
end;

symbolic procedure multiOM(elem);
begin;
   if ((length elem)=1) then objectOM( car elem )
       else <<objectOM car elem ; multiOM( cdr elem );>>
end;

% Prints out the OpenMath matrix_selector or
% vector_selector symbols 

symbolic procedure selectOM(elem);
begin scalar name;
  if caaddr elem ='matrix then name:='matrix_selector
  else name:='vector_selector;
  printout "<OMA>";
  indent:=indent+2;
  printout "<OMS cd=""linalg3"" name="""; princ name;
  princ """/>";
  multiOM(cdddr elem);
  objectOM caddr elem;
  indent:=indent-2;
  printout "</OMA>";
end;

% Prints out elements which are 
% containers in MathML.

symbolic procedure containerOM(elem);
begin scalar cd, att, name;
  att:=cadr elem;
  name:=car elem;
  printout "<OMA>";
  indent!* t;
  if name = 'vectorml then name:= 'vector;
  cd := cadr assoc(name, valid_om!*);
  if car elem = 'set and PAIRP att then <<
    if intern cadr car att='multiset then cd:='multiset1; 
  >>;
  
  if car elem = 'vectorml then name:= "vector";
  if car elem = 'vectorml then elem:= 'vector . cdr elem;
  printout "<OMS cd="""; princ cd; princ """ name="""; princ name; princ """/>";
  multiOM(cddr elem);
  indent!* nil;
  printout "</OMA>"; 
end;

% Prints out OpenMath intervals

symbolic procedure intervalOM(elem);
begin scalar aa, att, name, cd;
  att:=cadr elem;
  name:=car elem;
  
  if name = 'lowupperlimit then <<name:='integer_interval; att:=nil; elem:=car elem . nil . cdr elem>>;

  cd := cadr assoc(name, valid_om!*);

  if att neq nil then <<
     aa:=assoc(intern cadr car att, interval!*);
     name:=cadr aa;
  >>;

  printout "<OMA>";
  indent!* t;
  printout "<OMS cd="""; princ cd; princ """ name="""; princ name; princ """/>";
  multiOM(cddr elem);
  indent!* nil;
  printout "</OMA>"; 
  
end;

% Prints matrices according to the definition
% in CD linalg1

symbolic procedure matrixOM(elem);
begin;
  printout "<OMA>";
  indent!* t;
  printout "<OMS cd=""linalg1"" name=""matrix""/>";
  matrixrowOM(cadddr elem);
  indent!* nil;
  printout "</OMA>";
end;

symbolic procedure matrixrowOM(elem);
begin;
  if elem neq nil then <<
    printout "<OMA>";
    indent!* t;
    printout "<OMS cd=""linalg1"" name=""matrixrow""/>";
    multiOM(car elem);
    indent!* nil;
    printout "</OMA>";
    matrixrowOM cdr elem;
  >>;
end;

% Prints out variables which posses
% an attribute

symbolic procedure ciOM(elem);
begin; 
  printout "<OMATTR>";
  indent!* t;
  printout "<OMATP>";
  indent!* t;
  printout "<OMS cd=""typmml"" name=""type"">";    
  printout "<OMS cd=""typmml"" name="""; 
  princ assoc(intern cadr car cadr elem, mmltypes!*);
  princ cadr assoc(intern cadr car cadr elem, mmltypes!*);
  princ """>";  
  indent!* nil;
  printout "</OMATP>";
  objectOM(caddr elem);
  indent!* nil;
  printout "</OMATTR>";
end;

% Prints out constants such as pi, gamma etc...

symbolic procedure numOM(elem);
begin;
  printout "<OMA>";
  indent!* t;
  printout "<OMS cd=""nums1"" name="""; princ car elem; princ """/>";
  objectOM cadr elem;
  if car elem='based_integer then strOM cadr caddr elem 
  else objectOM caddr elem;
  indent!* nil;
  printout "</OMA>";
end;

symbolic procedure fnOM(elem);
begin;
  printout "<OMA>";
  indent!* t;
  printout "<OMATTR>";
  indent!* t;
  printout "<OMATP>";
  indent!* t;
  printout "<OMS cd=""typmml"" name=""type""/>";  
  
  printout "<OMS cd=""typmml"" name="""; princ "fn_type"; princ """/>";  
  indent!* nil;
  printout "</OMATP>";
  objectOM car elem;
  indent!* nil;
  printout "</OMATTR>";
  multiOM(cddr elem);
  indent!* nil;
  printout "</OMA>";  
end;

% Prints out partial differentiation expressions

symbolic procedure partialdiffOM(elem);
begin scalar cd, var, fun, name;
  cd := assoc(car elem, valid_om!*);
  if cd neq nil then cd:=cadr cd;
  name:=car elem;
  var:=cdr reverse cddr elem;
  fun:=car reverse elem;
    
  if length var = 1 then symbolsOM('diff . cdr elem);
end;

% Prints out elements such as sum, prod, diff and int. 

symbolic procedure symbolsOM(elem);
begin scalar cd, var, fun, int, name;
  cd := assoc(car elem, valid_om!*);
  if cd neq nil then cd:=cadr cd;
  name:=car elem;
  var:=caddr elem;
  fun:=car reverse elem;
  if name neq 'diff then int:=cadddr elem;

  % This error states that a <sum> will not be translated to MathML
  if int neq nil then if car int = 'condition then errorML("<condition> tag not supported in MathML", 1);

  printout "<OMA>";
  indent!* t;
  if int neq nil AND name='int then name:='defint; 
  printout "<OMS cd="""; princ cd; princ """ name="""; princ name; princ """/>";
  if int neq nil then objectOM int;
  lambdaOM ('lambda . nil . var . list fun);
  indent!* nil;
  printout "</OMA>";
end;

% Prints out lambda expressions

symbolic procedure lambdaOM(elem);
begin scalar var, fun;
  var:= cadr caddr elem;
  fun:=car reverse elem;
  printout "<OMBIND>";
  indent!* t;
  printout "<OMS cd=""fns1"" name=""lambda""/>";
  printout "<OMBVAR>";
  indent!* t;
  objectOM var;
  indent!* nil;
  printout "</OMBVAR>";
  objectOM fun;
  indent!* nil;
  printout "</OMBIND>";
end;

% Does not work...

symbolic procedure semanticOM(elem);
begin scalar sem;
  printout "<OMA>";
  indent!* t;
  sem:=cadr cadr elem;
  list2string sem;
  multiOM cddr elem;
  indent!* nil;
  printout "</OMA>";
end;

% Prints out limit expressions

symbolic procedure limitOM(elem);
begin scalar limit, fun, var, tendsto;
  var:=caddr elem;
  limit:=cadddr elem;
  fun:=car reverse elem;

  printout "<OMA>";
  indent!* t;
  printout "<OMS cd=""limit1"" name=""limit""/>";
  if car limit = 'lowlimit then << 
    objectOM cadr limit;
    printout "<OMS cd=""limit1"" name=""null""/>" 
  >>;
  if car limit = 'condition then << 
    objectOM car reverse cadr limit;
    tendsto:=  cadr car cadr cadr limit;  
    printout "<OMS cd=""limit1"" name="""; princ tendsto; princ """/>"     
  >>;
  lambdaOM ('limit . nil . var . list fun);
  indent!* nil;
  printout "</OMA>";
end;

% Prints out OpenMath quantifiers

symbolic procedure quantOM(elem);
begin;
  if cadr reverse elem neq nil then errorML("condition tag not supported in MathML ", 2);
  printout "<OMBIND>";
  indent!* t;
  printout "<OMS cd=""quant1"" name="""; princ car elem; princ """/>";
  printout "<OMBVAR>";
  indent!* t;
  bvarOM cddr elem;
  indent!* nil;
  printout "</OMBVAR>";
  objectOM car reverse elem;
  indent!* nil;
  printout "</OMBIND>";
end;

symbolic procedure bvarOM(elem);
begin;
  if PAIRP car elem then
  if car car elem = 'bvar then <<objectOM cadr car elem; bvarOM cdr elem>>;
end;

symbolic procedure printout( str );
begin;
   terpri!* t;
   for i := 1:indent do << princ " " >>;                       
   princ str;
end;                

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

symbolic procedure mml2om();
begin scalar a;;
  a:=mml2ir();
  terpri!* t;
  princ "Intermediate representation: "; terpri!* t; print a;
  ir2om a;      
end;

lisp operator mml2om;

end;