Solved hygiene problem, MCE runs (VERY slowly)

[scheme.forth.jl.git] / src / scheme-library.scm

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index fc3c9b9..2c6146e 100644 (file)
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -12,13 +12,96 @@
 (define (cadr l) (car (cdr l)))
 (define (cdar l) (cdr (car l)))
 (define (cddr l) (cdr (cdr l)))
 (define (cadr l) (car (cdr l)))
 (define (cdar l) (cdr (car l)))
 (define (cddr l) (cdr (cdr l)))

+(define (caaar l) (car (car (car l))))
+(define (caadr l) (car (car (cdr l))))

 (define (cadar l) (car (cdr (car l))))
 (define (cadar l) (car (cdr (car l))))

+(define (caddr l) (car (cdr (cdr l))))
+(define (cdaar l) (cdr (car (car l))))
+(define (cdadr l) (cdr (car (cdr l))))
+(define (cddar l) (cdr (cdr (car l))))
+(define (cdddr l) (cdr (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
 
 
 ;; 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)
+  (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))))
+

 ; Unary ops
 
 ; Unary ops
 

+(define (neg x)
+  (type-dispatch (cons fix:neg flo:neg) x))
+
+(define (abs x)
+  (type-dispatch (cons fix:abs flo:abs) x))
+

 (define (flo:1+ x) (flo:+ x 1.0))
 (define (flo:1- x) (flo:- x 1.0))
 
 (define (flo:1+ x) (flo:+ x 1.0))
 (define (flo:1- x) (flo:- x 1.0))
 


@@ -40,31 +123,17 @@
 (define (truncate x)
   (apply-to-flonum flo:truncate 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
 
 ; Binary operations
 

+(define (fix:/ x y) ; Non-standard definition while we don't have rationals
+  (if (fix:= 0 (fix:remainder x y))
+    (fix:quotient x y)
+    (flo:/ (fixnum->flonum x) (fixnum->flonum 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 (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))


@@ -72,24 +141,9 @@
 (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 '()))
 
 (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))
 
 (define (+ . args)
   (fold-left pair+ 0 args))
 


@@ -155,6 +209,10 @@
 (define (integer? x) (= x (round x)))
 (define (exact? x) (fixnum? x))
 (define (inexact? x) (flonum? x))
 (define (integer? x) (= x (round x)))
 (define (exact? x) (fixnum? x))
 (define (inexact? x) (flonum? x))

+(define (number? x)
+  (if (fixnum? x) #t
+    (if (flonum? x) #t
+      (if (ratnum? x) #t #f))))

 
 ;; LISTS
 
 
 ;; LISTS
 


@@ -163,7 +221,7 @@
   (define (iter a count)
     (if (null? a)
       count
   (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
   (iter l 0))
 
 ; Join two lists together


@@ -191,19 +249,9 @@
 
 ; let
 
 
 ; let
 

-(define (let-vars args)
-  (if (null? args)
-    '()
-    (cons (caar args) (let-vars (cdr args)))))
-
-(define (let-inits args)
-  (if (null? args)
-    '()
-  (cons (cadar args) (let-inits (cdr args)))))
-

 (define-macro (let args . body)
 (define-macro (let args . body)

-              `((lambda ,(let-vars args)
-                 ,@body) ,@(let-inits args)))
+              `((lambda ,(map (lambda (x) (car x)) args)
+                 ,@body) ,@(map (lambda (x) (cadr x)) args)))

 
 ; while
 
 
 ; while
 


@@ -217,60 +265,66 @@
 
 ; cond
 
 
 ; cond
 

-(define (cond-predicate clause) (car clause))
-(define (cond-actions clause) (cdr clause))
-(define (cond-else-clause? clause)
-  (eq? (cond-predicate clause) 'else))
-
-(define (expand-clauses clauses)
-  (if (null? clauses)
-    (none)
-    (let ((first (car clauses))
-          (rest (cdr clauses)))
-      (if (cond-else-clause? first)
-        (if (null? rest)
-          `(begin ,@(cond-actions first))
-          (error "else clause isn't last in cond expression."))
-        `(if ,(cond-predicate first)
-           (begin ,@(cond-actions first))
-           ,(expand-clauses rest))))))
-
-(define-macro (cond . clauses)
-              (if (null? clauses)
-                (error "cond requires at least one clause.")
-                (expand-clauses clauses)))
+((lambda ()
+   (define (cond-predicate clause) (car clause))
+   (define (cond-actions clause) (cdr clause))
+   (define (cond-else-clause? clause)
+     (eq? (cond-predicate clause) 'else))
+
+   (define (expand-clauses clauses)
+     (if (null? clauses)
+       (none)
+       (let ((first (car clauses))
+             (rest (cdr clauses)))
+         (if (cond-else-clause? first)
+           (if (null? rest)
+             `(begin ,@(cond-actions first))
+             (error "else clause isn't last in cond expression."))
+           `(if ,(cond-predicate first)
+              (begin ,@(cond-actions first))
+              ,(expand-clauses rest))))))
+
+   (define-macro (cond . clauses)
+                 (if (null? clauses)
+                   (error "cond requires at least one clause.")
+                   (expand-clauses clauses)))
+   ))

 
 ; and
 
 
 ; and
 

-(define (expand-and-expressions expressions)
-  (let ((first (car expressions))
-        (rest (cdr expressions)))
-    (if (null? rest)
-      first
-      `(if ,first
-         ,(expand-and-expressions rest)
-         #f))))
-
-(define-macro (and . expressions)
-              (if (null? expressions)
-                #t
-                (expand-and-expressions expressions)))
+((lambda ()
+   (define (expand-and-expressions expressions)
+     (let ((first (car expressions))
+           (rest (cdr expressions)))
+       (if (null? rest)
+         first
+         `(if ,first
+            ,(expand-and-expressions rest)
+            #f))))
+
+   (define-macro (and . expressions)
+                 (if (null? expressions)
+                   #t
+                   (expand-and-expressions expressions)))
+   ))

 
 ; or
 
 
 ; or
 

-(define (expand-or-expressions expressions)
-  (if (null? expressions)
-    #f
-    (let ((first (car expressions))
-          (rest (cdr expressions))
-          (val (gensym)))
-      `(let ((,val ,first))
-         (if ,val
-            ,val
-            ,(expand-or-expressions rest))))))
+((lambda ()
+   (define (expand-or-expressions expressions)
+     (if (null? expressions)
+       #f
+       (let ((first (car expressions))
+             (rest (cdr expressions))
+             (val (gensym)))
+         `(let ((,val ,first))
+            (if ,val
+              ,val
+              ,(expand-or-expressions rest))))))

 
 

-(define-macro (or . expressions)
-              (expand-or-expressions expressions))
+   (define-macro (or . expressions)
+                 (expand-or-expressions expressions))
+   ))

 
 
 ;; TESTING
 
 
 ;; TESTING


@@ -290,15 +344,42 @@
 (define (sum n)
 
   (define (sum-iter total count maxcount)
 (define (sum n)
 
   (define (sum-iter total count maxcount)

-    (if (> count maxcount)
+    (if (fix:> count maxcount)

       total
       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)
   
   (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
     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.
+"))