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

;;; Scheme doesn't allow for definition of new types which are
;;; distinct from existing types.  So we will carefully use BUNCH
;;; instead of LIST in order to distinguish the types. 
;;; This requires that boolean?, pair?, symbol?, number?,
;;; string?, vector? and procedure? be disjoint as outlined in:
;;; Jonathan Rees and William Clinger, editors. The Revised^3
;;; Report on the algorithmic language Scheme.  In ACM SIGPLAN Notices
;;; 21(12), ACM, December 1986.
;;; If the types are not disjoint you WILL lose.

;;;; But first, what case are symbols in?  Determine the standard case:
(define char-standard-case
  (cond ((not (string=? (symbol->string 'a) (symbol->string 'A)))
	 (display ";;; symbol casing not standard")
	 (error ""))
	((string=? (symbol->string 'a) "A")
	 char-upcase)
	((string=? (symbol->string 'A) "a")
	 char-downcase)
	(else
	 (display ";;; symbol casing not standard")
	 (error ""))))
(define (string-standard-case s)
  (do ((i 0 (+ 1 i))
       (sl (string-length s)))
      ((>= i sl) s)
      (string-set! s i (char-standard-case (string-ref s i)))))
;;; We also define proc so that scl.lisp will correctly funcallize it.
(define proc 'proc)
;;; The following types are mutually exclusive:
;;; SEXP, VARIABLE, EXPL, IMPL, EQLT, BUNCH
;;; INTEGERs are EXPL
;;; An EXPR is an EXPL or IMPL
;;; A LICIT is an EXPL, IMPL, or EQLT.
;;; VARIBLEs can only occur as part of EXPRS and EQLTS.
;;; SYMBOLs can only occur in SEXP.
;;; BUNCHES can contain SYMBOLs, LICITs, and BUNCHEs.
;;; An EXPL, IMPL, or EQLT, or BUNCH of these can be a
;;; lambda expression. 

;;; A VAR is a vector which consists of:
;;; 0 var_base		- string or var	;lambda vars have leading "@"
;;; 1 var_diff-depth	- interger	;differential depth
;;; 2 var_fdiff-depth	- integer	;finite differential depth
;;; 3 var_pri 		- integer	;ordering priority
;;; 4 var_def		- poleq		;ext defining equation
;;;		     or	- integer	;lambda position
;;; 5 var_dependencies	- list of vars	;vars used in var_def

(define poly_var? vector?)
(define (var_base v) (vector-ref v 0))
(define (var_nodiffs v) (let ((s (var_base v))) (if (string? s) v s)))
(define (var_base-string v)
  (let ((s (var_base v))) (if (string? s) s (var_base s))))
(define (var_diff-depth v) (vector-ref v 1))
(define (var_fdiff-depth v) (vector-ref v 2))
(define (var_pri v) (vector-ref v 3))
(define (var_set-pri! v i) (vector-set! v 3 i) v)
(define (var_def v) (vector-ref v 4))
(define (var_set-def! v i) (vector-set! v 4 i) v)
(define (var_dependencies v) (vector-ref v 5))
(define (var_set-dependencies! v i) (vector-set! v 5 i) v)

(define (nonzero? i) (if (zero? i) #f i))
(define (var_< v1 v2)
  (let ((d (or (nonzero? (- (var_pri v1) (var_pri v2)))
	       (let ((vr1 (var_base-string v1)) (vr2 (var_base-string v2)))
		 (cond ((eq? vr1 vr2) #f)
		       ((string<? vr1 vr2) -1)
		       (else 1)))
	       (nonzero? (- (var_fdiff-depth v1) (var_fdiff-depth v2)))
	       (nonzero? (- (var_diff-depth v1) (var_diff-depth v2))))))
    (and d (< d 0))))
(define (var_> v1 v2) (var_< v2 v1))
(define (lex_term_< p1 p2) (var_< (car p1) (car p2)))

;;; var-buckets is a list of lists of all differentials of each var.
;;; the first var in each bucket is not a differential (or finite
;;; differential).  In the first position this var has a string.  All
;;; subsequent vars have this var in the base position.
(define var-buckets '())
(define (find-diff-bucket? v)
  (let ((s (if (string? v) v (var_base-string v))))
    (find-if (lambda (vb) (string=? (var_base (car vb)) s))
	     var-buckets)))
(define (find-var s diffs fdiffs)
  (let ((b (find-diff-bucket? s)))
    (and b (find-if (lambda (v)
		      (and (= (var_diff-depth v) diffs)
			   (= (var_fdiff-depth v) fdiffs)))
		    b))))
(define (make-var v diffs fdiffs)
  (let* ((s (if (string? v) v (var_base-string v)))
	 (sl (string-length s)))
    (vector v
	    diffs
	    fdiffs
	    (if (= sl 1)
		(* 100 (char->integer (string-ref s 0)))
	      (let ((fv (find-var (substring s 0 1) 0 0)))
		(if fv
		    (var_pri fv)
		  (* 100 (char->integer (string-ref s 0))))))
	    (if (and (char=? #\@ (string-ref s 0))
		     (not (= sl 1))
		     (not (char=? #\^ (string-ref s 1))))
		(string->number (substring s 1 sl))
	      #f)
	    #f)))
(define (add-to-bucket v b) (set-cdr! b (cons v (cdr b))) v)
(define (intern-var s diffs fdiffs)
  (let ((b (find-diff-bucket? s)))
    (cond (b (or (find-if (lambda (v) (and (= (var_diff-depth v) diffs)
					   (= (var_fdiff-depth v) fdiffs)))
			  b)
		 (add-to-bucket (make-var (car b) diffs fdiffs) b)))
	  (else (set! b (list (make-var s 0 0)))
		(set! var-buckets (cons b var-buckets))
		(if (or (nonzero? diffs) (nonzero? fdiffs))
		    (add-to-bucket (make-var (car b) diffs fdiffs) b)
		  (car b))))))
(define (string->var s)
  (let ((diffs 0) (fdiffs 0))
    (intern-var (substring s 0 (do ((i (+ -1 (string-length s)) (+ -1 i)))
				   ((cond ((char=? #\' (string-ref s i))
					   (set! diffs (+ 1 diffs))
					   #f)
					  ((char=? #\_ (string-ref s i))
					   (set! fdiffs (+ 1 fdiffs))
					   #f)
					  (else #t))
				    (+ 1 i))))
		diffs
		fdiffs)))
;;; This checks for unshadowing :@
(define (var->string v)
  (let ((s (var_base-string v)))
    (string-append (if (char=? #\: (string-ref s 0))
			(substring s 1 (string-length s))
		      s)
		   (make-string (var_diff-depth v) #\')
		   (make-string (var_fdiff-depth v) #\_))))
(define (var->symbol v) (string->symbol (var->string v)))
(define (symbol->var s) (string->var (symbol->string s)))
(define var_new-counter 0)
(define (new-symbol prefix)
  (set! var_new-counter (+ 1 var_new-counter))
  (string->symbol (string-append prefix
				 (number->string var_new-counter))))
(define (newvar prefix) (symbol->var (new-symbol prefix)))
(define (make-subscripted-var v . indices)
  (string->var
   (apply string-append (var->string v)
	  (map (lambda (i) (string-append "_" (number->string i)))
	       indices))))

(define (var_differential? v) (> (var_diff-depth v) 0))
(define (var_finite-differential? v) (> (var_fdiff-depth v) 0))
(define (var_differential v)
  (intern-var (var_nodiffs v) (+ 1 (var_diff-depth v)) (var_fdiff-depth v)))
(define (var_finite-differential v)
  (intern-var (var_nodiffs v) (var_diff-depth v) (+ 1 (var_fdiff-depth v))))
(define (var_undiff v)
  (intern-var (var_nodiffs v) (+ -1 (var_diff-depth v)) (var_fdiff-depth v)))
(define (var_unfdiff v)
  (intern-var (var_nodiffs v) (var_diff-depth v) (+ -1 (var_fdiff-depth v))))

(define (lambdavar? v)
  (char=? #\@ (string-ref (var_base-string v) 0)))
(define (lambda-var i diff-depth fdiff-depth)
  (var_set-def! (intern-var (string-append "@" (number->string i))
			    diff-depth
			    fdiff-depth)
		i))
;;; This sometimes is called with shadowed variables (:@4)
(define lambda-position var_def)
(define (var_shadow v)
  (var_set-def! (intern-var (string-append ":" (var_base-string v))
			    (var_diff-depth v)
			    (var_fdiff-depth v))
		(var_def v)))

(define (radicalvar? v)
  (or (and (char=? #\^ (string-ref (var_base-string v) 0))
	   (var_def v))
      (and (lambdavar? v)
	   (char=? #\^ (string-ref (var_base-string v) 1))
	   (var_def v))))
(define (extrule e) (and (pair? (var_def e)) (var_def e)))
(define (defext var impl)
  (let ((fees '()) (deps '()))
    (poly_for-each-var
     (lambda (v) (if (not (@? v)) (if (extrule v)
				      (set! fees (adjoin v fees))
				    (set! deps (adjoin v deps)))))
     impl)
    (for-each (lambda (fee) (set! deps (union (var_dependencies fee) deps)))
	      fees)
    (var_set-dependencies! var deps)
    (set! fees (nconc fees deps))
    (var_set-pri! var (max (* 100 char-code-limit)
			   (if (null? fees)
			       0
			     (+ 1 (apply max (map var_pri fees))))))
    (var_set-def! var (vsubst var @ impl))
    var))
(define (make-ext-var str impl)
  (defext (newvar (if (clambda? impl)
		      (string-append "@" str)
		    str))
    impl))
(define (make-rad-var radicand n)
  (let ((e (univ_monomial -1 n @)))
    (set-car! (cdr e) radicand)
    (let ((v (make-ext-var "^" e)))
      (set! radical-defs (cons (extrule v) radical-defs))
      v)))

;;; IMPL is a data type consisting of a poly with major variable
;;; @.  The value of the IMPL is negative of the poly solved for @.
;;; Using this representation, if poly is square-free and has no
;;; content (gcd (coefficients) = 1), we can express any
;;; algebraic function or number uniquely, even those with no standard
;;; representation (order > 4 roots).

(define (expr? p)
  (or (number? p)
      (and (pair? p)
	   (poly_var? (car p)))))
(define @ (string->var ":@"))
(define d@ (var_differential @))
(define (@? v) (or (eq? v @) (eq? (var_base v) @)))
(define (impl? p) (and (pair? p) (poly_var? (car p)) (@? (car p))))
(define (rat_number? p)
  (or (number? p)
      (and (impl? p)
	   (= 3 (length p))
	   (number? (cadr p))
	   (number? (caddr p)))))
(define (expr_0? p) (or (eqv? 0 p) (and (impl? p) (eqv? 0 (rat_num p)))))
(define (expl? p)
  (or (number? p)
      (and (pair? p)
	   (poly_var? (car p))
	   (not (@? (car p))))))
;;; Rational impl?
(define (rat? p) (and (impl? p) (= 3 (length p))))
(define (make-rat num denom) (list @ num (poly_negate denom)))
(define rat_num cadr)
(define (rat_denom p) (poly_negate (caddr p)))
(define (rat_unit-denom? p) (unit? (caddr p)))

(define (bunch? p)
  (or (null? p)
      (and (pair? p)
	   (not (poly_var? (car p)))
	   (not (eqv? @= (car p))))))
(define (bunch_map proc b)
  (if (bunch? b)
      (map (lambda (x) (bunch_map proc x)) b)
    (proc b)))
(define (bunch_for-each proc b)
  (if (bunch? b)
      (for-each (lambda (x) (bunch_for-each proc x)) b)
    (proc b)))

(define @= "=")
(define (eqn? p) (and (pair? p) (eqv? @= (car p))))
(define (eqns? p) (if (bunch? p) (some eqns? p) (eqn? p)))
(define (licit? p)
  (or (number? p)
      (and (pair? p)
	   (or (poly_var? (car p))
	       (eqv? @= (car p))))))

(define eqn->poly cdr)
(define (poly->eqn p) (cons @= p))
(define (polys->eqns p) (if (bunch? p) (map polys->eqns p) (poly->eqn p)))
(define (var->expl v) (list v 0 1))
(define (expl->impl p) (make-rat p 1))
(define (var->impl v) (make-rat (var->expl v) 1))

;;; Two paradigms for doing algebra on equations and expressions:
;;; Polynomials as expressions and Polynomials as equations.
;;; Polynomials are used as expressions in GCD.
;;; Polynomials are used as equations in ELIMINATE.
;;;	licit->	polxpr	poleqn
;;;	eqn	expl	expl
;;;	expl	expl	impl
;;;	impl	expl(?)	impl
;;; After the operation is done, we need to convert back.  For
;;; Polynomials as expressions, the result is already expl.  For
;;; polynomials as equations:
;;; 	poleqn->licit
;;;	expl	eqn
;;;	impl	expr
(define (licit->poleqn p)
  (cond ((symbol? p) (var->impl (symbol->var p)))
	((eqn? p) (eqn->poly p))
	((impl? p) p)
	((expl? p) (expl->impl p))
	(else (math-error "cannot be coerced to implicit: " p))))
(define (licits->poleqns p)
  (if (bunch? p) (map licits->poleqns p) (licit->poleqn p)))
(define (poleqn->licit p)
  (cond ((impl? p) (expr_norm p))
	((expl? p) (poly->eqn p))
	(else (math-error "not a polynomial equation" p))))
(define (poleqns->licits p)
  (if (bunch? p) (map poleqns->licits p) (poleqn->licit p)))
(define (licit->polxpr p)
  (cond ((symbol? p) (var->expl (symbol->var p)))
	((eqn? p) (eqn->poly p))
	((expl? p) p)
	((and (impl? p) (poly_/? (rat_num p) (rat_denom p))))
	(else (math-error "cannot be coerced to explicit: " p))))
(define (expr p)
  (cond ((symbol? p) (var->expl (symbol->var p)))
	((expr? p) p)
	(else (math-error "cannot be coerced to expr: " p))))
(define (exprs p)
  (if (bunch? p) (map exprs p) (expr p)))
(define (variable p)
  (cond ((symbol? p) (symbol->var p))
	((poly_var? p) p)
	((and (pair? p)
	      (expl? p)
	      (equal? (cdr p) '(0 1)))
	 (car p))
	(else (math-error "not a simple variable: " p))))
(define (variables b) (map variable b))
(define (integer p)
  (cond ((integer? p) p)
	((not (rat_number? p)) (math-error "not an integer " p))
	((rat_unit-denom? p) (* (rat_denom p) (rat_num p) -1))
	(else (math-error "not an integer " p))))
(define (unit? x) (member x '(1 -1)))
(define (expr_norm p)
  (if (and (rat? p) (rat_unit-denom? p))
      (poly_* (rat_num p) (rat_denom p))
    p))
(define (expr_norm-or-signcan p)
  (if (and (rat? p) (rat_unit-denom? p))
      (poly_* (rat_num p) (rat_denom p))
    (signcan p)))

;;; These two functions return type expl
(define (num p)
  (cond ;;((number? p) (numerator p))
	((impl? p) (rat_num p))
	((expl? p) p)
	(else (math-error "cannot extract numerator " p))))
(define (denom p)
  (cond ;;((number? p) (denominator p))
	((rat? p) (rat_denom p))
	((expl? p) 1)
	(else (math-error "cannot extract denominator " p))))
(define (sexp? e)
  (cond ((number? e) #t)
	((symbol? e) #t)
	((pair? e) (symbol? (car e)))
	((vector? e) #t)
	(else #f)))

;;;Predefined Variables and Constants
(var_set-pri! @ (* 200 char-code-limit))
(var_set-pri! d@ (- (var_pri @) 5))
(define lambda-var-pri (- (var_pri @) 20))
(var_set-pri! (string->var "@") lambda-var-pri)
(var_set-pri! (string->var ":") lambda-var-pri)
(define @1 (string->var "@1"))
(define @2 (string->var "@2"))
(define @3 (string->var "@3"))

(define @1+@2 (list @2 (list @1 0 1) 1))
(define @1-@2 (list @2 (list @1 0 1) -1))
(define -@1 (list @1 0 -1))
(define @1*@2 (list @2 0 (list @1 0 1)))
(define @1/@2 (list @ (list @1 0 1) (list @2 0 -1)))
(define @1=@2 (list @= @2 (list @1 0 -1) 1))
;(define +/- (list @1 0 (list %sqrt1 0 1)))
(define cidentity (list @1 0 1))
