;;; -*- Mode:Scheme; Package:SCHEME-USER; Base:10 -*-
;;; 9/19/86 10:48:36
;      -*- Mode: Lisp -*-			       Filename:  pnum2s.s

;                     Last Revision:  12-Sep-85 1900ct
;;  3/30/88 DNG - Fix significant digits calculation.
;;  3/31/88 DNG - Add temporary hack to avoid error on complex numbers.  
;;		Modify to make single-letter symbol keys insensitive to package.
;;  4/06/88 DNG - Updated with a few changes from the 10-Feb-87 0900ct version 
;;		of the PC Scheme source.
;--------------------------------------------------------------------------;
;									   ;
;                         TI SCHEME -- PCS Compiler                        ;
;                  Copyright 1985 (c) Texas Instruments                    ;
;									   ;
;			       David Bartley				   ;
;									   ;
;               NUMBER->STRING and INTEGER->STRING Routines		   ;
;                              (Mark Meyer)				   ;
;									   ;
;--------------------------------------------------------------------------;

(define number->string)
;(define integer->string)

(letrec
 ((form-%%squares%%
   (lambda ()
     (mapc (lambda (x)
; Check the use of double float with Ken.  We proabaly need to add the function double-float to the translator	     
	     (let ((base ((%cl-function double-float) (car x)));jha 06/26/87 15:20:19 
;	     (let ((base (float (car x)))
		   (vec (cadr x)))
	       (do ((i (-1+ (vector-length vec)) (-1+ i)))
		   ((negative? i) 'OK)
		 (vector-set! vec i base)
		 (if (positive? i) (set! base (* base base))))))
	   %%squares%%)))

  (%%squares%%
   `((2 ,(make-vector 10)) (8 ,(make-vector 9))
     (10 ,(make-vector 9)) (16 ,(make-vector 8))))


  (scale
   (lambda (flo base)
     (if (null? (vector-ref (cadar %%squares%%) 0))
	 (form-%%squares%%))
     (if (zero? flo)
	 (cons flo 0)
	 (let ((small (<? flo 1.))
	       (sqrvec (cadr (assq base %%squares%%))))
	   (let ((scale 0)
		 (local (if small (/ flo) flo))
		 (lim (vector-length sqrvec)))
	     (do ((i 0 (1+ i)))
		 ((=? i lim) '())
	       (set! scale (* 2 scale))
		   (let ((sqr (vector-ref sqrvec i)))
		 (when (>=? local sqr)
		       (set! scale (1+ scale))
		       (set! local (/ local sqr)))))
	     (when small
		   (set! scale (- scale))
		   (set! local (/ local))
		   (when (<? local 1.)
			 (set! scale (-1+ scale))
			 (set! local (* local base))))
	     (cons local scale))))))

  (int->str
   (lambda (n base)
     (letrec
      ((i->s
	(lambda (n)
	  (if (zero? n)
	      ""
	      (let ((dig (remainder n base))
		    (rest (quotient n base)))
		(string-append
		    (i->s rest)
		    (make-string 1 (integer->char
				       (+ dig (if (>? dig 9) 55 48))))))))))
      (cond ((negative? n)
	     (string-append "-" (int->str (- n) base)))
	    ((zero? n) (make-string 1 #\0))
	    (else (i->s n))))))

  (num->str
   (lambda (num format)
     (define bad-format
       (lambda ()
	 (error "NUMBER->STRING: Invalid format specification" format)))
     (define (first-char symbol)
       ;; First character of symbol name, not including package.
       ;; This is done to avoid having to export a bunch of one-character 
       ;; symbols that would be likely to aquire conflicting definitions from 
       ;; different packages.
       (string-ref ((%cl-function symbol-name) symbol) 0))
     (if (not (number? num))
	 (error "NUMBER->STRING: Invalid argument" num))
     (if (atom? format) (bad-format))
     (letrec
      ((absnum (abs num))
       (sign (if (negative? num) "-" ""))
       (base 10)
       (radix "")
       (exact (integer? num))
       (exactness "")
       (result "")
       (sigfigs ())
       (default-n ())
       (factor ())
       (half-digit ())
       (highest-digit ())
       (numtype (car format))
       (formargs (cdr format))
       (numscale ())
       (numnorm ())
       (n ())
       (m ())
       (result-len ())
       (set-mods
        (lambda (l)
          (cond ((null? l) #!true)
                ((atom? l) ())
                ((not (set-mods (cdr l))) ())
                (else
		 (let ((mod (car l)))
		   (if (pair? mod)
		       (case (car mod)
			 (radix
			  (if (null? (cdr mod))
			      ()
			      (begin
			        (set! base
				      (cadr (assq (first-char (cadr mod))
						  '((#\B 2) (#\O 8)
						    (#\D 10) (#\X 16)))))
				(if base
				    (set! radix
					  (let ((express
						 (caddr mod)))
					    (when (symbol? express)
					      (set! express (first-char express)))
					    (cond ((or (eqv? express #\E)
						       (null? express))
						   (cadr (assq base
							       '((2 "#b")
								 (8 "#o")
								 (10 "#d")
								 (16 "#x")
								 ))))
						  ((eqv? express #\S)
						   "")
						  (else ())))))
				(and base radix))))
			 (exactness
			  (case (first-char (cadr mod))
			    (#\E (set! exactness (if exact "#E" "#I")))
			    (#\S (set! exactness ""))
			    (else ())))
			 (else ()))
		       ()))))))
       (argcheck
        (lambda (arg)
          (or (number? arg)
	      (and (symbol? arg)
		   (eqv? (first-char arg) #\H))))) ; `Heuristic'
       (check-args
        (lambda (num-of-args)
          (if (case num-of-args
                (0 (set-mods formargs))
                (1
                 (set-mods
                    (if (argcheck (car formargs))
                        (begin
                          (set! n (car formargs))
                          (cdr formargs))
                        formargs)))
                (2
                 (set-mods
                    (if (argcheck (car formargs))
                        (begin
                          (set! n (car formargs))
                          (if (argcheck (cadr formargs))
                              (begin
                                (set! m (cadr formargs))
                                (cddr formargs))
                              (cdr formargs)))
                        formargs)))
		(else #!false))
              (begin
                (set! sigfigs
                      (cadr (assq base
				  ;; Number of significant digits computed by:
				  ;; (ABS (ROUND (LOG LISP:SINGLE-FLOAT-EPSILON base)))
				  (if ((%cl-function sys:double-floatp) num)
				      '((2 53) (8 18) (10 16) (16 13))
				      '((2 24) (8 8) (10 7) (16 6))))))
		(set! default-n
		      (cadr (assq base
				  ;; significant digits for single-float
				  '((2 24) (8 8) (10 7) (16 6)))))
                (set! factor (float (expt base (-1+ sigfigs))))
                (set! half-digit
                      (integer->char (+ 48 (quotient base 2))))
                (set! highest-digit
                      (if (=? base 16)
                          #\f
                          (integer->char (+ 48 (-1+ base)))))
                #!true)
              (bad-format))))
       (string-round
        (lambda (s place)
          (cond ((<? place 1) s)
                ((<=? (string-length s) place) s)
                ((char<? (string-ref s place) half-digit) s)
                (else
		 (do ((i (-1+ place) (-1+ i)))
		     ((or (negative? i)
			  (not (char=? (string-ref s i) highest-digit)))
		      (if (negative? i)
			  ()
			  (let ((c (string-ref s i)))
			    (string-set! s i
					 (if (char=? c #\9)
					     #\a
					     (integer->char
					      (1+ (char->integer c))))))))
		   (string-set! s i #\0))
		 (when (char=? (string-ref s 0) #\0)
		       (if (number? numscale)
			   (set! numscale (1+ numscale)))
		       (substring-move-right!
			   s 0 (-1+ (string-length s)) s 1)
		       (string-set! s 0 #\1))
		 s))))
       (flag-insignificants
        (lambda (s places c)
          (let ((len (string-length s)))
            (if (>? len places)
                (substring-fill! s places len c))
            s)))
       (form-result
        (lambda (flo)
          (if (not (number? flo))
              (error "NUMBER->STRING: number too large for format" num))
          (set! flo (round flo))
          (when (and (member numtype '(FLO SCI))
		     (>= flo
			 (if (number? n)
			     (expt base n)
			     (* factor base))))
		(set! numscale (1+ numscale))
		(set! flo (quotient flo base)))
          (set! result (int->str flo base))
          (set! result (string-round result sigfigs))
          (flag-insignificants
             result
             sigfigs
             (if (integer? num) #\0 #\#))))
       (set-result-len
        (lambda ()
          (set! result-len (string-length result))))
       (add-leading-zeros
        (lambda (n)
          (set-result-len)
          (set! result
                (cond ((string=? result "0") (make-string n #\0))
                      ((>=? n result-len)
                       (string-append
                          (make-string (- n result-len) #\0)
                          result))
                      (else result)))))
       (insert-point
        (lambda (place)
          (set! result
                (string-append
                   (substring result 0 place)
                   "."
                   (if (and (float? num)
			    (= place result-len))
		       "0"	
		       (substring result place result-len))))))
       (scale-absnum
        (lambda ()
          (let ((x (scale absnum base)))
            (set! numscale (cdr x))
            (set! numnorm (car x)))))
       (kill-trailing-zeros
        (lambda (lim)
          (do ((i (-1+ (string-length result)) (-1+ i)))
              ((or (<? i lim)
                   (not (char=? (string-ref result i) #\0)))
               (set! result (substring result 0 (1+ i))))
            '())))
       (float-integer
        (lambda ()
          (if (integer? absnum)
              (set! absnum (float absnum)))
          (if (not (number? absnum))
              (error
                 "NUMBER->STRING: integer too large for float conversion"
                 num))))
       (return-result
        (lambda ()
          (if (string=? result ".") (set! result "0."))
          (string-append radix exactness sign result))))
      (case numtype
	(int
	   (check-args 0)
	   (if (integer? absnum)
	       (set! result (int->str absnum base))
	       (form-result absnum))
	   (return-result))
	(fix
	   (check-args 1)
	   (if (null? n) (set! n default-n))
	   (if (or (symbol? n) ;  (eq? arg 'H)
		   (negative? n))
	       (bad-format))
	   (float-integer)
	   (form-result (* absnum (expt base n)))
	   (add-leading-zeros n)
	   (set-result-len)
	   (insert-point (- result-len n))
	   (return-result))
	(flo
	   (check-args 1)
	   (if (null? n) (set! n default-n))
	   (if (and (not (and (symbol? n) (eqv? (first-char n) #\H))) ; (eq? n 'H))
		    (not (positive? n)))
	       (bad-format))
	   (float-integer)
	   (scale-absnum)
	   (if (or (>=? numscale sigfigs) (<? numscale -1))
	       (num->str num (cons 'SCI formargs))
	       (begin
		 (if (number? n)
		     (form-result (* numnorm (expt base (-1+ n))))
		     (begin
		       (form-result (* numnorm factor))
		       (kill-trailing-zeros (1+ numscale))))
		 (set-result-len)
		 (when (<=? result-len numscale)
		       (set! result
			     (string-append result
				 (make-string
				     (- (1+ numscale) result-len) #\0)))
		       (set-result-len))
		 (insert-point (1+ numscale))
		 (return-result))))
	(sci
	   (check-args 2)
	   (if (or (symbol? m) ; (eq? m 'H)
		   (and (number? m) (symbol? n))) ; (eq? n 'H)
	       (bad-format))
	   (if (null? n) (set! n default-n))
	   (if (and (number? n) (null? m)) (set! m (-1+ n)))
	   (if (and (number? n)
		    (or (not (positive? n)) (negative? m) (<? n m)))
	       (bad-format))
	   (float-integer)
	   (scale-absnum)
	   (if (number? n)
	       (begin
		 (form-result (* numnorm (expt base (-1+ n))))
		 (set! m (- n m)))
	       (begin
		 (form-result (* numnorm factor))
		 (set! m 1)
		 (kill-trailing-zeros m)))
	   (set-result-len)
	   (if (<? m result-len) (insert-point m))
	   (set! result
		 (string-append
		     result
		     (if (=? base 16) "L" "E")
		     (int->str (1+ (- numscale m)) 10)))
	   (return-result))
	(heur
	   (check-args 0)
	   (if (integer? absnum)
	       (num->str num (cons 'INT formargs))
	       (num->str num 
			 (list* (if (or (= absnum 0.0)
				        (and (>= absnum 1.0e-3)
					     (<  absnum 1.0e7)))
				   'FLO
				   'SCI)
				'H
				formargs))))
	(else (bad-format)))))))
 (set! number->string				; number->string
   (lambda (number format)
     (if ((%cl-function complexp) number)
	 ;; Temporary hack for complex numbers until supported above.
	 ((%cl-function write-to-string) number)
	 (num->str number format)
	 )))
; (set! integer->string				; integer->string
;   (lambda (n base)
;     (int->str n base)))
 )
