;;;---	HBASE > -*- package: user; mode: lisp; base: 10.; readtable: CL -*-

; MISCELLANEOUS FUNCTIONS:

(defun test-mod (x modulus &optional (count 0.))
  (cond ((> count 50.) (ferror nil "Arg too large."))
	((< x 0.) (test-mod (+ x modulus) modulus (1+ count)))
	((< x modulus) x)
	(t (test-mod (- x modulus) modulus (1+ count)))))


(defun pimod (a)
  (when (> (abs a) 20.0s0)
    (ferror nil "Angle too large."))
  (cond ((< a (- ONEPI)) (pimod (+ a TWOPI)))
	((< a ONEPI) a)
	(t (pimod (- a TWOPI)))))


(defun sine (x)
  (setq x (small-float x))
  (cond ((< (abs x) 1.0s-3) x)
	(t (min (max (let ((frac (/ (abs x) 1.570796326s0))
			   (d)
			   (sign (cond ((> x 0) 1.)
				       (t -1.))))
		       (setq d (fix frac) frac (- frac d))
		       (selectq (ldb 0002 d)
			 (1 (setq sign (minus sign) frac (- frac 1)))
			 (2 (setq sign (minus sign)))
			 (3 (setq frac (- frac 1))))
		       (let ((y (* frac sign))
			     (y2 (* frac frac)))
			 (* y (+ 1.5707963185s0
				 (* y2 (+ -.6459637111s0
					  (* y2 (+ .07968967928s0
						   (* y2 (+ -.00467376557s0
							    (* y2 .00015148419s0)))))))))))
		     -1.0s0)
		1.0s0))))


(defun arctan (x y)				; returns 0.0s0 <= angle < TWOPI
   (setq x (small-float x)
	 y (small-float y))
   (prog ((absx (abs x)) (absy (abs y)) temp temp2 (ans -0.004054058s0))
	 (when (and (zerop x) (zerop y))
	   (return 0.0s0))
	 (setq temp (/ (- absy absx) (+ absy absx))
	       temp2 (* temp temp))
	 (do ((l '( 0.0218612288s0 -0.0559098861s0 0.0964200441s0
		   -0.139085335s0 0.1994653499s0 -0.3332985605s0 0.9999993329s0)
		 (cdr l)))
	     ((null l))
	   (setq ans (+ (* ans temp2) (car l))))
	 (setq ans (* ans temp) temp (abs ans))
	 (cond ((or (>= temp .7855s0) (< temp .7853s0))
		(setq ans (+ ans 0.7853981634s0)))
	       ((< ans 0.0s0) (setq ans (/ absy absx)))
	       (t (setq ans (+ (/ absx absy) 1.5707963268s0))))
	 (setq temp ans ans (- 3.1415926536s0 ans))
	 (when (>= x 0.0s0)
	   (swap temp ans))
	 (setq temp (* temp 2.0s0))
	 (when (< y 0.0s0)
	   (setq ans (+ ans temp)))
	 (return ans)))


;(defun test-round (x)
;  (cond ((> (abs x) 1.0s6) (ferror nil "Overflow."))
;	(t (round x))))


(defun clear ( )
  (send *TERMINAL-IO* ':CLEAR-SCREEN)
  (when (boundp '*GRAPHICS-WINDOW*)
    (send *GRAPHICS-WINDOW* ':CLEAR-SCREEN))
  (setq *SCREEN-CLEARED?* t))


;;; End.