From 9c89ee6ac34d8bf1e7e27429a428f2e8dc711f15 Mon Sep 17 00:00:00 2001 From: "Collin J. Doering" Date: Mon, 2 Mar 2015 04:05:35 -0500 Subject: [PATCH] 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 --- Clojure/rdm.clj | 2 +- ELisp/rdm.el | 28 +++ JavaScript/rdm.js | 375 ++++++++++++++++++++++++++++++++ Racket/DFA.rkt | 115 ++++++---- Racket/church-booleans-lazy.rkt | 50 +++++ Racket/church-booleans.rkt | 74 +++++++ Racket/macros.rkt | 13 ++ 7 files changed, 610 insertions(+), 47 deletions(-) create mode 100644 ELisp/rdm.el create mode 100644 JavaScript/rdm.js create mode 100644 Racket/church-booleans-lazy.rkt create mode 100644 Racket/church-booleans.rkt 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")))