X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme-library.scm;h=cd2693231759f24143b192baa22b34d6d06f2f99;hb=5c256a740ae9bf1f774e202cbdaf66d8e33f37e7;hp=f8c0ec492c76fb8052f37b40faf9ae4f1ac80fb0;hpb=613b910f0ceb0ec0948a0e0595cd3e82086754cf;p=scheme.forth.jl.git

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index f8c0ec4..cd26932 100644
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -13,10 +13,65 @@
 (define (cdar l) (cdr (car l)))
 (define (cddr l) (cdr (cdr l)))
 (define (cadar l) (car (cdr (car l))))
+(define (caddr l) (car (cdr (cdr l))))
+(define (cadddr l) (car (cdr (cdr (cdr l)))))
 
+;; FUNCTIONAL PROGRAMMING
+
+(define (fold-left proc init l)
+  (if (null? l)
+    init
+    (fold-left proc (proc init (car l)) (cdr l))))
+
+(define (reduce-left proc init l)
+  (if (null? l)
+    init
+    (if (null? (cdr l))
+      (car l)
+      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
+
+(define (map proc l)
+  (if (null? l)
+    '()
+    (cons (proc (car l)) (map proc (cdr l)))))
 
 ;; NUMBERS
 
+; Rational primitives
+
+(define (numerator x)
+  (if (ratnum? x)
+    (rat:numerator x)
+    x))
+
+(define (denominator x)
+  (if (ratnum? x)
+    (rat:denominator x)
+    (if (fixnum? x)
+      1
+      1.0)))
+
+(define (rat:+ x y)
+  (make-rational (fix:+ (fix:* (numerator x) (denominator y))
+                        (fix:* (denominator x) (numerator y)))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:- x y)
+  (make-rational (fix:- (fix:* (numerator x) (denominator y))
+                        (fix:* (denominator x) (numerator y)))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:* x y)
+  (make-rational (fix:* (numerator x) (numerator y))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:/ x y)
+  (make-rational (fix:* (numerator x) (denominator y))
+                 (fix:* (denominator x) (numerator y))))
+
+(define (rat:1/ x)
+  (make-rational (denominator x) (numerator x)))
+
 ; Type dispatch and promotion
 
 (define (type-dispatch ops x)
@@ -83,18 +138,6 @@
 (define (null? arg)
   (eq? arg '()))
 
-(define (fold-left proc init l)
-  (if (null? l)
-    init
-    (fold-left proc (proc init (car l)) (cdr l))))
-
-(define (reduce-left proc init l)
-  (if (null? l)
-    init
-    (if (null? (cdr l))
-      (car l)
-      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
-
 (define (+ . args)
   (fold-left pair+ 0 args))
 
@@ -168,7 +211,7 @@
   (define (iter a count)
     (if (null? a)
       count
-      (iter (cdr a) (+ count 1))))
+      (iter (cdr a) (fix:+ count 1))))
   (iter l 0))
 
 ; Join two lists together
@@ -295,15 +338,42 @@
 (define (sum n)
 
   (define (sum-iter total count maxcount)
-    (if (> count maxcount)
+    (if (fix:> count maxcount)
       total
-      (sum-iter (+ total count) (+ count 1) maxcount)))
+      (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
   
   (sum-iter 0 1 n))
 
 ; Recursive summation. Use this to compare with tail call
 ; optimized iterative algorithm.
 (define (sum-recurse n)
-  (if (= n 0)
+  (if (fix:= n 0)
     0
-    (+ n (sum-recurse (- n 1)))))
+    (fix:+ n (sum-recurse (fix:- n 1)))))
+
+;; MISC
+
+(define (license)
+  (display
+"This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program. If not, see http://www.gnu.org/licenses/.
+"))
+
+(define (welcome)
+  (display
+"Welcome to scheme.forth.jl!
+
+Copyright (C) 2016 Tim Vaughan.
+This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.
+Use Ctrl-D to exit.
+"))