Browse Source

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>
master
Collin J. Doering 6 years ago
parent
commit
9c89ee6ac3
7 changed files with 610 additions and 47 deletions
  1. +1
    -1
      Clojure/rdm.clj
  2. +28
    -0
      ELisp/rdm.el
  3. +375
    -0
      JavaScript/rdm.js
  4. +69
    -46
      Racket/DFA.rkt
  5. +50
    -0
      Racket/church-booleans-lazy.rkt
  6. +74
    -0
      Racket/church-booleans.rkt
  7. +13
    -0
      Racket/macros.rkt

+ 1
- 1
Clojure/rdm.clj View File

@@ -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))


+ 28
- 0
ELisp/rdm.el View File

@@ -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!")))


+ 375
- 0
JavaScript/rdm.js View File

@@ -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));
}

+ 69
- 46
Racket/DFA.rkt View File

@@ -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))

+ 50
- 0
Racket/church-booleans-lazy.rkt View File

@@ -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)))

+ 74
- 0
Racket/church-booleans.rkt View File

@@ -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)))

+ 13
- 0
Racket/macros.rkt View File

@@ -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")))

Loading…
Cancel
Save