;;;	Copyright (c) 1989, 1990 by Aubrey Jaffer, All rights reserved.

;;;; careful write for displaying internal stuff
(define (math_write obj)
  (cond ((pair? obj)
	 (display #\()
	 (math_write (car obj))
	 (cond ((null? obj))
	       ((pair? (cdr obj))
		(for-each (lambda (x) (display #\ ) (math_write x))
			  (cdr obj)))
	       (else (display " . ")
		     (math_write (cdr obj))))
	 (display #\)))
	((poly_var? obj)
	 (display (var->string obj)))
	(else (write obj)))
  obj)
(define (warning . args)
  (display ";;;")
  (let ((ans ()))
    (for-each (lambda (obj)
		(write-char #\space)
		(if (string? obj)
		    (display obj)
		    (set! ans (math_write obj))))
	      args)
    (newline)
    ans))
(define (math-error . args)
  (newline)
  (apply warning args)
  (if math_debug (error "") (math_exit #f)))
(define (eval-error . args)
  (newline)
  (apply warning args)
  (if math_debug (error "") (math_exit #f)))
(define (clear-input)
  (do ((c (read-char) (read-char)))
      ((char=? #\linefeed c))))
(define (cgol_error . args)
  (display (make-string cgol_column #\space))
  (display #\^)
  (apply warning args)
  (clear-input)
  (math_exit #f))
(define scheme-grammer
  (list 'scheme-grammer
	#f
	(lambda (sexp grm) (write sexp))
	(lambda (grm) (read))))
(define (test ans fun . args)
  (let ((res (apply fun args)))
    (if (equal? ans res) #t (warning "trouble with " fun))))

;;; our local environments
(define (aput! key val alst)
  (let ((p (assq key alst)))
    (cond (p (set-cdr! p val) alst)
	  (else (cons (cons key val) alst)))))
(define (arem! key alst) (aput! key #f alst))
(define symdefs '())
(define (defsym sym value) (set! symdefs (aput! sym value symdefs)) value)
(define (undefsym sym)
  (set! symdefs (arem! sym symdefs))
  (var->expl (symbol->var sym)))
(define (symdef sym)
  (let ((p (assq sym symdefs)))
    (if p
	(cdr p)
      (eval-error "Undefined variable: " sym))))
(define opdefs '())
(define (defop op value) (set! opdefs (aput! op value opdefs)) value)
(define (opdef op) (let ((p (assq op opdefs))) (and p (cdr p))))
(define infodefs '())
(define (definfo sym info) (set! infodefs (aput! sym info infodefs)) sym)
(define (infodef sym)
  (let ((p (assq sym infodefs)))
    (and p (cdr p))))
(define (defbltn sym val . info)
  (defop sym val)
  (definfo sym info))

;;; hdns here is a list of lexically bound symbols as in lambda or suchthat.
;;; so it is really a list of things not to look up.
(define (symdef? sym hdns)
  (cond ((null? hdns)
	 (let ((p (assq sym symdefs)))
	   (if p (cdr p) #f)))
	((eq? sym (car hdns)) #f)
	((symbol? (car hdns)) (symdef? sym (cdr hdns)))
	((memq sym (car hdns)) #f)
	(else (symdef? sym (cdr hdns)))))

;;;now for the read-eval-print stuff
(define var-news '())
(define (read-sexp grm) (funcall (cadddr grm) grm))
(define (write-sexp sexp grm) (funcall (caddr grm) sexp grm))
(define (math)
  (display "type ")
  (write-sexp '(qed) *input-grammer*)
  (display " to return to ")
  (display base-language)
  (do ((newlabel (new-symbol (string-standard-case "E"))
		 (new-symbol (string-standard-case "E")))
       (math_exit-saved math_exit)
       (math_prompt #f)
       (obj #f))
      ((call/cc
	(lambda (math_exit-cnt)
	  (set! math_exit math_exit-cnt)
	  (newline)
	  (set! var-news '())
	  (set! math_prompt (string-append (symbol->string newlabel) " : "))
	  (display math_prompt)
	  (set! cgol_column (string-length math_prompt))
	  (set! obj (read-sexp *input-grammer*))
	  (defsym '% (sexp->math (list 'define newlabel obj)))
	  (set! cgol_column (string-length math_prompt))
	  (write-sexp (list 'define
			    newlabel
			    (math->sexp (symdef '%)))
		      *output-grammer*)
	  (map (lambda (x)
		 (newline)
		 (write-sexp (list 'define
				   (var->symbol x)
				   (math->sexp (vsubst @ x (extrule x))))
			     *output-grammer*))
	       var-news)
	  #f))
       (set! math_exit math_exit-saved)
       base-language)))

(define (clambda symlist body)
  (polys_do-vars
   (lambda (var)
     (let ((pos (position (var_nodiffs var) symlist)))
       (if pos
	   (lambda-var (+ 1 pos)
		       (var_diff-depth var)
		       (var_fdiff-depth var))
	 var)))
   body))

(define (clambda? cexp)
  (cond ((number? cexp) #f)
	((bunch? cexp) (some clambda? cexp))
	((expr? cexp) (poly_find-var-if? cexp lambdavar?))
	((eqn? cexp) (poly_find-var-if? (eqn->poly cexp) lambdavar?))
	(else #f)))

;;;In order to keep the lambda application hygenic (in case a function
;;;of a function is called), we need to substitute occurences of
;;;lambda variables in the body with shadowed versions of the
;;;variables before we eliminate them.  See:
;;;	Technical Report No. 194
;;;	Hygenic Macro Expansion
;;;	E.E.Kohlbecker, D.P.Friedman, M.Fellinson, and B.Duba
;;;	Indiana University
;;;	May, 1986

;;;currently capply puts the structure of the clambda inside the
;;;structure of the arguments.
(define (capply body arglist)
  (set! arglist (licits->poleqns arglist))
  (let ((sbody 0) (svlist '()) (dargs '()) (arglist-length (length arglist)))
    (set! sbody
	  (poleqns_do-vars
	   (lambda (var)
	     (if (lambdavar? var)
		 (let ((lshf (- (lambda-position var) arglist-length)))
		   (cond ((< 0 lshf) (lambda-var lshf
						 (var_diff-depth var)
						 (var_fdiff-depth var)))
			 (else (set! var (var_shadow var))
			       (set! svlist (adjoin var svlist))
			       var)))
	       var))
	   body))
    (set! dargs (diffargs svlist arglist))
    (set! sbody (bunch_map (lambda (p) (eliminate (cons p dargs) svlist))
			   sbody))
    (if (eqns? body) (polys->eqns sbody) sbody)))
(define (diffargs vlist args)
	  (map (lambda (var)
		 (bunch_map (lambda (e)
			      (univ_demote (cons var (cdr (licit->poleqn e)))))
			    (diffarg var args)))
	       vlist))
(define (diffarg var args)
  (cond ((var_differential? var)
	 (total-differential (diffarg (var_undiff var) args)))
	((var_finite-differential? var)
	 (total-finite-differential (diffarg (var_unfdiff var) args)))
	(else (list-ref args (- (lambda-position var) 1)))))
;;; @=fc(@1) --> @=fc^^-1(@1)
(define (fcinverse fc)
  (extize (normalize
	   (cons @ (vsubst @1 @ (cdr (promote @1 (licit->poleqn fc))))))))
;;; fc(fc(...fc(@1)))
(define (fcexpt fc pow)
  (if (negative? pow)
      (fcexpt (fcinverse fc) (- pow))
    (ipow-by-squaring fc pow cidentity app*)))

(define (rapply ob . arglist)
  (cond ((null? arglist) ob)
	((bunch? ob)
	 (apply rapply
		(list-ref ob (+ -1 (integer (car arglist))))
		(cdr arglist)))
	(else #f)))

(define (sapply fun args)
  (cond ((procedure? fun) (apply fun args))
	((clambda? fun)
	 (cond (math_trace
		(newline)
		(write-sexp (math->sexp fun) *output-grammer*)
		(newline)
		(display "applied to:")
		(map (lambda (x)
		       (newline)
		       (write-sexp (math->sexp x) *output-grammer*))
		     args)
		(newline)
		(display "yielding:")
		(newline)
		(let ((ans (capply fun args)))
		  (write-sexp (math->sexp ans) *output-grammer*)
		  (newline)
		  ans))
	       (else (capply fun args))))
	(else (eval-error "wrong type to apply: " fun))))

(define (app* fun . args) (sapply fun args))

(define (seval f hdns)
  (cond ((number? f)
	 (if (inexact? f) (eval-error "Inexact number to eval: "))
  	 (cond ((integer? f) f)
  	       ((rational? f) (make-rat (numerator f) (denominator f)))))
	((vector? f)
	 (do ((i (+ -1 (vector-length f)) (+ -1 i))
	      (b '() (cons (seval (vector-ref f i) hdns) b)))
	     ((< i 0) b)))
	((symbol? f)
	 (if (symdef? f hdns) (symdef f) (var->expl (symbol->var f))))
	((null? f) f)
	((not (pair? f)) (eval-error "Wrong type to eval: " f))
	((eqv? (car f) 'lambda)
	 (let ((vars (variables
		      (cond ((symbol? (cadr f)) (list (cadr f)))
			    ((vector? (cadr f)) (vector->list (cadr f)))
			    ((pair? (cadr f)) (cadr f))
			    (else (eval-error "Bad arglist in lambda: " f))))))
	   (clambda vars (seval (caddr f) (cons vars hdns)))))
	((eqv? (car f) 'suchthat)
	 (suchthat (symbol->var (cadr f))
		   (seval (caddr f) (cons (cadr f) hdns))))
	((eqv? (car f) 'define)
	 (cond ((symbol? (cadr f))
		(if (eq? (cadr f) (caddr f))
		    (undefsym (cadr f))
		  (defsym (cadr f)
		    (normalize (seval (caddr f) (cons (cadr f) hdns))))))
	       ((eqv? (caadr f) 'rapply)
		(defsym (cadadr f)
		  (rlambda (cddadr f)
			   (normalize (seval (caddr f)
					     (cons (cdadr f) hdns))))))
	       (else			;must be capply
		(defsym (caadr f)
		  (clambda (variables (cdadr f))
			   (normalize (seval (caddr f)
					     (cons (cadr f) hdns))))))))
	((opdef (car f))
	 (sapply (opdef (car f))
		 (map (lambda (x) (seval x hdns)) (cdr f))))
	(else (sapply (seval (car f) hdns)
		      (map (lambda (x) (seval x hdns)) (cdr f))))))
(define (sexp->math f) (seval f '()))

;;; These routines convert LICITs or parts of LICITs to S-EXPRESSIONs
(define (leading+? exp)
  (cond ((number? exp) (positive? exp))
	((symbol? exp) #t)
	((eq? '+/- (car exp)) #f)
	((eq? '+ (car exp)) #t)
	((eq? '* (car exp)) (leading+? (cadr exp)))
	(else #t)))

(define (cmprs_+ res)
  (cond ((null? (cdr res)) (car res))
	((and (pair? (car res))
	      (eq? '+ (caar res)))
	 (nconc (car res) (cdr res)))
	(else (cons '+ res))))

(define (cmprs_* mu mex)
  (cond ((and (pair? mu) (eq? '* (car mu))) (nconc mu (list mex)) mu)
	(else (list '* mu mex))))

(define (cmprs_^ var exp)
  (cond ((one? exp) var)
	((and (pair? var)
	      (eq? '^ (car var)))
	 (list '^
	       (cadr var)
	       (list '/ exp (caddr (caddr var)))))
	(else (list '^ var exp))))

;POLY->SEXP converts a polynomial to SEXPRESSION.
(define (poly->sexp p)
  (if (number? p)
      p
    (let ((var (radicalvar? (car p))))
      (cmprs_+ (coes->sexp (if var
			       (list '^
				     (poly->sexp (rat_num var))
				     (list '/ 1 (length (cddr var))))
			     (var->symbol (car p)))
			   0
			   (cdr p))))))
(define (coes->sexp var exp colist)
  (cond ((null? colist) colist)
	((eqv? 0 (car colist)) (coes->sexp var (+ 1 exp) (cdr colist)))
	((zero? exp) (cons (poly->sexp (car colist))
			   (coes->sexp var (+ 1 exp) (cdr colist))))
	((eqv? 1 (car colist))
	 (cons (cmprs_^ var exp) (coes->sexp var (+ 1 exp) (cdr colist))))
	(else
	 (cons (cmprs_* (poly->sexp (car colist)) (cmprs_^ var exp))
	       (coes->sexp var (+ 1 exp) (cdr colist))))))
;RAT->SEXP converts a rational polynomial to SEXPRESSION.
(define (rat->sexp n d)
  (if (unit? d)
      (poly->sexp (poly_* n d))
    (list '/ (poly->sexp n) (poly->sexp d))))

(define (impl_radical? p) (one? (length (or (memv 0 (cddr p)) '()))))
;;;IMPOLY->SEXP converts an implicit polynomial to SEXPRESSION.
(define (impoly->sexp p)
  (if (impl_radical? p)
      (list '=
	    (if (null? (cdddr p))
		(var->symbol (car p))
	      (list '^ (var->symbol (car p)) (length (cddr p))))
	    (rat->sexp (cadr p) (car (last-pair p))))
    (list '= 0 (poly->sexp p))))

;;;IRIMPL->SEXP converts an irreducible implicit expression to SEXPRESSION.
(define (irimpl->sexp p)
  (let ((dgr (poly_degree p @)))
    (cond ((zero? dgr) (warning "not canonical " p) p)
	  ((one? dgr) (rat->sexp (rat_num p) (rat_denom p)))
	  (else (list 'suchthat (var->symbol (car p)) (impoly->sexp p))))))

(define (bunch->sexp p)
  (cond ((bunch? p) (list->vector (map bunch->sexp p)))	;inefficient
	((symbol? p) p)
	((expl? p) (poly->sexp p))
	((impl? p)
	 (let ((dgr (poly_degree p @)))
	   (cond ((zero? dgr) (warning "not canonical " p) p)
		 ((one? dgr) (rat->sexp (rat_num p) (rat_denom p)))
		 (else (cons 'or (map irimpl->sexp (univ_split-all p)))))))
	((eqn? p) (list '= 0 (poly->sexp (eqn->poly p))))
	(else (eval-error "unknown type to display " p))))

(define (highest-lambda-var polys)
  (let ((maxpos 0) (deps '()))
    (polys_for-each-var
     (lambda (v) (if (lambdavar? v)
		     (if (extrule v)
			 (set! deps (adjoin v deps))
		       (set! maxpos (max maxpos (lambda-position v))))))
     polys)
    (for-each
     (lambda (v)
       (for-each
	(lambda (x) (if (lambdavar? x)
			(set! maxpos (max maxpos (lambda-position x)))))
	(var_dependencies v)))
     deps)
    maxpos))
(define (get-lambda-list poly)
  (do ((j (highest-lambda-var poly) (+ -1 j))
       (ll '()
	   (cons (string->symbol (string-append "@" (number->string j))) ll)))
      ((< j 1) ll)))

;;;MATH->SEXP converts expressions or equations to SEXPRESSIONS. 
(define (math->sexp p)
  (if (clambda? p)
      (list 'clambda (list->vector (get-lambda-list p)) (bunch->sexp p))
      (bunch->sexp p)))

;;;	Copyright (c) 1989, 1990 by Aubrey Jaffer, All rights reserved.
