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