diff --git a/lisp/lang/dlambda-test.lisp b/lisp/lang/dlambda-test.lisp index f779f9a..0c0748d 100644 --- a/lisp/lang/dlambda-test.lisp +++ b/lisp/lang/dlambda-test.lisp @@ -4,94 +4,94 @@ (setq assertions (unit-tester-assertions)) (setq tests - (list + (let ((arguments (gensym))) + (list - (defun empty-dlambda () - (call assertions :assert-equal - '(lambda (&rest arguments) (case (first arguments))) + (defun empty-dlambda () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) (case (first ,arguments))) - (dlambda))) + (dlambda))) - (defun dlambda-default-method-only () - (call assertions :assert-equal - '(lambda (&rest arguments) - (case (first arguments) - (t (apply (lambda () (print "nothing")) arguments)))) + (defun dlambda-default-method-only () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) + (case (first ,arguments) + (t (apply (lambda () (print "nothing")) ,arguments)))) - (dlambda - (t () (print "nothing"))))) + (dlambda + (t () (print "nothing"))))) - (defun dlambda-named-method-only () - (call assertions :assert-equal - '(lambda (&rest arguments) - (case (first arguments) - (:write (apply (lambda () (print "something")) (rest arguments))))) + (defun dlambda-named-method-only () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) + (case (first ,arguments) + (:write (apply (lambda () (print "something")) (rest ,arguments))))) - (dlambda - (:write () (print "something"))))) + (dlambda + (:write () (print "something"))))) - (defun dlambda-many-named-methods () - (call assertions :assert-equal - '(lambda (&rest arguments) - (case (first arguments) - (:write1 (apply (lambda () (print "something")) (rest arguments))) - (:write2 (apply (lambda () (print "something")) (rest arguments))) - (:write3 (apply (lambda () (print "something")) (rest arguments))))) + (defun dlambda-many-named-methods () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) + (case (first ,arguments) + (:write1 (apply (lambda () (print "something")) (rest ,arguments))) + (:write2 (apply (lambda () (print "something")) (rest ,arguments))) + (:write3 (apply (lambda () (print "something")) (rest ,arguments))))) - (dlambda - (:write1 () (print "something")) - (:write2 () (print "something")) - (:write3 () (print "something"))))) + (dlambda + (:write1 () (print "something")) + (:write2 () (print "something")) + (:write3 () (print "something"))))) - (defun dlambda-named-and-default-method () - (call assertions :assert-equal - '(lambda (&rest arguments) - (case (first arguments) - (:write (apply (lambda () (print "something")) (rest arguments))) - (t (apply (lambda () (print "nothing")) arguments)))) + (defun dlambda-named-and-default-method () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) + (case (first ,arguments) + (:write (apply (lambda () (print "something")) (rest ,arguments))) + (t (apply (lambda () (print "nothing")) ,arguments)))) - (dlambda - (:write () (print "something")) - (t () (print "nothing"))))) + (dlambda + (:write () (print "something")) + (t () (print "nothing"))))) - (defun dlambda-methods-with-arguments () - (call assertions :assert-equal - '(lambda (&rest arguments) - (case (first arguments) - (:write (apply (lambda (message) (print message)) (rest arguments))) - (t (apply (lambda (&rest messages) (print messages)) arguments)))) + (defun dlambda-methods-with-arguments () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) + (case (first ,arguments) + (:write (apply (lambda (message) (print message)) (rest ,arguments))) + (t (apply (lambda (&rest messages) (print messages)) ,arguments)))) - (dlambda - (:write (message) (print message)) - (t (&rest messages) (print messages))))) + (dlambda + (:write (message) (print message)) + (t (&rest messages) (print messages))))) - (defun dlambda-methods-with-multiple-arguments () - (call assertions :assert-equal - '(lambda (&rest arguments) - (case (first arguments) - (:write - (apply - (lambda (message &rest other-stuff) - (print message) - (print other-stuff)) - (rest arguments))) - (t - (apply - (lambda (message1 message2 &rest other-stuff) - (print message1) - (print message2) - (print other-stuff)) - arguments)))) + (defun dlambda-methods-with-multiple-arguments () + (call assertions :assert-gensym-equal + `(lambda (&rest ,arguments) + (case (first ,arguments) + (:write + (apply + (lambda (message &rest other-stuff) + (print message) + (print other-stuff)) + (rest ,arguments))) + (t + (apply + (lambda (message1 message2 &rest other-stuff) + (print message1) + (print message2) + (print other-stuff)) + ,arguments)))) - (dlambda - (:write (message &rest other-stuff) - (print message) - (print other-stuff)) - (t (message1 message2 &rest other-stuff) - (print message1) - (print message2) - (print other-stuff))))))) + (dlambda + (:write (message &rest other-stuff) + (print message) + (print other-stuff)) + (t (message1 message2 &rest other-stuff) + (print message1) + (print message2) + (print other-stuff)))))))) -(setq tester (unit-tester tests)) -(call tester :run) +(call (unit-tester tests)) diff --git a/lisp/lang/dlambda.lisp b/lisp/lang/dlambda.lisp index 89726dd..9f11c4b 100644 --- a/lisp/lang/dlambda.lisp +++ b/lisp/lang/dlambda.lisp @@ -2,22 +2,16 @@ ;; This is based on the dlambda macro presented in "Let Over Lambda" by Doug Hoyte. -(let - ((add-method-clause - (lambda (method) - (cons (first method) - (list - (cons 'apply - (cons (cons 'lambda (rest method)) - (list - (if (equal t (car method)) - 'arguments - '(rest arguments)))))))))) +(defmacro dlambda (&rest methods) + (let ((arguments (gensym))) - (defmacro dlambda (&rest methods) - (cons 'lambda - (cons '(&rest arguments) - (list - (cons 'case - (cons '(first arguments) - (mapcar add-method-clause methods)))))))) + `(lambda (&rest ,arguments) + (case (first ,arguments) + ,@(mapcar + (lambda (method) + `(,(first method) + (apply (lambda ,@(rest method)) + ,(if (equal t (first method)) + arguments + `(rest ,arguments))))) + methods))))) diff --git a/lisp/random/structure.lisp b/lisp/random/structure.lisp index 5c66757..93bc049 100644 --- a/lisp/random/structure.lisp +++ b/lisp/random/structure.lisp @@ -2,8 +2,8 @@ (load "../lang/functions.lisp") (defmacro keys (&rest fields) - (list 'let (mapcar 'list fields) - '(dlambda + `(let ,(mapcar 'list fields) + (dlambda (:get (field) (eval field)) (:set (field value) (set field value))))) diff --git a/lisp/unit/unit-tester.lisp b/lisp/unit/unit-tester.lisp index 8ae2462..ac44b73 100644 --- a/lisp/unit/unit-tester.lisp +++ b/lisp/unit/unit-tester.lisp @@ -26,6 +26,9 @@ (:assert-equal (expected actual) (call public-static :assert 'equal expected actual)) + (:assert-gensym-equal (expected actual) + (call public-static :assert 'gensym-equal expected actual)) + (:assert (comparison operand1 operand2) (if (call comparison operand1 operand2) t @@ -59,4 +62,7 @@ (setq public (dlambda (:run () - (apply 'and (call private :run-suite suite)))))))) + (apply 'and (call private :run-suite suite))) + + (t () + (call public :run))))))) diff --git a/src/function/builtin/predicate/GENSYM_EQUAL.java b/src/function/builtin/predicate/GENSYM_EQUAL.java new file mode 100644 index 0000000..d6f1f29 --- /dev/null +++ b/src/function/builtin/predicate/GENSYM_EQUAL.java @@ -0,0 +1,96 @@ +package function.builtin.predicate; + +import static function.builtin.GENSYM.GENSYM_PREFIX; +import static sexpression.Nil.NIL; +import static sexpression.Symbol.T; + +import java.util.*; +import java.util.Map.Entry; +import java.util.regex.*; + +import function.*; +import sexpression.*; + +@FunctionNames({ "GENSYM-EQUAL", "GENSYM-EQUAL?" }) +public class GENSYM_EQUAL extends LispFunction { + + private ArgumentValidator argumentValidator; + + public GENSYM_EQUAL(String name) { + this.argumentValidator = new ArgumentValidator(name); + this.argumentValidator.setExactNumberOfArguments(2); + } + + @Override + public SExpression call(Cons argumentList) { + argumentValidator.validate(argumentList); + + Cons rest = (Cons) argumentList.getRest(); + SExpression firstArgument = argumentList.getFirst(); + SExpression secondArgument = rest.getFirst(); + + return gensymEqual(firstArgument, secondArgument); + } + + private SExpression gensymEqual(SExpression firstArgument, SExpression secondArgument) { + String firstEqualized = equalizeGensyms(firstArgument); + String secondEqualized = equalizeGensyms(secondArgument); + + return firstEqualized.equals(secondEqualized) ? T : NIL; + } + + private String equalizeGensyms(SExpression expression) { + GensymEqualizer equalizer = new GensymEqualizer(expression.toString()); + + return equalizer.equalize(); + } + + private static class GensymEqualizer { + + private static final String GENSYM_REGEX = Pattern.quote(GENSYM_PREFIX) + "[0-9]+"; + + Map gensymAliases; + Matcher matcher; + String expression; + int counter; + + public GensymEqualizer(String expression) { + this.gensymAliases = new HashMap<>(); + this.matcher = Pattern.compile(GENSYM_REGEX).matcher(expression); + this.expression = expression; + this.counter = 0; + } + + public String equalize() { + createGensymAliases(); + + return equalizeGensyms(); + } + + private void createGensymAliases() { + while (matcher.find()) + createAliasForGensym(); + } + + private void createAliasForGensym() { + String gensym = matcher.group(); + + if (isNewGensym(gensym)) + gensymAliases.put(gensym, GENSYM_PREFIX + (counter++)); + } + + private boolean isNewGensym(String gensym) { + return !gensymAliases.containsKey(gensym); + } + + private String equalizeGensyms() { + String equalizedExpression = expression; + + for (Entry entry : gensymAliases.entrySet()) + equalizedExpression = equalizedExpression.replace(entry.getKey(), entry.getValue()); + + return equalizedExpression; + } + } + +} diff --git a/src/table/FunctionTable.java b/src/table/FunctionTable.java index b8e46dc..cedbe62 100644 --- a/src/table/FunctionTable.java +++ b/src/table/FunctionTable.java @@ -34,6 +34,7 @@ public class FunctionTable { allBuiltIns.add(FIRST.class); allBuiltIns.add(FUNCALL.class); allBuiltIns.add(GENSYM.class); + allBuiltIns.add(GENSYM_EQUAL.class); allBuiltIns.add(NUMERIC_GREATER.class); allBuiltIns.add(IF.class); allBuiltIns.add(LAMBDA.class); diff --git a/test/function/builtin/predicate/GENSYM_EQUALTester.java b/test/function/builtin/predicate/GENSYM_EQUALTester.java new file mode 100644 index 0000000..92d023b --- /dev/null +++ b/test/function/builtin/predicate/GENSYM_EQUALTester.java @@ -0,0 +1,159 @@ +package function.builtin.predicate; + +import static testutil.TestUtilities.evaluateString; +import static testutil.TypeAssertions.*; + +import org.junit.Test; + +import function.ArgumentValidator.*; + +public class GENSYM_EQUALTester { + + @Test + public void gensymEqualWithTwoEqualAtoms() { + String input = "(gensym-equal 'a 'a)"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoEqualAtomsAndAlias() { + String input = "(gensym-equal? 'a 'a)"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoUnequalAtoms() { + String input = "(gensym-equal 'a 'b)"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoEqualNumbers() { + String input = "(gensym-equal -4 -4)"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoUnequalNumbers() { + String input = "(gensym-equal +5 +7)"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoEqualStrings() { + String input = "(gensym-equal \"potato\" \"potato\")"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoUnequalStrings() { + String input = "(gensym-equal \"tomato\" \"potato\")"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoDifferentCasedStrings() { + String input = "(gensym-equal \"Potato\" \"potato\")"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithAtomAndList() { + String input = "(gensym-equal \"string\" '(m i k e))"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithListAndAtom() { + String input = "(gensym-equal '(m i k e) \"string\")"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoEqualLists() { + String input = "(gensym-equal '(1 2 3) '(1 2 3))"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoUnequalLists() { + String input = "(gensym-equal '(1 2 3) '(1 3 3))"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithTwoEqualNestedLists() { + String input = "(gensym-equal '(1 ((2) 3)) '(1 ((2) 3)))"; + + assertT(evaluateString(input)); + } + + @Test(expected = TooManyArgumentsException.class) + public void gensymEqualWithTooManyArguments() { + evaluateString("(gensym-equal 1 2 3)"); + } + + @Test(expected = TooFewArgumentsException.class) + public void gensymEqualWithTooFewArguments() { + evaluateString("(gensym-equal 1)"); + } + + @Test + public void gensymEqualWithGensyms() { + String input = "(gensym-equal (gensym) (gensym))"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithNestedGensyms() { + String input = "(gensym-equal `(1 ,(gensym) (2 ,(gensym))) `(1 ,(gensym) (2 ,(gensym))))"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithUnmatchedGensymPositions() { + String input = "(gensym-equal (let ((one (gensym))) `(,one ,one))" + + " (let ((one (gensym)) (two (gensym))) `(,one ,two)))"; + + assertNil(evaluateString(input)); + } + + @Test + public void gensymEqualWithMatchedGensymPositions() { + String input = "(gensym-equal (let ((one (gensym))) `(,one ,one))" + + " (let ((one (gensym)) (two (gensym))) `(,one ,one)))"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithComplexMatchedGensymPositions() { + String input = "(gensym-equal (let ((x (gensym)) (y (gensym)) (z (gensym))) `(,x (,y ,z)))" + + " (let ((a (gensym)) (b (gensym)) (c (gensym))) `(,c (,a ,b))))"; + + assertT(evaluateString(input)); + } + + @Test + public void gensymEqualWithComplexUnmatchedGensymPositions() { + String input = "(gensym-equal (let ((x (gensym)) (y (gensym)) (z (gensym))) `(,x , y (,z ,z)))" + + " (let ((a (gensym)) (b (gensym)) (c (gensym))) `(,a ,c (,b ,c))))"; + + assertNil(evaluateString(input)); + } + +}