frac.l (1622B)
1 # 26may11abu 2 # (c) Software Lab. Alexander Burger 3 4 (de gcd (A B) 5 (until (=0 B) 6 (let M (% A B) 7 (setq A B B M) ) ) 8 (abs A) ) 9 10 (de lcm (A B) 11 (*/ A B (gcd A B)) ) 12 13 (de frac (N D) 14 (if (=0 N) 15 (cons 0 1) 16 (and (=0 D) (quit "frac/0" N)) 17 (let G (gcd N D) 18 (if (gt0 N) 19 (cons (/ N G) (/ D G)) 20 (cons (- (/ N G)) (- (/ D G))) ) ) ) ) 21 22 (de fabs (A) 23 (cons (abs (car A)) (cdr A)) ) 24 25 (de 1/f (A) 26 (and (=0 (car A)) (quit "frac/0" A)) 27 (if (gt0 (car A)) 28 (cons (cdr A) (car A)) 29 (cons (- (cdr A)) (- (car A))) ) ) 30 31 (de f+ (A B) 32 (let D (lcm (cdr A) (cdr B)) 33 (let N 34 (+ 35 (* (/ D (cdr A)) (car A)) 36 (* (/ D (cdr B)) (car B)) ) 37 (if (=0 N) 38 (cons 0 1) 39 (let G (gcd N D) 40 (cons (/ N G) (/ D G)) ) ) ) ) ) 41 42 (de f- (A B) 43 (if B 44 (f+ A (f- B)) 45 (cons (- (car A)) (cdr A)) ) ) 46 47 (de f* (A B) 48 (let (G (gcd (car A) (cdr B)) H (gcd (car B) (cdr A))) 49 (cons 50 (* (/ (car A) G) (/ (car B) H)) 51 (* (/ (cdr A) H) (/ (cdr B) G)) ) ) ) 52 53 (de f/ (A B) 54 (f* A (1/f B)) ) 55 56 (de f** (A N) 57 (if (ge0 N) 58 (cons (** (car A) N) (** (cdr A) N)) 59 (cons (** (cdr A) (- N)) (** (car A) (- N))) ) ) 60 61 (de fcmp (A B) 62 (if (gt0 (* (car A) (car B))) 63 (let Q (f/ A B) 64 (* 65 (if (gt0 (car A)) 1 -1) 66 (- (car Q) (cdr Q))) ) 67 (- (car A) (car B)) ) ) 68 69 (de f< (A B) 70 (lt0 (fcmp A B)) ) 71 72 (de f<= (A B) 73 (ge0 (fcmp B A)) ) 74 75 (de f> (A B) 76 (gt0 (fcmp A B)) ) 77 78 (de f>= (A B) 79 (ge0 (fcmp A B)) ) 80 81 # vi:et:ts=3:sw=3