; .EnTete "Le-Lisp (c) version 15.2" " " "L'arithme'tique ge'ne'rique mixte"
; .EnPied "genarith.ll" "E-%" " "
; .Annexe E "L'Arithme'tique Ge'ne'rique mixte"
; .nr % 1
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
; .Centre "*****************************************************************"

; .Centre "$Header: genarith.ll,v 4.1 88/01/13 12:19:50 kuczynsk Rel $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'genarith))

; Le chargement de ce fichier transforme les appels de l'arithme'tique
; ge'ne'rique en arithme'tique mixte, supprimant ainsi les erreurs ERRGEN
; en cas de de'bordement entier.
; 
; Seules les me'thodes : + - 0- * / 1/ ont un sens ici.

(de #:genarith:+ (n1 n2)
    (if (and (fixp n1) (fixp n2))
        (fadd (float n1) (float n2))
        (#:genarith:error '+ n1 n2)))

(de #:genarith:- (n1 n2)
    (if (and (fixp n1) (fixp n2))
        (fsub (float n1) (float n2))
        (#:genarith:error '- n1 n2)))

(de #:genarith:0- (n)
    (if (fixp n)
        (fsub 0.0 (float n))
        (#:genarith:error '0- n)))

(de #:genarith:* (n1 n2)
    (if (and (fixp n1) (fixp n2))
        (fmul (float n1) (float n2))
        (#:genarith:error '* n1 n2)))

(de #:genarith:/ (n1 n2)
    (if (and (fixp n1) (fixp n2))
        (if (eqn 0 n2)
            (error '/ err0dv (list n1 n2))
            (fdiv (float n1) (float n2)))
        (#:genarith:error '/ n1 n2)))

(de #:genarith:1/ (n)
    (if (fixp n)
        (if (eqn n 0)
            (error '1/ err0dv n)
            (fdiv 1.0 (float n)))
        (#:genarith:error '1/ n)))

(defvar #:ex:mod 0)

(de #:genarith:quomod (n1 n2)
    (let ((q (floor (/ n1 (abs n2)))))
         (setq #:ex:mod (- n1 (* (abs n2) q)))
         (if (< n2 0) (- q) q)))

(de #:genarith:error (f . l)
    (while l
           (if (or (fixp (car l)) (floatp (car l)))
               (nextl l)
               (error f 'ERRNNA (car l)))))

(defvar #:sys-package:genarith 'genarith)


; Re'glage de la fonction QUOTIENT/QUOMOD canonique 
; (courtesy of Jean Vuillemin)


(de floor (r)
    ; Renvoie le plus grand entier relatif z tel que z<=r:
    (ifn (numberp r)
         (error 'floor 'ERRNNA r)
         (let ((z (truncate r)))
              (if (> z r)
                  (- z 1)
                  z))))

(de ceiling (r) 
    (let ((z (floor r))) 
         (if (< z r) (+ z 1) z))) ; !!

; n=dq+r -d<2r<=d  ou -d-r<r<=d-r
(de round (n d)
    (cond ((< d 0) (0- (round n (0- d))))
          ((< n 0)
           (if (= #:ex:mod (- d #:ex:mod))
               (- -1 (round (0- n) d)) 
               (setq n (0- (round (0- n) d)) #:ex:mod (0- #:ex:mod))
               n))
          ((setq n (quotient n d) d (- d #:ex:mod))
           (if (< d #:ex:mod)
               (setq #:ex:mod (0- d) n (+ 1 n))
               n)))))