;;;;;;;;;;;;;;;;; File:    ;;;;;;;;;;;;;;;;;;;;;
;; Purpose:   Loads initial libraries
;;            makes general representation default
;;            adds the filter function
;;	      functions for maxima syntax to openmath conversion.
;;        
;;
;; Usage:     load this file into maxima 
;;                loadfile("InitializeService.lsp");
;;
;; Author: Olga Caprotti
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; makes general representation default
(in-package "MAXIMA")

;; add libraries here

;;($load 'eigen);      
;;($LOAD 'eigen);      
;;($load 'vect);      
;;($LOAD 'vect);      
;;($LOAD 'descriptive);      
;;;;;;;;;;;;;;;functions in development;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun columncount(mat)
  (- (length (second mat)) 1)
)
(defun rowcount(mat)
 (- (length mat) 1)
)

(defun sizemat(mat)
  (* (columncount mat) (rowcount mat))
)

;; custom exponent function that is commutative unless the argument is a matrix
(defun exptoverloaded(expr n)
  (cond 
    ( (and 
        (OMAp expr)
        (eq (first (first expr)) '$MATRIX)
      ) (mfuncall '$apply "^^" (list '(MLIST SIMP) expr n) ) )
    (T (mfuncall '$apply "^" (list '(MLIST SIMP) 2 2) ))
  )
)

;; :lisp (extendpairHelp '(1 2) '(3 4) nil 0 0)

(defun extendpairHelp(l1 l2 result times copy) 
	(cond 
		((and (eq l2 nil) (eq times 0)) result)
		((eq times 0) (extendpairHelp (rest l1) 
			(rest l2) result (first l2) (first l1)))
		(T (extendpairHelp l1 l2 
			(append result (cons copy nil))
			(- times 1)
			copy
		   )
		)
	)
)

;; ?extendpair([[1,2],[3,4]]) gives ((MLIST SIMP) 1 1 1 2 2 2 2) 

(defun extendpair(l)
        (cons 
		'(MLIST SIMP)
		(extendpairHelp (rest (second l))
			(rest (third l))
			nil
			'0
			'0
		)
	)
)
(defun pairhelp(L1 L2)
(if (eq L1 NIL) 
	'NIL
	(cons (list '(MLIST SIMP) (first L1) (first L2)) (pairhelp (rest L1) (rest L2))))
)
(defun pair(v)
	(cons '(MLIST SIMP)(pairhelp (rest (extendpair (second v))) (rest (rest v))))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; maxima to OpenMath conversion ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;Introduction:
;;This section contains functions used to convert an expression written in 
;;maxima syntax into OpenMath.The OpenMath expressions can be OMA, OMBIND, 
;;OMF, OMI or OMV. 

;;to_openmath
;;The top level function to_openmath takes an expression in maxima syntax as 
;;input and returns an object of openmath type i.e 
;;((OPENMATH SIMP) "openmath_code_here").

;;Output Buffer 
;;A global output buffer is used to store the openmath code as a string, and 
;;when the whole expression has been converted then to_openmath returns this 
;;string as an openmath object.

;;OpenMath applications
;;The applications have been split into two parts, some can be 
;;directly translated into openmath in the function openmathOMA, while the 
;;other contains the symbols which require something extra for the 
;;conversion, and hence there are seperate functions for these symbols.
;;The top level function for these cases is openmathOMAHd.

;;Common Lisp functions 
;;The common lisp functions used are:
;;concatenate: to append the second string to the first
;;		(concatenate 'string result str) appends str to 
;;		result		
;;first, second...nth:for extracting the respective element of list.
;;		     (first '(a b c)) gives 'a'.
;;		     (nth '(a b c) 2) and (second '(a b c)) give 'b'
;;map: for applying a function to all elements of a list
;;	(map nil #'f l) applies the function f to all elements of list l.
;;char-downcase: to make a character in lower case
;;		(char-downcase #\A) gives 'a'
;;case: a simple case statement, the statement corrosponding to matching tag
;;	is executed.
;;(case expr
;;    (LAMBDA T)
;;    (FALL T)
;;    (otherwise NIL)
;;if expr is LAMBDA or FALL then T is returned, otherwise NIL.
;;cond: the first statement whose condition is satisfied is executed and then 
;;	cond is exited.
;; (cond ((> p 1) 'a)
;;	((< p 1) 'b)
;;	(= p 1) 'c)
;; ) returns 'a,'b or 'c depending if p>1 or p<1 or p=1

;;user defined functions
;;xor: mathml requires a n-ary xor, but maxima provides only binary xor
;;	so a n-ary xor was coded.
;;filter:takes a list and a predicate as input, and returns the sublist such 
;;	that the elements satisfy the predicate.

;;Adding a symbol
;; 1. See if the symbol can appear as maxima output, if not then nothing 
;;    needs to be done.
;; 2. If yes, then see that is it an application or a binding.If a binding 
;;    then add the symbol to binderp. 
;; 3. If an application then see if it can be directly translated. If yes, 
;;    then add it to openmathOMS
;;4. If it can not be directly translated make a seperate function 
;;   openmathCdSymbol,and add the symbol to hardSymbol and openmathOMAHd.
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;list of functions;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;utility functions for buffer
;;append-to-buffer: appends a string into the output buffer
;;clear-output-buffer: initializes the output buffer to " ".
;;get-buffer-content: returns the contents of output buffer.

;;functions for testing the type of expressions
;;binderp: helper function of OMBINDp
;;OMAp: check if symbol corresponds to an OMA type
;;OMBINDp: check if symbol corresponds to an OMBIND type
;;OMVp: check if symbol corresponds to an OMV type
;;hardSymbol: helper function for OMAhardp
;;OMAhardp: checks if symbol is an application and cannot be directly  
;;	    translated to OMA.
;;OPENMATHSTRp: for checking the type of output is openmath output

;;To generate some openmath expressions special functions are needed. Here is 
;;a list of symbols that need such a function. For example the function 
;;corresponding to set1.set is openmathSet1Set   
;;arith1:product,sum
;;Bigfloat1: bigfloat
;;calculus1:defint,diff,int,nthdiff
;;integer1:factotof
;;interval1:integer_interval
;;limit1: limit
;;linalg1: matrix_selector,outerproduct,vector_selector
;;linalg2: matrix,matrix_row,vector
;;linalg3: characterstic_eqn
;;list1: list,map
;;logic1: equivalent
;;relation1: eq,geq,gt,leq,lt,neq
;;rounding1: ceiling,floor,round,trunc
;;s_data1: mean,median,std,var
;;set1: map,set,emptyset

;;a function each for each openmath type. For example the function for 
;;generating openmath code for an OMI is openmathOMI
;;openmathOMA:  adds an application which can be directly translated
;;		as openmath to the buffer
;;openmathOMAHd:  adds an application which cannot be directly translated
;;		  as openmath to the buffer
;;openmathOMBIND:adds a binding as openmath to the buffer
;;openmathOMF:adds a floating point number as openmath to the buffer
;;openmathOMI:adds an integer as openmath to the buffer
;;openmathOMS:adds a symbol as openmath to the buffer
;;openmathOMV:adds a variable as openmath to the buffer
;;openmath: adds a generic expression as openmath to the buffer
;;to_openmath: converts an expression into an openmath typed string, is the 
;;	       topmost function for openmath conversion.




;;global buffer for storing output
(setf result "")

;;appends the input string to the output buffer
(defun append-to-buffer(flag str)
	;;result:=append(result,str)
	(setf result (concatenate 'string result str))
)

;;for clearing the output buffer
(defun clear-output-buffer()
(setf result "")
)

;;returns the contents of output buffer
(defun get-buffer-content()
	result
)

;;checks if symbol corresponds to an OMBIND type, e.g lambda
(defun binderp (expr)
 (case expr
    (LAMBDA T)
    (otherwise NIL)
 )
)

;;for testing if the expr in input corresponds to an OMA
;;that is the expressions are things like (( _ ) ...) where '_' is a dont care.
;;e.g ((MPLUS SIMP) $A $B) or ((MPLUS) $A $B)
(defun OMAp(expr)
  (cond
       ;;expr should be a list
       ((not (listp expr)) NIL)
       ;;first element of expr should be a list
       ((not (listp (first expr))) NIL)
       ;;first element of expr should be of type ( _ ...) where _ should not  
       ;;be a binding symbol like LAMBDA
       ((binderp (first (first expr))) NIL)
	;;otherwise true
       (t t)))

;;for testing if the expr in input corresponds to an OMBINDING. For it to 
;;happen the expression should be ((binder ..)...).
;;e.g ((LAMBDA SIMP) ((MLIST) $X $Y) ((MPLUS) $X $Y))
(defun OMBINDp(expr)

  (cond
	;;expr should be a list
	((not (listp expr)) NIL)
	;;first element of expr should be a list
	((not (listp (first expr))) NIL)
	;;first element of expr should be of type ( _ ..) where _ should be a 
	;;binding.
        ((binderp (first (first expr))) T)
	;;otherwise false
       (t NIL)))

;;for testing if the expr in input corresponds to an OMV
(defun OMVp(expr)
;;for variable the first element should be a $ and second not a %
(if (symbolp expr) 
	(when (> (length (string expr)) 1)
 	(and 
	   (not (equal #\% (char (string expr) 1)))
	   (and 
		(symbolp expr)
		(equal #\$ (char (string expr) 0)))))NIL)
)	

;;Checks if the application symbols correspond to those for which direct 
;;translation is not possible, and seperate functions are required.
(defun hardSymbol(expr)
	(case expr
		(%PRODUCT T)
		(%SUM T)
		(BIGFLOAT T)
		($DIFF T)
		(%INTEGRATE T)
		(%DERIVATIVE T)
		($MAKELIST T)
		(%LIMIT T)
		(MQAPPLY T)
		($MATRIX T)
		(MLIST T)
		($OUTERMAP T)
		($IS T)
		(CEILING T)
		(FLOOR T)
		(ROUND T)
		(TRUNCATE T)
		($MEAN T)
		($MEDIAN T)
		($STD T)
		($VAR T)
		($SET T)
		(${ T)
		($CHARPOLY T)
		(otherwise NIL)
	)
)

;;for detecting the applications(OMA type) which cannot be translated 
;;directly, see openmathOMAHd.
(defun OMAhardp(expr)
	(and (OMAp expr ) (hardSymbol (first (first expr)))))

;;for checking if the type is an openmath object,i.e if input is of the form
;;((OPENMATH SIMP) ..) then it is openmath object and the function returns
;; true otherwise false.
(defun OPENMATHSTRp (expr)
        (cond
                ;; should be a list, if not return false
		((not (listp expr)) NIL)
                ;; first element should be (OPENMATH SIMP) if not return false
		((not (equal (first (first expr)) 'OPENMATH)) NIL)
		((not (equal (second (first expr)) 'SIMP)) NIL)
		;; otherwise return true
		(t t)
	)
)

;;;;;;;;;;;;
;; arith1 ;;
;;;;;;;;;;;;
;;symbols:product,sum

(defun openmathArith1Product(expr)
	(append-to-buffer t "<OMA>~%<OMS cd =\"arith1\" name=\"product\"/>~%<OMA>~%")
	(append-to-buffer t "<OMS cd =\"interval1\" name=\"integer_interval\"/>~%")
	(openmath (fourth expr))
	(openmath (fifth expr))
	(append-to-buffer t "</OMA>~%<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>~%")
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%")
	(openmath (second expr))
	(append-to-buffer t "</OMBINDING>~%</OMA>~%")
)

(defun openmathArith1Sum(expr)
	(append-to-buffer t "<OMA>~%<OMS cd =\"arith1\" name=\"sum\"/>~%<OMA>~%")
	(append-to-buffer t "<OMS cd =\"interval1\" name=\"integer_interval\"/>~%")
	(openmath (fourth expr))
	(openmath (fifth expr))
	(append-to-buffer t "</OMA>~%<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>~%")
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%")
	(openmath (second expr))
	(append-to-buffer t "</OMBINDING>~%</OMA>~%")
)

(defun openmathBigfloat1Bigfloat(expr)
	(append-to-buffer t "<OMA>~%<OMS cd =\"bigfloat1\" name=\"bigfloat\"/>~%")
;;	(print (* 1.0 (/ (* (second expr) (expt 2 (- (third expr) 1))) (expt 2 (- (third (first expr)) 1)))))
	(openmath (* 1.0 (/ (* (second expr) (expt 2 (- (third expr) 1))) (expt 2 (- (third (first expr)) 1)))))
	(append-to-buffer t "</OMA>~%")	
)

;;;;;;;;;;;;;;;;
;;calculus1;;
;;;;;;;;;;;;;;;;
;;symbols:defint,diff,int,nthdiff

(defun openmathCalculus1Defint(expr)
	(append-to-buffer t "<OMA>~%<OMS cd =\"calculus1\" name=\"defint\"/>~%")
	(append-to-buffer t "<OMA>~%<OMS cd =\"interval1\" name=\"interval\"/>~%")
	(openmath (fourth expr))
	(openmath (fifth expr))
	(append-to-buffer t "</OMA>~%<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>")	
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%")	
	(openmath (second expr))
	(append-to-buffer t "</OMBIND>~%</OMA>~%")
		
)

(defun openmathCalculus1Diff(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"calculus1\" name=\"diff\"/>~%<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>~%");
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%");
	(openmath (second expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathCalculus1Int(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"calculus1\" name=\"int\"/>~%<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>~%");
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%");
	(openmath (second expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathCalculus1Nthdiff(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"calculus1\" name=\"nthdiff\"/>~%")
	(openmath (fourth expr))
	(append-to-buffer t "<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>~%")
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%")
	(openmath (second expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathInteger1Factorof(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"integer1\" name=\"factorof\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathInterval1Integer_interval(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"interval1\" name=\"integer_interval\"/>~%")
	(openmath (third expr))
	(openmath (fourth expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLimit1Limit (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"limit1\" name=\"limit\"/>~%")
	(openmath (third expr))
	(if (eq (length expr) 4)
	(append-to-buffer t "<OMS cd=\"limit1\" name=\"both_sides\"/>~%")
	(openmath (fifth expr)))
	(append-to-buffer t "<OMBIND>~%<OMS cd=\"fns1\" name=\"lambda\"/>~%<OMBVAR>~%")
	(openmath (third expr))
	(append-to-buffer t "</OMBVAR>~%")
	(openmath (second expr))
	(append-to-buffer t "</OMBIND>~%</OMA>~%")
)

;;;;;;;;;;;;;
;; linalg1 ;;
;;;;;;;;;;;;;
;;symbols: matrix_selector,outerproduct,vector_selector

(defun openmathLinalg1Matrix_selector (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg1\" name=\"matrix_selector\"/>~%")
	(openmath (third expr))
	(openmath (fourth expr))
	(openmath (second expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLinalg1Outerproduct (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg1\" name=\"outermap\"/>~%")
	(openmath (third (fourth (third expr))))
	(openmath (fourth (fourth (third expr))))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLinalg1Vector_selector (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg1\" name=\"vector_selector\"/>~%")
	(openmath (third expr))
	(openmath (second expr))
	(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;
;; linalg2 ;;
;;;;;;;;;;;;;
;;symbols: matrix,matrix_row,vector

(defun openmathLinalg2Matrix (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg2\" name=\"matrix\"/>~%")
	(map nil #'openmathLinalg2Matrixrow (rest expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLinalg2Matrixrow (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg2\" name=\"matrixrow\"/>~%")
	(map nil #'openmath (rest expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLinalg2Vector (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg2\" name=\"vector\"/>~%")
	(map nil #'openmath (rest expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLinalg4Characterstic_eqn(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"linalg4\" name=\"characterstic_eqn\"/>~%")
	(openmath (second expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathList1List (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"list1\" name=\"list\"/>~%")
	(map nil #'openmath (rest expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathList1Map (expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"list1\" name=\"map\"/>~%")
	(map nil #'openmath (rest expr))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathLogic1Equivalent(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"logic1\" name=\"equivalent\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;;;
;; relation1 ;;
;;;;;;;;;;;;;;;
;;symbols:eq,geq,gt,leq,lt,neq

(defun openmathRelation1Eq(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"relation1\" name=\"eq\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRelation1Geq(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"relation1\" name=\"geq\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRelation1Gt(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"relation1\" name=\"gt\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRelation1Leq(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"relation1\" name=\"leq\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRelation1Lt(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"relation1\" name=\"lt\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRelation1Neq(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"relation1\" name=\"neq\"/>~%")
	(openmath (second (second expr)))
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;;;
;; rounding1 ;;
;;;;;;;;;;;;;;;
;;symbols: ceiling,floor,round,trunc

(defun openmathRounding1Ceiling(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"rounding1\" name=\"ceiling\"/>~%")
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRounding1Floor(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"rounding1\" name=\"floor\"/>~%")
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRounding1Round(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"rounding1\" name=\"round\"/>~%")
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathRounding1Trunc(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"rounding1\" name=\"trunc\"/>~%")
	(openmath (third (second expr)))
	(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;
;; s_data1 ;;
;;;;;;;;;;;;;
;;symbols: mean,median,std,var

(defun openmathS_data1Mean(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"s_data1\" name=\"mean\"/>~%")
	(map nil #'openmath (rest (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathS_data1Median(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"s_data1\" name=\"median\"/>~%")
	(map nil #'openmath (rest (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathS_data1Std(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"s_data1\" name=\"std\"/>~%")
	(map nil #'openmath (rest (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathS_data1Var(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"s_data1\" name=\"var\"/>~%")
	(map nil #'openmath (rest (second expr)))
	(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;
;; cd:set1 ;;
;;;;;;;;;;;;;
;; symbols:emptyset,map,set

(defun openmathSet1Emptyset(expr)
	(append-to-buffer t "<OMS cd=\"set1\" name=\"emptyset\"/>~%")
)

(defun openmathSet1Map(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"set1\" name=\"map\"/>~%")
	(map nil #'openmath (rest (second expr)))
	(append-to-buffer t "</OMA>~%")
)

(defun openmathSet1Set(expr)
	(append-to-buffer t "<OMA>~%<OMS cd=\"set1\" name=\"set\"/>~%")
	(map nil #'openmath (rest expr))
	(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;;;;;
;; openmathOMA ;;
;;;;;;;;;;;;;;;;;

;;expr: an expression which corresponds to an openmath object  for which
;;	a direct translation can be performed. see openmathOMAHd.
;;output:append the corresponding openmath string for expr to the result 
;;buffer.e.g sin(x) is appended to buffer as 
;;<OMA><OMS cd="transc1" name="sin"/><OMV name="x"/></OMA>
(defun openmathOMA(expr)
		(append-to-buffer t "<OMA>~%")
  		(openmathOMS (first (first expr)))
  		(map nil #'openmath (rest expr))
		(append-to-buffer t "</OMA>~%")
)

;;;;;;;;;;;;;;;;;;;
;; openmathOMAHd ;;
;;;;;;;;;;;;;;;;;;;

;; to decode the cases which cannot be translated directly, because there are
;;different translations for the same symbol(e.g MLIST can be a matrixrow or 
;;vector or list), different order of arguments(e.g product of maxima 
;;requires the arguments in different order than product of openmath).
(defun openmathOMAHd(expr)
(let((q (first (first expr))))	
	(case q
		(%PRODUCT (openmathArith1Product expr))
		(%SUM (openmathArith1Sum expr))
		(BIGFLOAT (openmathBigfloat1Bigfloat expr))
		($INTEGRATE (openmathCalculus1Int expr))
		($DEFINT (openmathCalculus1Defint expr))
		($MAKELIST (openmathInterval1Integer_interval expr))
		($OUTERMAP (openmathLinalg1Outerproduct expr))
		(CEILING (openmathRounding1Ceiling expr))
		(FLOOR (openmathRounding1Floor expr))
		(ROUND (openmathRounding1Round expr))
		(TRUNCATE (openmathRounding1Trunc expr))
		($MEAN (openmathS_data1Mean expr))		
		($MEDIAN (openmathS_data1Median expr))
		($STD (openmathS_data1Std expr))
		($VAR (openmathS_data1Var expr))
		(${ (openmathSet1Set expr))
		($SET (openmathSet1Set expr))
		($CHARPOLY (openmathLinalg4Characterstic_eqn expr))
		($DIFF 
		(let((q (length expr)))
			(case q
				;;diff(f,x)
				(3 (openmathCalculus1diff expr))
				;;diff(f,x,n)
				(4 (openmathCalculus1Nthdiff expr))
				;;diff(f,x1,n1,...)
				(otherwise (append-to-buffer t "<OMS cd=\"calculus1\" name=\"partialdiff\"/>~%"))

			)
		)			
		)
		(%DERIVATIVE 
		(let((q (length expr)))
			(case q
			;;diff(f,x)
			(3 (openmathCalculus1diff expr))
			;;diff(f,x,n)
			(4 (openmathCalculus1Nthdiff expr))
			;;diff(f,x1,n1,...)			
(otherwise (append-to-buffer t "<OMS cd=\"calculus1\" name=\"partialdiff\"/>~%"))

			)
		)			
		)
		(%LIMIT (openmathLimit1Limit expr)

		)
		(MQAPPLY 
			(if(equal (first (second expr)) '$MATRIX)
			(openmathLinalg1Matrix_selector expr)
			(openmathLinalg1Vector_selector expr)
			)
		)
		($MATRIX
			(openmathLinalg2Matrix expr)
		)
		(MLIST 
			;;do not know how to handle between list and vector
			(openmathLinalg2Vector expr)		
					
		)
		($SET 
		(if (eq (length expr) 1)
			;;empty set is of ((SET ?)) form(? means SIMP can be there or not) 
			(openmathSet1Emptyset expr)
			(openmathSet1Set expr)
		)
		)
		($MAP 
		(if(equal (first (first(third expr))) '$SET)
			(openmathSet1Map expr)
			(openmathList1Map expr)		
		))
		($IS
		;;need a case for is
		(case (first (second expr))
		(MEQUAL (openmathInteger1Factorof expr))
		(EQ (openmathLogic1Equivalent expr))
		($EQUAL (openmathRelation1Eq expr))
		(MGEQP (openmathRelation1Geq expr))
		(MGREATERP (openmathRelation1Gt expr))
		(MLEQP (openmathRelation1Leq expr))
		(MLESSP (openmathRelation1Lt expr))
		(MNOTEQUAL (openmathRelation1Neq expr))
		))

		(otherwise NIL)
	)	
))

;;;;;;;;;;;;;;;;;;;;
;; openmathOMBIND ;;
;;;;;;;;;;;;;;;;;;;;

;;expr: an expression which is of OMBINDING type.
;;output:append the corresponding openmath string for expr to the result 
;;buffer. e.g ((LAMBDA SIMP) ((MLIST) $X) ( $X )) translates to
;;<OMBIND><OMS cd="fns1" name="lambda"/><OMBVAR><OMV name="x"/></OMBVAR>
;;<OMV name="x"/></OMBIND>
(defun openmathOMBIND(expr)
		(append-to-buffer t "<OMBIND>~%")
  		(openmathOMS (first (first expr)))
		(append-to-buffer t "<OMBVAR>~%")
		(map nil #'openmath (rest (second expr)))
		(append-to-buffer t "</OMBVAR>~%")
  		(openmath (third expr))
		(append-to-buffer t "</OMBIND>~%")
)

;;;;;;;;;;;;;;;;;
;;openmathOMERR;;
;;;;;;;;;;;;;;;;;

;;text: some text explaining the error
;;expr: the expression in maxima
;;output:append the corresponding openmath string for expr to the result 
;;buffer
(defun openmathOME(text)
	(append-to-buffer t "<OME>")
	(append-to-buffer t "<OMS cd='moreerrors' name='encodingError'/>")
	(append-to-buffer t "<OMSTR>")
	(append-to-buffer t text)
	(append-to-buffer t "</OMSTR>")
	(append-to-buffer t "</OME>~%"))

;;;;;;;;;;;;;;;
;;openmathOMF;;
;;;;;;;;;;;;;;;

;;expr: a floating point number in maxima
;;output:append the corresponding openmath string for expr to the result 
;;buffer. e.g 3.0 to <OMF dec="3.0"/>
(defun openmathOMF(expr)
	(append-to-buffer t (format nil "<OMF dec=\"~f\"/>~%" expr)))

;;;;;;;;;;;;;;;
;;openmathOMI;;
;;;;;;;;;;;;;;;

;;expr: an integer in maxima
;;output:append the corresponding openmath string for expr to the result 
;;buffer.e.g 2 to <OMI>2</OMI>
(defun openmathOMI(expr)
	(append-to-buffer t "<OMI>" ) 
	(append-to-buffer t (write-to-string expr))
	(append-to-buffer t "</OMI>~%"))

;;;;;;;;;;;;;;;;;
;; openmathOMS ;;
;;;;;;;;;;;;;;;;;
;; arguments:
;; expr : openmath expression (should be an openmath symbol OMS)
;; result: append the corresponding openmath string for expr to the result 
;;buffer

(defun openmathOMS(expr)
  (case expr
	(MPLUS (append-to-buffer t "<OMS cd=\"arith1\" name=\"plus\"/>~%"))
	(LCM (append-to-buffer t "<OMS cd=\"arith1\" name=\"lcm\"/>~%"))
	($GCD (append-to-buffer t "<OMS cd=\"arith1\" name=\"gcd\"/>~%"))
	(MMINUS(append-to-buffer t "<OMS cd=\"arith1\" name=\"unary_minus\"/>~%"))
	(MTIMES(append-to-buffer t "<OMS cd=\"arith1\" name=\"times\"/>~%"))
	(MQUOTIENT (append-to-buffer t "<OMS cd=\"arith1\" name=\"divide\"/>~%"))
	(MNCEXPT (append-to-buffer t "<OMS cd=\"arith1\" name=\"power\"/>~%"))
	(MEXPT (append-to-buffer t "<OMS cd=\"arith1\" name=\"power\"/>~%"))
	(MABS (append-to-buffer t "<OMS cd=\"arith1\" name=\"abs\"/>~%"))
	(MNCTIMES (append-to-buffer t "<OMS cd=\"arith1\" name=\"times\"/>~%"))

	($CARG (append-to-buffer t "<OMS cd=\"complex1\" name=\"argument\"/>~%"))
	;;complex_cartesian,complex_polar no symbols
	($CONJUGATE (append-to-buffer t "<OMS cd=\"complex1\" name=\"conjugate\"/>~%"))
	($IMAGPART (append-to-buffer t "<OMS cd=\"complex1\" name=\"imaginary\"/>~%"))
	($REALPART (append-to-buffer t "<OMS cd=\"complex1\" name=\"real\"/>~%"))
	
	($IDENTITY (append-to-buffer t "<OMS cd=\"fns1\" name=\"identity\"/>~%"))
	(LAMBDA (append-to-buffer t "<OMS cd=\"fns1\" name=\"lambda\"/>~%"))

	(FACTOROF (append-to-buffer t "<OMS cd=\"integer1\" name=\"factorof\"/>~%"))
	(MFACTORIAL (append-to-buffer t "<OMS cd=\"integer1\" name=\"factorial\"/>~%"))
	($QUOTIENT (append-to-buffer t "<OMS cd=\"integer1\" name=\"quotient\"/>~%"))
	($REMAINDER (append-to-buffer t "<OMS cd=\"integer1\" name=\"remainder\"/>~%"))

	
	($PLUS  (append-to-buffer t "<OMS cd=\"limit1\" name=\"above\"/>~%"))
	($MINUS  (append-to-buffer t "<OMS cd=\"limit1\" name=\"below\"/>~%"))
	
	(%DETERMINANT (append-to-buffer t "<OMS cd=\"linalg1\" name=\"determinant\"/>~%"))
	(MQAPPLY (append-to-buffer t "<OMS cd=\"linalg1\" name=\"matrix_selector\"/>~%"))
	($OUTERMAP (append-to-buffer t "<OMS cd=\"linalg1\" name=\"outerproduct\"/>~%"))
	(%TRANSPOSE (append-to-buffer t "<OMS cd=\"linalg1\" name=\"transpose\"/>~%"))

	(COLUMNCOUNT  (append-to-buffer t "<OMS cd=\"linalg4\" name=\"columncount\"/>~%"))
	($RANK (append-to-buffer t "<OMS cd=\"linalg4\" name=\"rank\"/>~%"))
	(ROWCOUNT  (append-to-buffer t "<OMS cd=\"linalg4\" name=\"rowcount\"/>~%"))
	(SIZEMAT  (append-to-buffer t "<OMS cd=\"linalg4\" name=\"size\"/>~%"))

	($ADJOINT (append-to-buffer t "<OMS cd=\"linalg8\" name=\"adjoint\"/>~%"))
	($GRAMSCHMIDT (append-to-buffer t "<OMS cd=\"linalg8\" name=\"gramscmidt\"/>~%"))
	($INPROD (append-to-buffer t "<OMS cd=\"linalg8\" name=\"innerproduct\"/>~%"))
	($ECHELON (append-to-buffer t "<OMS cd=\"linalg8\" name=\"row_echelon\"/>~%"))
	($TRACE (append-to-buffer t "<OMS cd=\"linalg8\" name=\"trace\"/>~%"))
	($TRIANGULARIZE (append-to-buffer t "<OMS cd=\"linalg8\" name=\"triangularize\"/>~%"))
	($UVECT (append-to-buffer t "<OMS cd=\"linalg8\" name=\"unitvector\"/>~%"))

	($COLUMN (append-to-buffer t "<OMS cd=\"linalg9\" name=\"extract_column\"/>~%"))
	($ROW (append-to-buffer t "<OMS cd=\"linalg9\" name=\"extract_row\"/>~%"))
	($SUBMATRIX (append-to-buffer t "<OMS cd=\"linalg9\" name=\"submatrix\"/>~%"))

	(MAND (append-to-buffer t "<OMS cd=\"logic1\" name=\"and\"/>~%"))
	;;equivalent uses equal,implies is in not and or form
	(MNOT (append-to-buffer t "<OMS cd=\"logic1\" name=\"not\"/>~%"))
	(MOR (append-to-buffer t "<OMS cd=\"logic1\" name=\"or\"/>~%"))
	('T (append-to-buffer t "<OMS cd=\"logic1\" name=\"true\"/>~%"))
	($XOR (append-to-buffer t "<OMS cd=\"logic1\" name=\"xor\"/>~%"))
	('NIL (append-to-buffer t "<OMS cd=\"logic1\" name=\"false\"/>~%"))

	($MAX (append-to-buffer t "<OMS cd=\"minmax1\" name=\"max\"/>~%"))
	($MIN (append-to-buffer t "<OMS cd=\"minmax1\" name=\"min\"/>~%"))

	($%E (append-to-buffer t "<OMS cd=\"nums1\" name=\"e\"/>~%"))
	($%GAMMA (append-to-buffer t "<OMS cd=\"nums1\" name=\"gamma\"/>~%"))
	($%I (append-to-buffer t "<OMS cd=\"nums1\" name=\"i\"/>~%"))
	($%INF (append-to-buffer t "<OMS cd=\"nums1\" name=\"infinity\"/>~%"))
	($%PI (append-to-buffer t "<OMS cd=\"nums1\" name=\"pi\"/>~%"))
	($UND (append-to-buffer t "<OMS cd=\"nums1\" name=\"NaN\"/>~%"))
	(RAT (append-to-buffer t "<OMS cd=\"nums1\" name=\"rational\"/>~%"))

	(MEQUAL (append-to-buffer t "<OMS cd=\"relation1\" name=\"eq\"/>~%"))
	(MGEQP (append-to-buffer t "<OMS cd=\"relation1\" name=\"geq\"/>~%"))
	(MGREATERP (append-to-buffer t "<OMS cd=\"relation1\" name=\"gt\"/>~%"))
	(MLEQP (append-to-buffer t "<OMS cd=\"relation1\" name=\"leq\"/>~%"))
	(MLESSP (append-to-buffer t "<OMS cd=\"relation1\" name=\"lt\"/>~%"))
	(MNOTEQUAL (append-to-buffer t "<OMS cd=\"relation1\" name=\"neq\"/>~%"))

	($CEILING (append-to-buffer t "<OMS cd=\"rounding1\" name=\"ceiling\"/>~%"))
	($FLOOR (append-to-buffer t "<OMS cd=\"rounding1\" name=\"floor\"/>~%"))
	($ROUND (append-to-buffer t "<OMS cd=\"rounding1\" name=\"round\"/>~%"))
	($TRUNCATE (append-to-buffer t "<OMS cd=\"rounding1\" name=\"trunc\"/>~%"))

	($CARTESIAN_PRODUCT (append-to-buffer t "<OMS cd=\"set1\" name=\"cartesian_product\"/>~%"))
	
	($ELEMENTP (append-to-buffer t "<OMS cd=\"set1\" name=\"in\"/>~%"))
	($INTERSECT (append-to-buffer t "<OMS cd=\"set1\" name=\"intersect\"/>~%"))
	($SUBSETP (append-to-buffer t "<OMS cd=\"set1\" name=\"subset\"/>~%"))
	($SETDIFFERENCE (append-to-buffer t "<OMS cd=\"set1\" name=\"setdiff\"/>~%"))
	($CARDINALITY (append-to-buffer t "<OMS cd=\"set1\" name=\"cardinality\"/>~%"))
	($SUBSET (append-to-buffer t "<OMS cd=\"set1\" name=\"suchthat\"/>~%"))
	($UNION (append-to-buffer t "<OMS cd=\"set1\" name=\"union\"/>~%"))

	($COMPLEX (append-to-buffer t "<OMS cd=\"setname1\" name=\"complex\"/>~%"))
	($RATIONAL (append-to-buffer t "<OMS cd=\"setname1\" name=\"rational\"/>~%"))
	($REAL (append-to-buffer t "<OMS cd=\"setname1\" name=\"real\"/>~%"))
	($INTEGER (append-to-buffer t "<OMS cd=\"setname1\" name=\"integer\"/>~%"))
		
	(%ACOS (append-to-buffer t "<OMS cd=\"transc1\" name=\"arccos\"/>~%"))
	(%ACOSH (append-to-buffer t "<OMS cd=\"transc1\" name=\"arccosh\"/>~%"))	
	(%ACOT (append-to-buffer t "<OMS cd=\"transc1\" name=\"arccot\"/>~%"))
	(%ACOTH (append-to-buffer t "<OMS cd=\"transc1\" name=\"arccoth\"/>~%"))
	(%ACSC (append-to-buffer t "<OMS cd=\"transc1\" name=\"arccsc\"/>~%"))
	(%ACSCH (append-to-buffer t "<OMS cd=\"transc1\" name=\"arccsch\"/>~%"))	
	(%ASEC (append-to-buffer t "<OMS cd=\"transc1\" name=\"arcsec\"/>~%"))
	(%ASECH (append-to-buffer t "<OMS cd=\"transc1\" name=\"arcsech\"/>~%"))
	(%ASIN (append-to-buffer t "<OMS cd=\"transc1\" name=\"arcsin\"/>~%"))
	(%ASINH (append-to-buffer t "<OMS cd=\"transc1\" name=\"arcsinh\"/>~%"))
	(%ATAN (append-to-buffer t "<OMS cd=\"transc1\" name=\"arctan\"/>~%"))
	(%ATANH (append-to-buffer t "<OMS cd=\"transc1\" name=\"arctanh\"/>~%"))
	(%COS (append-to-buffer t "<OMS cd=\"transc1\" name=\"cos\"/>~%"))
	(%COSH (append-to-buffer t "<OMS cd=\"transc1\" name=\"cosh\"/>~%"))	
	(%COT (append-to-buffer t "<OMS cd=\"transc1\" name=\"cot\"/>~%"))
	(%COTH (append-to-buffer t "<OMS cd=\"transc1\" name=\"coth\"/>~%"))
	(%CSC (append-to-buffer t "<OMS cd=\"transc1\" name=\"csc\"/>~%"))
	(%CSCH (append-to-buffer t "<OMS cd=\"transc1\" name=\"csch\"/>~%"))	
	($EXP (append-to-buffer t "<OMS cd=\"transc1\" name=\"exp\"/>~%"))
	(%LOG (append-to-buffer t "<OMS cd=\"transc1\" name=\"ln\"/>~%"))	
	(%SEC (append-to-buffer t "<OMS cd=\"transc1\" name=\"sec\"/>~%"))
	(%SECH (append-to-buffer t "<OMS cd=\"transc1\" name=\"sech\"/>~%"))
	(%SIN (append-to-buffer t "<OMS cd=\"transc1\" name=\"sin\"/>~%"))
	(%SINH (append-to-buffer t "<OMS cd=\"transc1\" name=\"sinh\"/>~%"))
	(%TAN (append-to-buffer t "<OMS cd=\"transc1\" name=\"tan\"/>~%"))
	(%TANH (append-to-buffer t "<OMS cd=\"transc1\" name=\"tanh\"/>~%"))

	($TOTIENT (append-to-buffer t "<OMS cd=\"integer2\" name=\"euler\"/>~%"))	


	(otherwise (append-to-buffer t "unknown symbol"))
  )
)

;;convert a string into lower case, used to output variables in correct case
;;helper function for openmathOMV
(defun makesmall(str)
(map 'string #'(lambda (c) (char-downcase c)) str)
)

;;;;;;;;;;;;;;;;;
;;;openmathOMV;;;
;;;;;;;;;;;;;;;;;

;;input: maxima variables 
;;output: string representing the input variable as OMV object appended to 
;;	  output buffer.e.g $A to <OMV name="a"/> 
(defun openmathOMV(expr)
	(append-to-buffer t "<OMV name=\"")
	(let*(
		(my-string (string expr))
		(my-s-string (makesmall my-string))
		;;to remove the '$' which is in front of maxima variables
		(my-n-string (subseq my-s-string 1 (length my-s-string))))	
		(append-to-buffer t my-n-string))
	(append-to-buffer t "\"/>~%")		
	)
 
;;takes an expression written in maxima syntax and appends the string
;;representing the expression written in openmath to output buffer.
(defun openmath(expr)
   (cond ((integerp expr) 
		(openmathOMI expr))
        ((OMVp expr)  
		(openmathOMV expr))
	((symbolp expr)
		(openmathOMS expr))
	((floatp expr)
		(openmathOMF expr))
	
	((OMAhardp expr)
		(openmathOMAHd expr)	
	)
	((OMAp expr)
		(openmathOMA expr)	
	)
	((OMBINDp expr)
		(openmathOMBIND expr)	
	)
       (t (openmathOME (concatenate 'string "unsupported expression" 
		(write-to-string expr))))
  )
)

;;converts the string returned by openmath (expstring) into OPENMATH type
;;So expstring becomes ((OPENMATH SIMP) expstring).
(defun to_openmath(exp)
    (clear-output-buffer)
    (append-to-buffer t "<OMOBJ>~%")
    (openmath exp)
    (append-to-buffer t "</OMOBJ>~%")
    (list '(OPENMATH SIMP) (get-buffer-content))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; end maxima to OpenMath conversion ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun displa(exp) 
     (setq exp (caddr exp))   ;;; get rid of output label
     (cond
        ((OPENMATHSTRp exp) (format t (second exp)))
	(t (print exp))
     )
;;     (print 'OM-EXP)
 ;;    ($OM exp)
;;     (print 'END-EXP)
     (terpri)
)

;; filter is a function that returns all elements of the list <l> for which
;; the function <testfun> applied on <l> is true.
;;
;; it is written with tail recursion (lisp style)
;; because of all the maxima functions it is not clear if this code can be
;; improved for huge lists. It neccessary it probably can.
(defun filter (l testfun &optional (acc '((MLIST SIMP))))
  (if ($EMPTYP l)   ;; l=[] (set or list)
    (if ($SETP l)   ;; l is the empty set
      ($SETIFY acc) ;; return answer as a set
      acc           ;; return answer as a list
    )
    (if (funcall testfun ($FIRST l))
      (filter ($REST l) testfun ($ENDCONS ($FIRST l) acc)) ;; add first elt
      (filter ($REST l) testfun acc) ;; do not add first elemen();t
    )
  )
)
(defun findlist(n L)
  (if (eq ($first ($first L)) n)
    ($second ($first L))
    (findlist n ($rest L))	
  )
)

;; n-ary xor function that returns T if an odd number of arguments is true
;; and false otherwise
;; the val attribute is a carry (holds the result up til now)
(defun xor (l &optional (val nil))
  (if (not (cdr l)) ;; if (l = [])
    val
    (if ($FIRST l)
      (xor ($REST l) (not val))
      (xor ($REST l) val)
    )
  )
)    

;; surpress information printed by RAT
;;(setq $ratprint nil) 
(setq $RATPRINT nil)

;;(defmfun $asksign (expr) (merror "asksign called in service mode"));
;;(DEFMFUN $ASKSIGN (EXPR) (MERROR "asksign called in service mode"));
(defun asksignerror ($askexpr) (MERROR "asksign called in service mode"));

(defun ask (&rest x) (MERROR "asksign called in service mode"));

;; copy of asksign as in compar.lisp (version 5.10.0)
(defun asksign1 ($askexp)
  (let ($radexpand) (sign1 $askexp))
  (cond ((memq sign '($pos $neg $zero)) sign)
	((null odds)
	 (setq $askexp (lmul evens)
	       sign (cdr (assol $askexp locals)))
	 (do () (nil)
	   (cond ((zl-member sign '($zero |$Z| |$z| 0 0.0))
		  (tdzero $askexp) (setq sign '$zero) (return t))
		 ((memq sign '($pn $nonzero |$N| |$n| $nz $nonz $non0))
		  (tdpn $askexp) (setq sign '$pos) (return t))
		 ((memq sign '($pos |$P| |$p| $positive))
		  (tdpos $askexp) (setq sign '$pos) (return t))
		 ((memq sign '($neg |$N| |$n| $negative))
		  (tdneg $askexp) (setq sign '$pos) (return t)))
	   (setq sign (ask "Is  " $askexp "  zero or nonzero?")))
	 (if minus (flip sign) sign))
	(t (if minus (setq sign (flip sign)))
	   (setq $askexp (lmul (nconc odds (mapcar #'(lambda (l) (pow l 2))
						   evens))))
	   (do ((dom (cond ((eq '$pz sign) "  positive or zero?")
			   ((eq '$nz sign) "  negative or zero?")
			   ((eq '$pn sign) "  positive or negative?")
			   (t "  positive, negative, or zero?")))
		(ans (cdr (assol $askexp locals)))) (nil)
	     (cond ((and (memq ans '($pos |$P| |$p| $positive))
			 (memq sign '($pz $pn $pnz)))
		    (tdpos $askexp) (setq sign '$pos) (return t))
		   ((and (memq ans '($neg |$N| |$n| $negative))
			 (memq sign '($nz $pn $pnz)))
		    (tdneg $askexp) (setq sign '$neg) (return t))
		   ((and (zl-member ans '($zero |$Z| |$z| 0 0.0))
			 (memq sign '($pz $nz $pnz)))
		    (tdzero $askexp) (setq sign '$zero) (return t)))
	     (setq ans (ask "Is  " $askexp dom)))
	   (if minus (flip sign) sign))))




;;;;;; example usage

;;   (C1) loadfile("InitializeService.lisp");      
                                     
;;   InitializeService.lisp being loaded.          
;;   Loading InitializeService.lisp                
;;   Finished loading InitializeService.lisp       

(defun myfirst(expr)
  (listp (first expr))
)

;; force *print-circle* to nil

(setq *print-circle* nil)