picolisp

commit 5b600aa2619b05f0f02449d55d578d577ec083b9
parent 44197da1f2cbe56890678dcd819ae2a1a459775b
Author: Commit-Bot <unknown>
Date:   Fri, 25 Jun 2010 08:17:14 +0000

Automatic commit from picoLisp.tgz, From: Fri, 25 Jun 2010 08:17:14 GMT
Diffstat:
A
lib/frac.l
 | 
83
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src64/version.l
 | 
4
++--

2 files changed, 85 insertions(+), 2 deletions(-)
diff --git a/lib/frac.l b/lib/frac.l
@@ -0,0 +1,83 @@
+# 25jun10abu
+# (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)
+   (* B (/ A (gcd A B))) )
+
+(de frac (N D)
+   (if (=0 N)
+      (cons 0 1)
+      (and (=0 D) (quit "frac/0" N))
+      (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
+      (prog1
+         (f+ A B)
+         (set @ (- (car A))) )
+      (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
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 21jun10abu
+# 25jun10abu
 # (c) Software Lab. Alexander Burger
 
-(de *Version 3 0 2 33)
+(de *Version 3 0 2 34)
 
 # vi:et:ts=3:sw=3