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