commit a61758ad6528817e5e2f674a9b0ac7b54fe6caa0
parent 615500209f78b80f9dd42fd5deffcc4990297bd0
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 12 Mar 2011 23:28:08 -0300
Extracted out the equivalence up to mutation features from kground.c to a new file kgequalp.c (and .h).
Diffstat:
5 files changed, 229 insertions(+), 186 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -10,7 +10,7 @@ MYLIBS=
CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
- kground.o kghelpers.o kgbooleans.o kgeqp.o
+ kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o
KRN_T= klisp
KRN_O= klisp.o
@@ -67,10 +67,12 @@ krepl.o: krepl.c krepl.h kcontinuation.h kstate.h kobject.h keval.h klisp.h \
kread.h kwrite.h kenvironment.h
kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.h \
kpair.h kapplicative.h koperative.h ksymbol.h kerror.h kghelpers.h \
- kgbooleans.h kgeqp.h
+ kgbooleans.h kgeqp.h kgequalp.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h kstate.h klisp.h kpair.h \
kapplicative.h koperative.h kerror.h kobject.h ksymbol.h
kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h
kgeqp.o: kgeqp.c kgeqp.c kghelpers.h kstate.h klisp.h \
- kobject.h kerror.h kpair.h kcontinuation.h
-\ No newline at end of file
+ kobject.h kerror.h kpair.h kcontinuation.h
+kgequalp.o: kgequalp.c kgequalp.c kghelpers.h kstate.h klisp.h \
+ kobject.h kerror.h kpair.h kcontinuation.h kgeqp.h kstring.h
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -18,6 +18,10 @@
#include "klisp.h"
#include "kghelpers.h"
+/* 4.2.1 eq? */
+/* TEMP: for now it takes only two argument */
+void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
/* Helper (also used in equal?) */
/* TEMP: for now this is the same as tv_equal,
later it will change with numbers and immutable objects */
@@ -26,8 +30,4 @@ inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
return (tv_equal(obj1, obj2));
}
-/* 4.2.1 eq? */
-/* TEMP: for now it takes only two argument */
-void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-
#endif
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -0,0 +1,190 @@
+/*
+** kgequalp.h
+** Equivalence up to mutation features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kground.h"
+#include "kpair.h"
+#include "kstring.h" /* for kstring_equalp */
+#include "kcontinuation.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgeqp.h" /* for eq2p */
+#include "kgequalp.h"
+
+/* 4.3.1 equal? */
+
+/*
+** equal? is O(n) where n is the number of pairs.
+** Based on [1] "A linear algorithm for testing equivalence of finite automata"
+** by J.E. Hopcroft and R.M.Karp
+** List merging from [2] "A linear list merging algorithm"
+** by J.E. Hopcroft and J.D. Ullman
+** Idea to look up these papers from srfi 85:
+** "Recursive Equivalence Predicates" by William D. Clinger
+*/
+void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv)
+{
+ (void) denv;
+ bind_2p(K, "equal?", ptree, obj1, obj2);
+ bool res = equal2p(K, obj1, obj2);
+ kapply_cc(K, b2tv(res));
+}
+
+
+/*
+** Helpers
+**
+** See [2] for details of the list merging algorithm.
+** Here are the implementation details:
+** The marks of the pairs are used to store the nodes of the trees
+** that represent the set of previous comparations of each pair.
+** They serve the function of the array in [2].
+** If a pair is unmarked, it was never compared (empty comparison set).
+** If a pair is marked, the mark object is either (#f . parent-node)
+** if the node is not the root, and (#t . n) where n is the number
+** of elements in the set, if the node is the root.
+** This pair also doubles as the "name" of the set in [2].
+*/
+
+/* find "name" of the set of this obj, if there isn't one create it,
+ if there is one, flatten its branch */
+inline TValue equal_find(klisp_State *K, TValue obj)
+{
+ /* GC: should root obj */
+ if (kis_unmarked(obj)) {
+ /* object wasn't compared before, create new set */
+ TValue new_node = kcons(K, KTRUE, i2tv(1));
+ kset_mark(obj, new_node);
+ return new_node;
+ } else {
+ TValue node = kget_mark(obj);
+
+ /* First obtain the root and a list of all the other objects in this
+ branch, as said above the root is the one with #t in its car */
+ /* NOTE: the stack is being used, so we must remember how many pairs we
+ push, we can't just pop 'till is empty */
+ int np = 0;
+ while(kis_false(kcar(node))) {
+ ks_spush(K, node);
+ node = kcdr(node);
+ ++np;
+ }
+ TValue root = node;
+
+ /* set all parents to root, to flatten the branch */
+ while(np--) {
+ node = ks_spop(K);
+ kset_cdr(node, root);
+ }
+ return root;
+ }
+}
+
+/* merge the smaller set into the big one, if both are equal just pick one */
+inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
+{
+ /* K isn't needed but added for consistency */
+ (void)K;
+ int32_t size1 = ivalue(kcdr(root1));
+ int32_t size2 = ivalue(kcdr(root2));
+ TValue new_size = i2tv(size1 + size2);
+
+ if (size1 < size2) {
+ /* add root1 set (the smaller one) to root2 */
+ kset_cdr(root2, new_size);
+ kset_car(root1, KFALSE);
+ kset_cdr(root1, root2);
+ } else {
+ /* add root2 set (the smaller one) to root1 */
+ kset_cdr(root1, new_size);
+ kset_car(root2, KFALSE);
+ kset_cdr(root2, root1);
+ }
+}
+
+/* check to see if two objects were already compared, and return that. If they
+ weren't compared yet, merge their sets (and flatten their branches) */
+inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
+{
+ /* GC: should root root1 and root2 */
+ TValue root1 = equal_find(K, obj1);
+ TValue root2 = equal_find(K, obj2);
+ if (tv_equal(root1, root2)) {
+ /* they are in the same set => they were already compared */
+ return true;
+ } else {
+ equal_merge(K, root1, root2);
+ return false;
+ }
+}
+
+/*
+** See [1] for details, in this case the pairs form a possibly infinite "tree"
+** structure, and that can be seen as a finite automata, where each node is a
+** state, the car and the cdr are the transitions from that state to others,
+** and the leaves (the non-pair objects) are the final states.
+** Other way to see it is that, the key for determining equalness of two pairs
+** is: Check to see if they were already compared to each other.
+** If so, return #t, otherwise, mark them as compared to each other and
+** recurse on both cars and both cdrs.
+** The idea is that if assuming obj1 and obj2 are equal their components are
+** equal then they are effectively equal to each other.
+*/
+bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ assert(ks_sisempty(K));
+
+ /* the stack has the elements to be compaired, always in pairs.
+ So the top should be compared with the one below, the third with
+ the fourth and so on */
+ ks_spush(K, obj1);
+ ks_spush(K, obj2);
+
+ /* if the stacks becomes empty, all pairs of elements were equal */
+ bool result = true;
+
+ while(!ks_sisempty(K)) {
+ obj2 = ks_spop(K);
+ obj1 = ks_spop(K);
+
+ if (!eq2p(K, obj1, obj2)) {
+ if (ttispair(obj1) && ttispair(obj2)) {
+ /* if they were already compaired, consider equal for now
+ otherwise they are equal if both their cars and cdrs are */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ ks_spush(K, kcdr(obj1));
+ ks_spush(K, kcdr(obj2));
+ ks_spush(K, kcar(obj1));
+ ks_spush(K, kcar(obj2));
+ }
+ } else if (ttisstring(obj1) && ttisstring(obj2)) {
+ if (!kstring_equalp(obj1, obj2)) {
+ result = false;
+ break;
+ }
+ } else {
+ result = false;
+ break;
+ }
+ }
+ }
+
+ /* if result is false, the stack may not be empty */
+ ks_sclear(K);
+
+ unmark_tree(K, obj1);
+ unmark_tree(K, obj2);
+
+ return result;
+}
diff --git a/src/kgequalp.h b/src/kgequalp.h
@@ -0,0 +1,29 @@
+/*
+** kgequalp.h
+** Equivalence up to mutation features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgequalp_h
+#define kgequalp_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "klisp.h"
+#include "kghelpers.h"
+
+/* 4.3.1 equal? */
+/* TEMP: for now it takes only two argument */
+void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv);
+
+/* Helper (may be used in assoc and member) */
+/* compare two objects and check to see if they are "equal?". */
+bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -25,6 +25,7 @@
#include "kghelpers.h"
#include "kgbooleans.h"
#include "kgeqp.h"
+#include "kgequalp.h"
/*
** This section will roughly follow the report and will reference the
@@ -33,184 +34,6 @@
/* TODO: split in different files for each module */
/*
-** 4.3 Equivalence up to mutation
-*/
-
-/* 4.3.1 equal? */
-
-/* TEMP: for now it takes only two argument */
-/*
-** equal? is O(n) where n is the number of pairs.
-** Based on [1] "A linear algorithm for testing equivalence of finite automata"
-** by J.E. Hopcroft and R.M.Karp
-** List merging from [2] "A linear list merging algorithm"
-** by J.E. Hopcroft and J.D. Ullman
-** Idea to look up these papers from srfi 85:
-** "Recursive Equivalence Predicates" by William D. Clinger
-*/
-
-/* Helper */
-/* compare two objects and check to see if they are "equal?". */
-inline bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
-
-void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv)
-{
- (void) denv;
- bind_2p(K, "equal?", ptree, obj1, obj2);
- bool res = equal2p(K, obj1, obj2);
- kapply_cc(K, b2tv(res));
-}
-
-
-/*
-** Helpers
-**
-** See [2] for details of the list merging algorithm.
-** Here are the implementation details:
-** The marks of the pairs are used to store the nodes of the trees
-** that represent the set of previous comparations of each pair.
-** They serve the function of the array in [2].
-** If a pair is unmarked, it was never compared (empty comparison set).
-** If a pair is marked, the mark object is either (#f . parent-node)
-** if the node is not the root, and (#t . n) where n is the number
-** of elements in the set, if the node is the root.
-** This pair also doubles as the "name" of the set in [2].
-*/
-
-/* find "name" of the set of this obj, if there isn't one create it,
- if there is one, flatten its branch */
-inline TValue equal_find(klisp_State *K, TValue obj)
-{
- /* GC: should root obj */
- if (kis_unmarked(obj)) {
- /* object wasn't compared before, create new set */
- TValue new_node = kcons(K, KTRUE, i2tv(1));
- kset_mark(obj, new_node);
- return new_node;
- } else {
- TValue node = kget_mark(obj);
-
- /* First obtain the root and a list of all the other objects in this
- branch, as said above the root is the one with #t in its car */
- /* NOTE: the stack is being used, so we must remember how many pairs we
- push, we can't just pop 'till is empty */
- int np = 0;
- while(kis_false(kcar(node))) {
- ks_spush(K, node);
- node = kcdr(node);
- ++np;
- }
- TValue root = node;
-
- /* set all parents to root, to flatten the branch */
- while(np--) {
- node = ks_spop(K);
- kset_cdr(node, root);
- }
- return root;
- }
-}
-
-/* merge the smaller set into the big one, if both are equal just pick one */
-inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
-{
- /* K isn't needed but added for consistency */
- (void)K;
- int32_t size1 = ivalue(kcdr(root1));
- int32_t size2 = ivalue(kcdr(root2));
- TValue new_size = i2tv(size1 + size2);
-
- if (size1 < size2) {
- /* add root1 set (the smaller one) to root2 */
- kset_cdr(root2, new_size);
- kset_car(root1, KFALSE);
- kset_cdr(root1, root2);
- } else {
- /* add root2 set (the smaller one) to root1 */
- kset_cdr(root1, new_size);
- kset_car(root2, KFALSE);
- kset_cdr(root2, root1);
- }
-}
-
-/* check to see if two objects were already compared, and return that. If they
- weren't compared yet, merge their sets (and flatten their branches) */
-inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
-{
- /* GC: should root root1 and root2 */
- TValue root1 = equal_find(K, obj1);
- TValue root2 = equal_find(K, obj2);
- if (tv_equal(root1, root2)) {
- /* they are in the same set => they were already compared */
- return true;
- } else {
- equal_merge(K, root1, root2);
- return false;
- }
-}
-
-/*
-** See [1] for details, in this case the pairs form a possibly infinite "tree"
-** structure, and that can be seen as a finite automata, where each node is a
-** state, the car and the cdr are the transitions from that state to others,
-** and the leaves (the non-pair objects) are the final states.
-** Other way to see it is that, the key for determining equalness of two pairs
-** is: Check to see if they were already compared to each other.
-** If so, return #t, otherwise, mark them as compared to each other and
-** recurse on both cars and both cdrs.
-** The idea is that if assuming obj1 and obj2 are equal their components are
-** equal then they are effectively equal to each other.
-*/
-inline bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
-{
- assert(ks_sisempty(K));
-
- /* the stack has the elements to be compaired, always in pairs.
- So the top should be compared with the one below, the third with
- the fourth and so on */
- ks_spush(K, obj1);
- ks_spush(K, obj2);
-
- /* if the stacks becomes empty, all pairs of elements were equal */
- bool result = true;
-
- while(!ks_sisempty(K)) {
- obj2 = ks_spop(K);
- obj1 = ks_spop(K);
-
- if (!eq2p(K, obj1, obj2)) {
- if (ttispair(obj1) && ttispair(obj2)) {
- /* if they were already compaired, consider equal for now
- otherwise they are equal if both their cars and cdrs are */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- ks_spush(K, kcdr(obj1));
- ks_spush(K, kcdr(obj2));
- ks_spush(K, kcar(obj1));
- ks_spush(K, kcar(obj2));
- }
- } else if (ttisstring(obj1) && ttisstring(obj2)) {
- if (!kstring_equalp(obj1, obj2)) {
- result = false;
- break;
- }
- } else {
- result = false;
- break;
- }
- }
- }
-
- /* if result is false, the stack may not be empty */
- ks_sclear(K);
-
- unmark_tree(K, obj1);
- unmark_tree(K, obj2);
-
- return result;
-}
-
-
-/*
** 4.4 Symbols
*/
