diff --git a/Clojure/rdm.clj b/Clojure/rdm.clj
index 957a110..95b10b4 100644
--- a/Clojure/rdm.clj
+++ b/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))
diff --git a/ELisp/rdm.el b/ELisp/rdm.el
new file mode 100644
index 0000000..3d3adde
--- /dev/null
+++ b/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 .
+
+;; File: rdm.el
+;; Author: Collin J. Doering
+;; 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!")))
+
diff --git a/JavaScript/rdm.js b/JavaScript/rdm.js
new file mode 100644
index 0000000..cb47931
--- /dev/null
+++ b/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 .
+*/
+
+/**
+ * File: rdm.js
+ * Author: Collin J. Doering
+ * 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));
+}
diff --git a/Racket/DFA.rkt b/Racket/DFA.rkt
index 082dd15..b92570a 100644
--- a/Racket/DFA.rkt
+++ b/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)
- (1 -> s1)]
- [s2 #:end
- (0 -> s2)
- (1 -> s1)]
- [s3 #:dead (0 -> s3) (1 -> s3)])
-
;; 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))))
+;(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 (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))))
+;(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))))
-;; Odd binary dfa macro
-;; (define-dfa odd-dfa (0 1)
-;; [s0 (0 -> s0)
-;; (1 -> s1)]
-;; [s1 end
-;; (0 -> s0)
-;; (1 -> s1)])
+;; 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)])
-;; ;; 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)])
+;; Odd binary DFA
+(define-dfa odd-dfa (0 1)
+ [s0 (0 -> s2)
+ (1 -> s1)]
+ [s1 #:end
+ (0 -> s2)
+ (1 -> s1)]
+ [s2 (0 -> s2)
+ (1 -> s1)])
+
+;; Only epsilon (empty) DFA
+;; (define (empty-dfa name xs)
+;; (define-dfa name xs
+;; [s0 #:end
+;; (_ -> s1)]
+;; [s1 #:dead]))
+
+;; ----------------------------------------------------------------------------
+;; 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))
diff --git a/Racket/church-booleans-lazy.rkt b/Racket/church-booleans-lazy.rkt
new file mode 100644
index 0000000..421bffc
--- /dev/null
+++ b/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)))
diff --git a/Racket/church-booleans.rkt b/Racket/church-booleans.rkt
new file mode 100644
index 0000000..5ef8fc7
--- /dev/null
+++ b/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 .
+
+;; File: church-booleans.rkt
+;; Author: Collin J. Doering
+;; 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)))
diff --git a/Racket/macros.rkt b/Racket/macros.rkt
index 2a2c55f..971edb0 100644
--- a/Racket/macros.rkt
+++ b/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")))