Various changes

Various changes including work define-dfa macro in Racket/DFA.rkt and
implementations of church booleans in javascript, racket, and lazy
racket. Also implemented various other church encoded types in
javascript.

Signed-off-by: Collin J. Doering <collin.doering@rekahsoft.ca>

Clojure/rdm.clj

@@ -4,7 +4,7 @@
 
 (map (fn [x] (* x x)) '(0 1 2 3 4 5))
 
-;; Example factorial function with accumulator (tail call)
+;; Example factorial function with accumulator (aridity overloading)
 (defn factorial
   ([n]
      (factorial n 1))

ELisp/rdm.el

@@ -0,0 +1,28 @@
+;; (C) Copyright Collin J. Doering 2014
+;;
+;; 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/>.
+
+;; File: rdm.el
+;; Author: Collin J. Doering <collin.doering@rekahsoft.ca>
+;; Date: Nov  6, 2014
+
+(defun hi-there (arg)
+  "Says 'Hi there!' in the message buffer. If called with the prefix
+argument, prompts the user to enter a name and then replies 'Hi there, name'"
+  (interactive "P")
+  (if (equal arg '(4))
+      (let ((name (read-from-minibuffer "Enter your name: ")))
+        (message "Hi there, %s." name))
+    (message "Hi there!")))
+

JavaScript/rdm.js

@@ -0,0 +1,375 @@
+/**
+ * (C) Copyright Collin J. Doering 2015
+ *
+ * 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/>.
+*/
+
+/**
+ * File: rdm.js
+ * Author: Collin J. Doering <collin.doering@rekahsoft.ca>
+ * Date: Feb  2, 2015
+ */
+
+var church = (function () {
+    var spec,
+        t = function (x) {
+            var ret = function (y) {
+                return x;
+            };
+            return ret;
+        },
+        f = function (x) {
+            var ret = function (y) {
+                return y;
+            };
+            return ret;
+        },
+        church_zero = function (f) {
+            var ret = function (x) {
+                return x;
+            };
+            return ret;
+        },
+        nil;
+
+    // ------------------------------
+    // Church Boolean implementation
+    // ------------------------------
+
+    function make_bool (b) {
+        if (b) {
+            return t;
+        } else {
+            return f;
+        }
+    }
+
+    function unchurch_bool (b) {
+        return b(true)(false);
+    }
+
+    function and (x) {
+        var ret = function (y) {
+            return x(y)(x);
+        };
+        return ret;
+    }
+
+    function or (x) {
+        var ret = function (y) {
+            return x(x)(y);
+        };
+        return ret;
+    }
+
+    function not (x) {
+        var ret = function (y) {
+            var aret = function (z) {
+                return x(z)(y);
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    function xor (x) {
+        var ret = function (y) {
+            return x(not(y))(y);
+        };
+        return ret;
+    }
+
+    function church_if (p) {
+        var ret = function (a) {
+            var aret = function (b) {
+                return p(a)(b);
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    // -----------------------
+    // Church natural numbers
+    // -----------------------
+
+    function succ (n) {
+        var ret = function (f) {
+            var aret = function (x) {
+                return f(n(f)(x));
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    function add (n) {
+        var ret = function (m) {
+            var aret = function (f) {
+                var bret = function (x) {
+                    return n(f)(m(f)(x));
+                };
+                return bret;
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    function mult (n) {
+        var ret = function (m) {
+            var aret = function (f) {
+                var bret = function (x) {
+                    return n(m(f))(x);
+                };
+                return bret;
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    function expt (n) {
+        var ret = function (m) {
+            var aret = function (f) {
+                var bret = function (x) {
+                    return (m(n))(f)(x);
+                };
+                return bret;
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    function isZero (n) {
+        var ret = n(function (x) {
+            return f;
+        })(t);
+        return ret;
+    }
+
+    function make_nat (n) {
+        var i, ret = church_zero.bind({});
+        for (i = 0; i < n; i += 1) {
+            ret = succ(ret);
+        }
+        return ret;
+    }
+
+    function unchurch_nat (n) {
+        var ret = function (i) {
+            var aret = function (m) {
+                i += 1;
+                return i;
+            };
+            return aret;
+        }, i = 0;
+        return n(ret(i))(0);
+    }
+
+    // -------------
+    // Church Pairs
+    // -------------
+
+    function make_pair (a) {
+        var ret = function (b) {
+            var aret = function (f) {
+                return f(a)(b);
+            };
+            return aret;
+        };
+        return ret;
+    }
+
+    function fst (p) {
+        return p(t);
+    }
+
+    function snd (p) {
+        return p(f);
+    }
+
+    function unchurch_pair (p) {
+        return [fst(p), snd(p)];
+    }
+
+    // -------------
+    // Church Lists
+    // -------------
+
+    function make_list () {}
+
+    function unchurch_list (xs) {}
+
+    nil = make_pair(t)(t);
+    isNil = fst;
+
+    function cons (h) {
+        var ret = function (t) {
+            return make_pair(f)(make_pair(h)(t));
+        };
+        return ret;
+    }
+
+    function head (l) {
+        return fst(snd(l));
+    }
+
+    function tail (l) {
+        return snd(snd(l));
+    }
+
+    // -----------------
+    // The Y Combinator
+    // -----------------
+    // * This doesn't work as javascript is strictly evaluated
+    // -----------------
+    
+    function fix (g) {
+        var f = function (x) {
+            return g(x(x));
+        };
+        return f(f);
+    }
+
+    // Setup specification object
+    spec = {
+        "if": church_if,
+        fix: fix,
+        bool: {
+            make: make_bool,
+            toNative: unchurch_bool,
+            t: t,
+            f: f,
+            not: not,
+            and: and,
+            or: or,
+            xor: xor
+        },
+        nat: {
+            make: make_nat,
+            toNative: unchurch_nat,
+            zero: church_zero,
+            succ: succ,
+            add: add,
+            mult: mult,
+            expt: expt,
+            isZero: isZero
+        },
+        pair: {
+            make: make_pair,
+            toNative: unchurch_pair,
+            fst: fst,
+            snd: snd
+        },
+        list: {
+            make: make_list,
+            toNative: unchurch_list,
+            nil: nil,
+            isNil: isNil,
+            cons: cons,
+            head: head,
+            tail: tail
+        }
+    };
+    return spec;
+})();
+
+// -------------------------
+
+function unchurch_church_nat_test (lim) {
+    var i,
+        lim = lim || 12;
+    for (i = 0; i <= lim; i += 1) {
+        if (i !== church.nat.toNative(church.nat.make(i))) {
+            console.log('Failed church.nat.toNative(church.nat.make(' + i + '))');
+            return false;
+        }
+    }
+    console.log('Created church nats from 1 to ' + lim + ' successfully.');
+    return true;
+}
+
+function uncurry (f) {
+    var ret = function (x, y) {
+        return f(x)(y);
+    };
+    return ret;
+}
+
+function matrix_test (f, g, n, tp) {
+    var i, j,
+        t = tp || 100,
+        name = n || "unnamed";
+    for (i = 0; i <= t; i += 1) {
+        for (j = 0; j <= t; j += 1) {
+            if (f(i,j) !== g(i,j)) {
+                console.log('Failed matrix test for ' + name + ' with inputs ' + i + ' and ' + j + '.');
+                return false;
+            }
+        }
+    }
+    console.log('Successfully completed test for ' + name + '.');
+    return true;
+}
+
+unchurch_church_nat_test(100);
+
+matrix_test(function (a, b) {
+    return a + b;
+}, function (a, b) {
+    return church.nat.toNative(church.nat.add(church.nat.make(a))(church.nat.make(b)));
+}, "Test church addition");
+
+// matrix_test(function (a, b) {
+//     return a - b;
+// }, function (a, b) {
+//     return church.nat.toNative(minus(church.nat.make(a))(church.nat.make(b)));
+// });
+
+matrix_test(function (a, b) {
+    return a * b;
+}, function (a, b) {
+    return church.nat.toNative(church.nat.mult(church.nat.make(a))(church.nat.make(b)));
+}, "Test church multiplication");
+
+// very slow for some reason? (not that this implementation will ever be)
+matrix_test(function (a, b) {
+    return Math.pow(a, b);
+}, function (a, b) {
+    return church.nat.toNative(church.nat.expt(church.nat.make(a))(church.nat.make(b)));
+}, "Test church exponentiation", 7);
+
+
+// -------------------------------------------------------
+// Factorial function written similar to how the y-combinator works
+function factorial (x) {
+    var g = function (h) {
+        var f = function (n) {
+            if (n < 2) {
+                return 1;
+            } else {
+                return n * h(h)(n - 1);
+            }
+        };
+        return f;
+    };
+    return g(g)(x);
+}
+
+var i;
+for (i = 0; i < 10; i += 1) {
+    console.log(factorial(i));
+}

Racket/DFA.rkt

@@ -43,12 +43,16 @@
     #:description "dfa state transition"
     (pattern (in (~optional ->) out:id)))
 
-  (define-syntax-class state
+  (define-splicing-syntax-class state
     #:description "dfa state"
-    (pattern (name:id (~optional (~seq (~and #:end end?))) trans:transition ...+)
+    (pattern (name:id #:end trans:transition ...+)
+             #:with end? #'#t
+             #:with (in ...) #'(trans.in ...)
+             #:with (out ...) #'(trans.out ...))
+    (pattern (name:id trans:transition ...+)
+             #:with end? #'#f
              #:with (in ...) #'(trans.in ...)
              #:with (out ...) #'(trans.out ...)))
-  ;; (pattern (name:id (~seq (~and #:end end2?)) (~optional (~and #:end end?))))
   
   (syntax-parse stx
     [(_ name:id alpha:expr start:state rests:state ...)
@@ -56,59 +60,78 @@
                   (syntax->list
                    #'(start.name rests.name ...)))
                  "duplicate state names"
+     (with-syntax ([startSt (if (syntax->datum (attribute start.end?)) #'dfaStartEndState #'dfaStartState)]
+                   [restsSt (map (lambda (x) (if (syntax->datum x) #'dfaEndState #'dfaState)) (attribute rests.end?))])
      #'(define name
          (letrec ([start.name
-                   (dfaStartState
+                   (startSt
                     (match-lambda [start.in start.out] ...))]
                   [rests.name
-                   (dfaState
+                   ((if rests.end? dfaEndState dfaState) ;restsSt
                     (match-lambda [rests.in rests.out] ...))] ...)
-           (dfa 'alpha start.name '(start.name rests.name ...))))]))
+           (dfa 'alpha start.name '(start.name rests.name ...)))))]))
 
+;; Todo:
+;;  - error when 'in' pattern in the transition syntax class is not an element of alpha
+;;  - error when given no end state
+;;  - add keyword #:dead to create a dead state: (define-dfa n (0 1) (s0 #:dead))
+;;  - check to ensure all transitions goto a valid state name; fail otherwise
+;;  - check to ensure all transitions 'come from' a valid input; fail otherwise
 ;; ----------------------------------------------------------------------------
 
-(define-dfa odd-binary (0 1)
-  [s0 (0 -> s0)
-      (1 -> s1)]
-  [s1 (0 -> s0)
+;; Odd binary dfa expansion
+;(define odd-dfa
+;  (letrec ([s0 (dfaStartState (match-lambda [0 s0]
+;                                            [1 s1]))]
+;           [s1 (dfaEndState (match-lambda [0 s0]
+;                                          [1 s1]))])
+;    (dfa '(0 1) s0 '(s0 s1))))
+
+;; Even binary dfa expansion
+;(define even-dfa
+;  (letrec ([s0 (dfaStartEndState (match-lambda [0 s0]
+;                                               [1 s1]))]
+;           [s1 (dfaState (match-lambda [0 s0]
+;                                       [1 s1]))])
+;    (dfa '(0 1) s0 '(s0 s1 s2))))
+
+;; Even binary DFA
+(define-dfa even-dfa (0 1)
+  [s0 (0 -> s1)
+      (1 -> s2)]
+  [s1 #:end
+      (0 -> s1)
+      (1 -> s2)]
+  [s2 (0 -> s1)
+      (1 -> s2)])
+
+;; Odd binary DFA
+(define-dfa odd-dfa (0 1)
+  [s0 (0 -> s2)
       (1 -> s1)]
-  [s2 #:end
+  [s1 #:end
       (0 -> s2)
       (1 -> s1)]
-  [s3 #:dead (0 -> s3) (1 -> s3)])
+  [s2 (0 -> s2)
+      (1 -> s1)])
 
-;; Odd binary dfa expansion
-(define odd-dfa
-  (letrec ([s0 (dfaStartState (match-lambda [0 s0]
-                                            [1 s1]))]
-           [s1 (dfaEndState (match-lambda [0 s0]
-                                          [1 s1]))])
-    (dfa '(0 1) s0 '(s0 s1))))
+;; Only epsilon (empty) DFA
+;; (define (empty-dfa name xs)
+;;   (define-dfa name xs
+;;     [s0 #:end
+;;         (_ -> s1)]
+;;     [s1 #:dead]))
 
-;; Even binary dfa expansion
-(define even-dfa
-  (letrec ([s0 (dfaStartState (match-lambda [0 s0]
-                                               [1 s1]))]
-           [s1 (dfaState (match-lambda [0 s2]
-                                       [1 s1]))]
-           [s2 (dfaEndState (match-lambda [0 s0]
-                                          [1 s1]))])
-    (dfa '(0 1) s0 '(s0 s1 s2))))
-
-;; Odd binary dfa macro
-;; (define-dfa odd-dfa (0 1)
-;;      [s0 (0 -> s0)
-;;          (1 -> s1)]
-;;      [s1 end
-;;          (0 -> s0)
-;;          (1 -> s1)])
-
-;; ;; Even binary dfa macro
-;; (define-dfa even-dfa (0 1)
-;;      [s0 (0 -> s0)
-;;          (1 -> s1)]
-;;      [s1 (0 -> s2)
-;;          (1 -> s1)]
-;;      [s2 end
-;;          (0 -> s0)
-;;          (1 -> s1)])
+;; ----------------------------------------------------------------------------
+;; Some simple tests
+
+(define (integer->binary-list n)
+  (define (ibl n acc)
+    (cond [(zero? n) acc]
+          [else (ibl (quotient n 2) (cons (modulo n 2) acc))]))
+  (if (zero? n) '(0) (ibl n '())))
+
+(for ([i 1000])
+  (displayln (compute-dfa even-dfa (integer->binary-list i)))
+  (displayln (compute-dfa odd-dfa  (integer->binary-list i)))
+  (newline))

Racket/church-booleans-lazy.rkt

@@ -0,0 +1,50 @@
+#lang lazy
+
+;; Implementation of booleans with only the use of define and lambda
+
+(define my-true (lambda (x)
+                  (lambda (y) x)))
+(define my-false (lambda (x)
+                   (lambda (y) y)))
+
+(define (to-built-in-bool a)
+  ((a #t) #f))
+
+(define (not a)
+  (lambda (x)
+    (lambda (y)
+      ((a y) x))))
+
+(define (and-op a b)
+  ((a b) a))
+
+(define (my-and . xs)
+  (foldr and-op my-true xs))
+
+(define (or-op a b)
+  ((a a) b))
+
+(define (my-or . xs)
+  (foldr or-op my-false xs))
+
+;;
+;; Testing the functions
+;;
+
+(displayln "Testing and: should output false then #f on the next line indicating and (as well as and-op) did not evaluate its second argument")
+(to-built-in-bool
+ (my-and
+  (begin (displayln 'false)
+         my-false)
+  (begin (displayln 'what)
+         my-true)))
+
+(newline)
+
+(displayln "Testing or: should output true then #t on the next line indicating or (and or-op) did not evaluate its second argument")
+(to-built-in-bool
+ (my-or
+  (begin (displayln 'true)
+         my-true)
+  (begin (displayln 'what)
+         my-false)))

Racket/church-booleans.rkt

@@ -0,0 +1,74 @@
+#lang racket
+
+;; (C) Copyright Collin J. Doering 2014
+;;
+;; 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/>.
+
+;; File: church-booleans.rkt
+;; Author: Collin J. Doering <collin.doering@rekahsoft.ca>
+;; Date: Oct 28, 2014
+
+;; Implementation of booleans with only the use of define and lambda
+
+(define my-true (lambda (x)
+                  (lambda (y) x)))
+(define my-false (lambda (x)
+                   (lambda (y) y)))
+
+(define (to-built-in-bool a)
+  ((a #t) #f))
+
+(define (not a)
+  (lambda (x)
+    (lambda (y)
+      (((a) y) x))))
+
+(define (and-op a b)
+  (let ([evaled-a (a)])
+    ((evaled-a (b)) evaled-a)))
+
+(define (my-and . xs)
+  (foldr and-op my-true xs))
+
+(define (or-op a b)
+  (let ([evaled-a (a)])
+    ((evaled-a evaled-a) (b))))
+
+(define (my-or . xs)
+  (foldr or-op my-false xs))
+
+;; (lazy-fun (f x1 ... xn) body) => macro with name "f-lazy" generated which is like the lazy-funcall macro
+;; (lazy-funcall f x1 ... xn) ==> (f (lambda () x1) ... (lambda () xn))
+
+;;
+;; Testing the functions
+;;
+
+(displayln "Testing and: should output false then #f on the next line indicating and (as well as and-op) did not evaluate its second argument")
+(to-built-in-bool
+ (my-and
+  (begin (displayln 'false)
+         my-false)
+  (begin (displayln 'what)
+         my-true)))
+
+(newline)
+
+(displayln "Testing or: should output true then #t on the next line indicating or (and or-op) did not evaluate its second argument")
+(to-built-in-bool
+ (my-or
+  (begin (displayln 'true)
+         my-true)
+  (begin (displayln 'what)
+         my-false)))

Racket/macros.rkt

@@ -42,3 +42,16 @@
 (define-syntax (mylet2 stx)
   (syntax-parse stx
     [(_ ((var:id rhs:expr) ...) body ...+) #'((lambda (var ...) body ...) rhs ...)]))
+
+(define-syntax (mycond stx)
+  (syntax-parse stx #:datum-literals (else)
+    [(_) #'(void)]
+    [(_ (else en:expr)) #'en]
+    [(_ (p e:expr) (p1 e1:expr) ...) #'(if p e (mycond (p1 e1) ...))]))
+
+;; (module+ test
+;;   (test-suite "mycond macro"
+;;     (test-case "mycond basecase"
+;;                (check-true (void? (mycond)) "mycond when called with no arguments should return void")
+;;                (check-eq (mycond [else 'val]) 'val ""))
+;;     (test-case "mycond else")))