From: Tim Vaughan <tgvaughan@gmail.com>
Date: Fri, 16 Dec 2016 10:53:28 +0000 (+1300)
Subject: Fleshing out numerical library.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=ec9fd0159ca81657ec35ca99efb4365162672d42;p=scheme.forth.jl.git

Fleshing out numerical library.
---

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index faa9288..fc3c9b9 100644
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -2,9 +2,78 @@
 ;; Standard Library Procedures and Macros ;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;; MISC
+
+(define (not x) (if x #f #t))
+
+(define (list . args) args)
+
+(define (caar l) (car (car l)))
+(define (cadr l) (car (cdr l)))
+(define (cdar l) (cdr (car l)))
+(define (cddr l) (cdr (cdr l)))
+(define (cadar l) (car (cdr (car l))))
+
+
 ;; NUMBERS
 
-; Arithmetic
+; Unary ops
+
+(define (flo:1+ x) (flo:+ x 1.0))
+(define (flo:1- x) (flo:- x 1.0))
+
+(define (1+ n)
+  (type-dispatch (cons fix:1+ flo:1+) n))
+
+(define (1- n)
+  (type-dispatch (cons fix:1- flo:1-) n))
+
+(define (apply-to-flonum op x)
+  (if (flonum? x) (op x) x))
+
+(define (round x)
+  (apply-to-flonum flo:round x))
+(define (floor x)
+  (apply-to-flonum flo:floor x))
+(define (ceiling x)
+  (apply-to-flonum flo:ceiling x))
+(define (truncate x)
+  (apply-to-flonum flo:truncate x))
+
+; Type dispatch and promotion
+
+(define (type-dispatch ops x)
+  (if (flonum? x)
+    ((cdr ops) x)
+    ((car ops) x)))
+
+(define (promote-dispatch ops x y)
+  (if (flonum? x)
+    (if (flonum? y)
+      ((cdr ops) x y)
+      ((cdr ops) x (fixnum->flonum y)))
+    (if (flonum? y)
+      ((cdr ops) (fixnum->flonum x) y)
+      ((car ops) x y))))
+
+; Binary operations
+
+(define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
+(define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
+(define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
+(define (pair/ x y) (promote-dispatch
+                      (cons (lambda 'args
+                              (error "Division unsupported for integers."))
+                            flo:/) x y))
+
+(define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
+(define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
+(define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
+(define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
+(define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
+
+(define (neg x)
+  (type-dispatch (cons fix:neg flo:neg) x))
 
 (define (null? arg)
   (eq? arg '()))
@@ -22,15 +91,20 @@
       (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
 
 (define (+ . args)
-  (fold-left fix:+ 0 args))
+  (fold-left pair+ 0 args))
 
 (define (- first . rest)
   (if (null? rest)
-    (fix:neg first)
-    (fix:- first (apply + rest))))
+    (neg first)
+    (pair- first (apply + rest))))
 
 (define (* . args)
-  (fold-left fix:* 1 args))
+  (fold-left pair* 1 args))
+
+(define (/ first . rest)
+  (if (null? rest)
+    (pair/ 1 first)
+    (pair/ first (apply * rest))))
 
 (define (quotient n1 n2)
   (fix:quotient n1 n2))
@@ -40,12 +114,6 @@
 
 (define modulo remainder)
 
-(define (1+ n)
-  (fix:1+ n))
-
-(define (-1+ n)
-  (fix:-1+ n))
-
 ; Relations
 
 (define (test-relation rel l)
@@ -58,45 +126,38 @@
         #f))))
 
 (define (= . args)
-  (test-relation fix:= args))
+  (test-relation pair= args))
 
 (define (> . args)
-  (test-relation fix:> args))
+  (test-relation pair> args))
 
 (define (< . args)
-  (test-relation fix:< args))
+  (test-relation pair< args))
 
 (define (>= . args)
-  (test-relation fix:>= args))
+  (test-relation pair>= args))
 
 (define (<= . args)
-  (test-relation fix:<= args))
-
+  (test-relation pair<= args))
 
+; Numeric tests 
 
-; Current state of the numerical tower
-(define complex? #f)
-(define real? #f)
-(define rational? #t)
-(define integer? #t)
-(define exact? #t)
-(define inexact? #t)
+(define (zero? x) (pair= x 0.0))
+(define (positive x) (pair> x 0.0))
+(define (odd? n) (pair= (remainder n 2) 0))
+(define (odd? n) (not (pair= (remainder n 2) 0)))
 
-; Logic
 
-(define (not x) (if x #f #t))
+; Current state of the numerical tower
+(define (complex? x) #f)
+(define (real? x) #t)
+(define (rational? x) #t)
+(define (integer? x) (= x (round x)))
+(define (exact? x) (fixnum? x))
+(define (inexact? x) (flonum? x))
 
 ;; LISTS
 
-(define (list . args) args)
-
-
-(define (caar l) (car (car l)))
-(define (cadr l) (car (cdr l)))
-(define (cdar l) (cdr (car l)))
-(define (cddr l) (cdr (cdr l)))
-(define (cadar l) (car (cdr (car l))))
-
 ; Return number of items in list
 (define (length l)
   (define (iter a count)
diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index 8dad18e..8bcbb97 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -151,7 +151,7 @@
 
 \ }}}
 
-\ ==== Primitivle Arithmetic ==== {{{
+\ ==== Numeric types ==== {{{
 
 \ --- Fixnums ---
 
@@ -279,6 +279,10 @@
 ; 1 make-fa-primitive flo:finite?
 
 
+:noname ( flonum -- flonum )
+    swap -1.0 f* swap
+; 1 make-fa-primitive flo:neg
+
 :noname ( flonum -- flonum )
     swap fabs swap
 ; 1 make-fa-primitive flo:abs
@@ -359,6 +363,13 @@
     drop swap drop f/ fatan flonum-type
 ; 2 make-fa-primitive flo:atan2
 
+
+\ --- Conversion ---
+
+:noname ( fixnum -- flonum )
+    drop i->f flonum-type
+; 1 make-fa-primitive fixnum->flonum
+
 \ }}}
 
 \ ==== Pairs and Lists ==== {{{