
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : convert.scm
;; DESCRIPTION : Convert mathematical formulas to cas input
;; COPYRIGHT   : (C) 1999  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 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.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Main conversion routines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define current-cas-input-object "")

(define (convert-test)
  (set! current-cas-input-object (tree->object (the-selection)))
  (write (with-output-to-string cas-input-caller))
  (display "\n"))

(define (cas-math-input l)
  (set! current-cas-input-object (caddr l))
  (set! cas-input-current-cas (cadr l))
  (with-output-to-string cas-input-caller))

(define (cas-input-caller)
  (cas-input current-cas-input-object))

(define (cas-input t)
  (if (string? t)
      (cas-input-tmtokens (string->tmtokens t 0 (string-length t)))
      (let* ((f (car t)) (args (cdr t)) (im (cas-input-ref f)))
	(cond ((not (equal? im #f)) (im args))
	      (else (noop))))))

(define (cas-input-arg t)
  (if (and (string? t)
	   (= (length (string->tmtokens t 0 (string-length t))) 1))
      (cas-input t)
      (begin
	(display "(")
	(cas-input t)
	(display ")"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; conversion of strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (string-find-char s i n c)
  (cond ((>= i n) n)
	((equal? (string-ref s i) c) i)
	(else (string-find-char s (+ i 1) n c))))

(define (string-find-end s i n pred)
  (cond ((>= i n) n)
	((not (pred (string-ref s i))) i)
	(else (string-find-end s (+ i 1) n pred))))

(define (string->tmtokens s i n)
  (cond ((>= i n) '())
	((equal? (string-ref s i) #\<)
	 (let ((j (min n (+ (string-find-char s i n #\>) 1))))
	   (cons (substring s i j) (string->tmtokens s j n))))
	((char-alphabetic? (string-ref s i))
	 (let ((j (string-find-end s i n char-alphabetic?)))
	   (cons (substring s i j) (string->tmtokens s j n))))
	((char-numeric? (string-ref s i))
	 (let ((j (string-find-end s i n char-numeric?)))
	   (cons (substring s i j) (string->tmtokens s j n))))
	(else (cons (substring s i (+ 1 i))
		    (string->tmtokens s (+ 1 i) n)))))

(define (cas-input-tmtoken s)
  (let ((im (cas-input-ref s)))
    (if (equal? im #f)
	(if (and (not (equal? s "")) (equal? (string-ref s 0) #\<))
	    (display (substring s 1 (- (string-length s) 1)))
	    (display s))
	(display im))))

(define (cas-input-tmtokens l)
  (if (not (null? l))
      (begin
	(cas-input-tmtoken (car l))
	(cas-input-tmtokens (cdr l)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; conversion of other nodes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (cas-input-with args)
  (if (null? (cdr args))
      (cas-input (car args))
      (cas-input-with (cdr args))))

(define (cas-input-concat args)
  (if (not (null? args))
      (begin
	(cas-input (car args))
	(cas-input-concat (cdr args)))))

(define (cas-input-frac args)
  (display "(")
  (cas-input-arg (car args))
  (display "/")
  (cas-input-arg (cadr args))
  (display ")"))

(define (cas-input-sqrt args)
  (if (= (length args) 1)
      (begin
	(display "sqrt(")
	(cas-input (car args))
	(display ")"))
      (begin
	(cas-input-arg (car args))
	(display "^(1/")
	(cas-input-arg (cadr args))
	(display ")"))))

(define (cas-input-rsub args)
  (display "[")
  (cas-input (car args))
  (display "]"))

(define (cas-input-rsup args)
  (display "^")
  (cas-input-arg (car args)))

(define (cas-input-large args)
  (display (car args)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Conversion of matrices
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (cas-input-descend-last args)
  (if (null? (cdr args))
      (cas-input (car args))
      (cas-input-descend-last (cdr args))))

(define (cas-input-det args)
  (display "matdet(")
  (cas-input-descend-last args)
  (display ")"))

(define (rewrite-cell c)
  (if (and (list? c) (equal? (car c) 'cell)) (cadr c) c))

(define (rewrite-row r)
  (if (null? r) r (cons (rewrite-cell (car r)) (rewrite-row (cdr r)))))

(define (rewrite-table t)
  (if (null? t) t (cons (rewrite-row (cdar t)) (rewrite-table (cdr t)))))

(define (cas-input-row r)
  (if (null? (cdr r))
      (cas-input (car r))
      (begin
	(cas-input (car r))
	(display ", ")
	(cas-input-row (cdr r)))))

(define (cas-input-var-rows t)
  (if (not (null? t))
      (begin
	(display "; ")
	(cas-input-row (car t))
	(cas-input-var-rows (cdr t)))))

(define (cas-input-rows t)
  (display "[")
  (cas-input-row (car t))
  (cas-input-var-rows (cdr t))
  (display "]"))

(define (cas-input-table args)
  (let ((t (rewrite-table args)))
    (cas-input (cons 'rows t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization subroutines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define cas-input-current-cas "generic")

(define cas-input-methods (make-hash-table 1000))

(define (cas-input-set! key im)
  (hash-set!
   cas-input-methods
   (list cas-input-current-cas key)
   im))

(define (cas-input-ref-sub cas key)
  (hash-ref
   cas-input-methods
   (list cas key)))

(define (cas-input-ref key)
  (let ((im (cas-input-ref-sub cas-input-current-cas key)))
    (if (equal? im #f) (cas-input-ref-sub "generic" key) im)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(set! cas-input-current-cas "generic")
(cas-input-set! "<less>" "<less>")
(cas-input-set! "<gtr>" "<gtr>")
(cas-input-set! "<leq>" "<less>=")
(cas-input-set! "<geq>" "<gtr>=")
(cas-input-set! "<leqslant>" "<less>=")
(cas-input-set! "<geqslant>" "<gtr>=")
(cas-input-set! "<neq>" "!=")
(cas-input-set! "<neg>" "not ")
(cas-input-set! "<wedge>" " and ")
(cas-input-set! "<vee>" " or ")
(cas-input-set! "<ll>" "<less><less>")
(cas-input-set! "<gg>" "<gtr><gtr>")
(cas-input-set! "<assign>" ":=")

(cas-input-set! 'with cas-input-with)
(cas-input-set! 'concat cas-input-concat)
(cas-input-set! 'document cas-input-concat)
(cas-input-set! 'frac cas-input-frac)
(cas-input-set! 'sqrt cas-input-sqrt)
(cas-input-set! 'rsub cas-input-rsub)
(cas-input-set! 'rsup cas-input-rsup)
(cas-input-set! 'left cas-input-large)
(cas-input-set! 'middle cas-input-large)
(cas-input-set! 'right cas-input-large)
(cas-input-set! 'tabular cas-input-descend-last)
(cas-input-set! 'tabular* cas-input-descend-last)
(cas-input-set! 'block cas-input-descend-last)
(cas-input-set! 'block* cas-input-descend-last)
(cas-input-set! 'matrix cas-input-descend-last)
(cas-input-set! 'det cas-input-det)
(cas-input-set! 'tformat cas-input-descend-last)
(cas-input-set! 'table cas-input-table)
(cas-input-set! 'rows cas-input-rows)
(display "")
