From: ·······@abmx.rz.rwth-aachen.de
Subject: lisp <-> math
Date: Fri, 08 Apr 1994 12:44:08 +0000
Message-ID: <2o3jio$1hu@urmel.informatik.rwth-aachen.de> Does anybody know if there's any existing code for translating from
Lisp to mathematical notation and vice versa ?
e.g. (+ a b) -> "a + b"
Any kind and source of information is welcome.
Thanks, Nummi
----------------------
·······@rwth-aachen.de From: Hans-Martin Adorf
Subject: Re: lisp <-> math
Date: Fri, 08 Apr 1994 17:41:47 +0000
Message-ID: <adorf-080494184148@st53.hq.eso.org> In article <··········@urmel.informatik.rwth-aachen.de>,
·······@abmx.rz.rwth-aachen.de wrote:
>
>
> Does anybody know if there's any existing code for translating from
> Lisp to mathematical notation and vice versa ?
>
> e.g. (+ a b) -> "a + b"
>
> Any kind and source of information is welcome.
>
> Thanks, Nummi
> ----------------------
> ·······@rwth-aachen.de
There is definitively code around, e.g. look in Winston & Horn's Lisp book,
possibly not in the most recent edition, though.
Have a llok at the appended code, which I found on my disk from earlier
times.
--
Hans-Martin Adorf
ST-ECF/ESO
Karl-Schwarzschild-Str. 2
D-85748 Garching b. Muenchen
Germany
Tel: +49-89-32006-261
Fax: +49-89-32006-480
Internet: ·····@eso.org
========================= cut here ====================
;;;; -*- Package: CL-User; Mode: Lisp; Base: 10 -*-
;;;;
;;;;.IDENTIFICATION:
;;;; fortran-to-lisp.lisp
;;;;
;;;;.PURPOSE:
;;;; Processes a FORTRAN file towards LISP
;;;;
;;;;.REFERENCES:
;;;; Winston & Horn
;;;;
; (require "UTILITIES" "lispm:utilities;utilities.lisp")
;;;;------------------------------------------------------------------------
;;;; Global variables
;;;;------------------------------------------------------------------------
(defvar *unary-operators*
'((+ . +)
(- . -)
)
"Translation table for unary prefix operators.")
(defvar *special-operators*
'((/ 1 /)
(1+ 1 +)
(1- -1 +)
(-1+ -1 +)
)
"Translation table for special prefix operators.")
(defvar *binary-operators*
'((setq . =)
(psetq . =)
(let . =)
(let* . =)
(rem . rem)
(expt . ^)
)
"Translation table for binary prefix operators.")
(defvar *n-ary-operators*
'((+ . +)
(- . -)
(* . *)
(/ . /)
)
"Translation table for n-ary prefix operators.")
(defvar *functions*
'((sqrt . sqrt)
(square . square) ;Private
(exp . exp)
(sin . sin)
(cos . cos)
(tan . tan)
(sinh . sinh)
(cosh . cosh)
(tanh . tanh)
)
"Translation table for unary prefix operators.")
(defvar *fortran-operators*
'("+" "-" "*" "/" "="
".EQ." ".GT." ".LT." ".GE." ".LE."
"IF" "THEN" "ELSE" "ENDIF"))
(defvar *fortran-declarations*
'("REAL" "INTEGER" "COMPLEX" "DIMENSION" "IMPLICIT"))
;;;;------------------------------------------------------------------------
;;;; Interface to files.
;;;;------------------------------------------------------------------------
(defun process-fortran-file (input-file &optional (output-file nil))
(with-open-file (input-stream input-file :direction :input)
(if output-file
(with-open-file (output-stream output-file :direction :output
:if-exists :supersede)
(process-fortran-stream input-stream output-stream))
(process-fortran-stream input-stream t))))
#|
(process-fortran-file "lispm:utilities;mirpos.for"
"lispm:utilities;mirpos.out")
|#
(defun process-fortran-stream (input-stream &optional (output-stream t))
(let ((*readtable* (copy-readtable)))
(set-macro-characters) ; redefine dangerous characters
(process-fortran-strings input-stream output-stream)))
(defun process-fortran-text (text)
(let ((*readtable* (copy-readtable)))
(set-macro-characters) ; redefine dangerous characters
(with-input-from-string (input-stream text)
(process-fortran-strings input-stream t))))
(defun process-fortran-strings (input-stream output-stream &aux statement)
(loop
(cond ((setf statement (read-line input-stream nil nil))
;; (format t "~&~A" statement)
(format output-stream
"~A" (string-downcase
(process-fortran-statement statement))))
(t (return 'ok)))))
#|
(process-fortran-text
"dayl = 0.0
years = 0.0
iyear = 1990
rleap = 0.0
iend = 0")
|#
(defun process-fortran-statement (string)
(let ((fortran-list (read-from-string
(preprocess-fortran-statement string))))
(cond ((assignmentp fortran-list)
(process-fortran-assignment fortran-list))
((commentp fortran-list)
(process-fortran-comment fortran-list))
((declarationp fortran-list)
(process-fortran-other fortran-list))
(t (process-fortran-other fortran-list)))))
;; (process-fortran-statement "z=a+b")
;; (process-fortran-statement "C This is a test")
(defun declarationp (statement-list)
(member (first statement-list) *fortran-declarations*) :test
#'string-equal)
(defun assignmentp (statement-list)
(eq (second statement-list) '=))
(defun commentp (statement-list)
(eq (first statement-list) 'C))
(defun process-fortran-assignment (statement-list)
(format nil "~%~A" (inf-to-pre statement-list)))
;; (process-fortran-assignment '(z = a + b))
(defun process-fortran-comment (statement-list)
(format nil "~%;; ~{~A~^ ~}" (rest statement-list)))
;; (process-fortran-comment '(C This is a test.))
(defun process-fortran-other (statement-list)
(format nil "~%;; ~{~A~^ ~}" statement-list))
;;;-----------------------------------------------------------------------------
;;; String preprocessing.
;;;-----------------------------------------------------------------------------
(defun preprocess-fortran-statement (string)
(concatenate 'string
"("
(surround-operators-with-spaces
(substitute #\" #\' string))
")"))
;; (format t "~A" (preprocess-fortran-statement "a='This is a test.'"))
(defun surround-operators-with-spaces (string &optional (operators
*fortran-operators*))
(dolist (op operators string)
(setf string (surround-operator-with-spaces string op))))
;; (surround-operators-with-spaces "z=a+b*c")
(defun surround-operator-with-spaces
(string op &aux (pos 0) (op-length (length op)))
(loop
(if (setf pos (position op string :start pos :test #'string-equal))
(progn (setf string
(concatenate 'string (subseq string 0 pos) " " op " "
(subseq string (+ pos op-length))))
;; (print string)
(incf pos (+ op-length 1)))
(return string))))
;; (surround-operator-with-spaces "a+b+c" "+")
;;;-----------------------------------------------------------------------------
;;; Old interface to files.
;;;-----------------------------------------------------------------------------
(defun infix-formulae-to-file (input-file output-file)
(with-open-file (output-stream output-file :direction :output)
(mapcar #'(lambda (f)
(terpri)
(terpri)
(pprint f output-stream))
(infix-formulae-from-file input-file))))
;; (infix-formulae-to-file "hst-ea: calculators; imaging-etc.lisp" "hst-ea:
calculators; imaging-etc.doc")
;; (infix-formulae-to-file "hst-ea: calculators; spectroscopy-etc.lisp"
"hst-ea: calculators; spectroscopy-etc.doc")
(defun infix-formulae-from-file (input-file)
(with-open-file (input-stream input-file)
(infix-formulae-from-stream input-stream)))
;; (infix-formulae-from-file "hst-ea: calculators; imaging-etc.lisp")
(defun infix-formulae-from-stream (input-stream)
(flet ((defun-p (form)
(eq (first form) 'defun)))
(do ((form nil (read input-stream nil 'eof))
(inf nil (if (defun-p form) (pre-to-inf (get-formula (body form)))))
(formulae '()))
((eq form 'eof) (return (nreverse formulae)))
(when inf
(terpri) (terpri) (pprint inf)
(push inf formulae)))))
(defun body (form)
(body-aux (nthcdr 3 form)))
;; (body '(defun test (arg) (+ 1 2) (+ 3 4)))
(defun body-aux (form)
(flet ((declarationp (item)
(eq (first item) 'declare)))
(let ((item (first form)))
(if (or (atom item)
(stringp item)
(declarationp item))
(body-aux (rest form))
form))))
(defun get-formula (form)
(cond ((null form) nil)
((atom form) nil)
((eq (first form) 'values) (second form))
(t (or (get-formula (first form))
(get-formula (rest form))))))
;; (get-formula '(formula (/ a b)))
;;;------------------------------------------------------------------------
;;; INF-TO-PRE translates infix notation to prefix notation.
;;;------------------------------------------------------------------------
(defun inf-to-pre (ae)
(cond ((atom ae) ae) ;Easy case first
(t (inf-aux ae nil nil)))) ; else stacks empty.
;; (inf-to-pre '(z = 1 + 2))
(defun inf-aux (ae operators operands)
(inf-iter (cdr ae) ;Work on CDR after
operators
(cons (inf-to-pre (car ae)) operands))) ; recursion on CAR.
(defun inf-iter (ae operators operands)
(cond ((and (null ae) (null operators)) ;Finished?
(car operands))
((and (not (null ae))
(or (null operators)
(> (weight (car ae)) ;Compare weights of
(weight (car operators))))) ; operator & list head.
(inf-aux (cdr ae)
(cons (car ae) operators) ;Push operator
operands)) ; and continue.
(t (inf-iter ae
(cdr operators) ;Pop operator,
(cons (list (opcode (car operators))
(cadr operands)
(car operands))
(cddr operands)))))) ; and pop operands.
(defun weight (operator) ;determine weights
(cond ((equal operator '=) 0)
((equal operator '+) 1)
((equal operator '-) 1)
((equal operator '*) 2)
((equal operator '/) 2)
((equal operator '\\) 2)
((equal operator '^) 3)
(t (print `(,operator is not an operator)) 4)))
(defun opcode (operator) ;Get LISP primitive.
(cond ((equal operator '=) 'setq)
((equal operator '+) '+)
((equal operator '-) '-)
((equal operator '*) '*)
((equal operator '/) '/)
((equal operator '\\) 'reminder)
((equal operator '^) 'expt)
(t (print `(,operator is not an operator)) operator)))
;;;;------------------------------------------------------------------------
;;;; PRE-TO-INF
;;;;------------------------------------------------------------------------
(defmacro pre-to-inf* (ae)
`(pre-to-inf ',ae))
;; (pre-to-inf* (+ 1 2))
(defun pre-to-inf (ae)
"Translate prefix notation to infix notation."
(cond ((null ae) nil) ;Easy case first
((variable-p ae) ae) ;Easy case first
((and (listp ae) (= (length ae) 1) (pre-to-inf (first ae))))
((setq-p ae) (pre-to-inf-setq ae))
((let-p ae) (pre-to-inf-let ae))
((unary-p ae) (pre-to-inf-unary ae))
((special-p ae) (pre-to-inf-special ae))
((binary-p ae) (pre-to-inf-binary ae))
((n-ary-p ae) (pre-to-inf-n-ary ae))
(t (pre-to-inf-function ae))
))
#|
(pre-to-inf '(- 1 (+ 2 3) 4 5 6))
(pre-to-inf '(+ (sin (+ x y)) 1))
(pre-to-inf '(sin (+ x y)))
(pre-to-inf '(1+ 2))
(pre-to-inf '(1- 2))
(pre-to-inf '(expt 10 5))
(pre-to-inf '(square 2))
(pre-to-inf '(/ (* (square SNR) (+ RS (* RB (1+ (/ area-ratio))))) (square
RS)))
(pre-to-inf '(setq v1 (+ 1 2) v2 (* 3 4)))
|#
(defun pre-to-inf-unary (ae)
(cons (unop (operator ae)) (list (pre-to-inf (first-arg ae)))))
;; (pre-to-inf-unary '(- (* x y)))
(defun pre-to-inf-special (ae)
(append (unop (operator ae)) (list (pre-to-inf (first-arg ae)))))
;; (pre-to-inf-special '(/ 2)
;; (pre-to-inf-special '(1+ 2))
(defun pre-to-inf-binary (ae)
(append (list (pre-to-inf (first-arg ae)))
(list (binop (operator ae)))
(list (pre-to-inf (second-arg ae)))))
;; (pre-to-inf-binary '(+ a b))
(defun pre-to-inf-n-ary (ae)
(let ((op (n-op (operator ae))))
(cons (pre-to-inf (first-arg ae))
(mapcan #'(lambda (x) (cons op (list (pre-to-inf x))))
(further-args ae)))))
;; (pre-to-inf-n-ary '(- a b (* c d)))
(defun pre-to-inf-function (ae)
(let ((arg (pre-to-inf (first-arg ae))))
(cons (fn (operator ae))
(if (listp arg)
(list arg)
(list (list arg))))))
;; (pre-to-inf-function '(sin x))
;; (pre-to-inf-function '(sin (+ x y)))
(defun pre-to-inf-setq (ae)
(let ((op (binop (operator ae))))
(map-subseq 2 #'(lambda (var expr)
(let ((expr (pre-to-inf expr)))
(append (list var)
(list op)
(if (listp expr) expr (list expr)))))
(arguments ae))))
;; (pre-to-inf-setq '(setq v1 (+ a b) v2 (* c d) v3 (/ e f)))
(defun pre-to-inf-let (ae)
(append
(let ((op (binop (operator ae))))
(mapcar #'(lambda (pair)
(let ((expr (pre-to-inf (second pair))))
(append (list (first pair) op)
(if (listp expr) expr (list expr)))))
(second ae)))
(pre-to-inf (nthcdr 2 ae))))
;; (pre-to-inf-let '(let ((v1 (+ a b)) (v2 e2)) (setq test (+ v1 v2))))
;;; Predicates
(defun variable-p (ae)
(atom ae))
(defun unary-p (ae)
(and (= (length ae) 2)
(member (operand ae) *unary-operators* :key #'car)))
(defun special-p (ae)
(and (= (length ae) 2)
(member (operand ae) *special-operators* :key #'car)))
(defun binary-p (ae)
(and (= (length ae) 3)
(member (operand ae) *binary-operators* :key #'car)))
(defun n-ary-p (ae)
(member (operand ae) *n-ary-operators* :key #'car))
(defun function-p (ae)
(and (= (length ae) 2)
(member (operand ae) *functions* :key #'car)))
(defun setq-p (ae)
(member (operand ae) '(setq psetq)))
(defun let-p (ae)
(member (operand ae) '(let let*)))
;;; Accessor functions
(defun operand (ae)
(operator ae))
(defun operator (ae) (car ae))
(defun first-arg (ae) (cadr ae))
(defun second-arg (ae) (caddr ae))
(defun further-args (ae) (nthcdr 2 ae))
(defun arguments (ae) (rest ae))
;;; Translations
(defun unop (op) (or (rest (assoc op *unary-operators*))
(rest (assoc op *special-operators*))
op))
(defun binop (op) (or (rest (assoc op *binary-operators*)) op))
(defun n-op (op) (or (rest (assoc op *n-ary-operators*)) op))
(defun fn (op) (or (rest (assoc op *functions*)) op))
;;; Almost original code
#|
(defun pre-to-inf (ae)
(cond ((null ae) nil) ;Easy case first
((atom ae) ae) ;Easy case first
(t (list (pre-to-inf (cadr ae)) ;Translate part
(opsymbol (car ae)) ;Look up symbol
(pre-to-inf (caddr ae))))))
(defun opsymbol (x) ;Get symbol.
(case x
(setq '=)
(+ '+)
(- '-)
(* '*)
(/ '/)
('reminder '\\)
(expt '^)
(t x)))
|#
;;;;------------------------------------------------------------------------
;;;; Tools
;;;;------------------------------------------------------------------------
(defmacro do-forms ((form input-file &optional result-form) &body body)
(let ((input-stream (gensym)))
`(with-open-file (,input-stream ,input-file :direction :input)
(do ((,form nil (read ,input-stream nil 'eof)))
((eq ,form 'eof) ,result-form)
,@body))))
;; (do-forms (form "lispm:calculators;imaging-etc.lisp") (print form))
(defun map-subseq (n function sequence)
"A mapcar which jumps in steps of n over the given sequence feeding the
function with n items at a time."
(let ((i-lim (* (floor (length sequence) n) n))
(funcall-apply (if (stringp sequence) #'funcall #'apply)))
(do ((i 0 (+ i n))
(seq sequence (subseq seq n))
(result '() (cons (apply funcall-apply (list function (subseq seq 0 n)))
result)))
((>= i i-lim) (nreverse result))
;; (format t "~%~a" seq)
)))
;; (map-subseq 2 #'list '(a 1 b 2 c 3))
;; (map-subseq 2 #'identity "aAbBcC")