1 : /*
2 : Copyright (C) 2007, Bruce Ediger
3 :
4 : This file is part of cl.
5 :
6 : cl is free software; you can redistribute it and/or modify
7 : it under the terms of the GNU General Public License as published by
8 : the Free Software Foundation; either version 2 of the License, or
9 : (at your option) any later version.
10 :
11 : cl is distributed in the hope that it will be useful,
12 : but WITHOUT ANY WARRANTY; without even the implied warranty of
13 : MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 : GNU General Public License for more details.
15 :
16 : You should have received a copy of the GNU General Public License
17 : along with cl; if not, write to the Free Software
18 : Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 :
20 : */
21 : #include <stdio.h> /* NULL */
22 : #include <string.h> /* strcmp() */
23 :
24 : #include <node.h>
25 : #include <graph.h>
26 : #include <bracket_abstraction.h>
27 :
28 : bracket_abstraction_function default_bracket_abstraction = curry_bracket_abstraction;
29 :
30 : int
31 : var_appears_in_graph(struct node *var, struct node *tree)
32 5347818 : {
33 5347818 : int r = 0;
34 5347818 : switch (tree->typ)
35 : {
36 : case APPLICATION:
37 2687982 : r = var_appears_in_graph(var, tree->left)
38 : || var_appears_in_graph(var, tree->right);
39 2687982 : break;
40 : case COMBINATOR:
41 2659836 : if (var->cn == tree->cn)
42 : {
43 16122 : if (COMB_NONE == var->cn)
44 : {
45 16122 : if (var->name == tree->name)
46 5127 : r = 1;
47 : } else
48 0 : r = 1;
49 2643714 : } else if (var->name == tree->name)
50 0 : r = 1;
51 : break;
52 : case UNTYPED: /* XXX */
53 : default:
54 : break;
55 : }
56 5347818 : return r;
57 : }
58 :
59 : /* Curry-Feys bracket abstraction
60 : [x] x -> I
61 : [x] N -> K N, x not appearing in N
62 : [x] M N -> S ([x]M) ([x]N)
63 : */
64 : struct node *
65 : curry_bracket_abstraction(struct node *var, struct node *tree)
66 4227 : {
67 4227 : struct node *r = NULL;
68 4227 : switch (tree->typ)
69 : {
70 : case APPLICATION:
71 3646 : if (!var_appears_in_graph(var, tree))
72 : /* [x] A -> K A, x not appearing in A */
73 1578 : r = new_application(new_combinator(COMB_K), arena_copy_graph(tree));
74 : else {
75 2068 : r = new_application(
76 : new_application(
77 : new_combinator(COMB_S),
78 : curry_bracket_abstraction(var, tree->left)
79 : ),
80 : curry_bracket_abstraction(var, tree->right)
81 : );
82 : }
83 3646 : break;
84 : case COMBINATOR:
85 669 : if (var->cn == tree->cn && var->name == tree->name)
86 : /* [x] x -> I */
87 88 : r = new_combinator(COMB_I);
88 : else
89 : /* [x] N -> K N */
90 493 : r = new_application(
91 : new_combinator(COMB_K),
92 : COMB_NONE == tree->cn? new_term(tree->name): new_combinator(tree->cn)
93 : );
94 : break;
95 : case UNTYPED: /* XXX */
96 : default:
97 : break;
98 : }
99 4227 : return r;
100 : }
101 :
102 : /* Simple Turner bracket abstraction
103 : [x] x -> I
104 : [x] N x -> N x not appearing in N
105 : [x] N -> K N x not appearing in N
106 : [x] M N -> C ([x]M) N x appears only in M, not in N
107 : [x] M N -> B M ([x] N) x appears only in N, not in M
108 : [x] M N -> S ([x]M) ([x]N) x appears in both M and N
109 : */
110 : struct node *
111 : turner_bracket_abstraction(struct node *var, struct node *tree)
112 1497 : {
113 1497 : struct node *r = NULL;
114 1497 : switch (tree->typ)
115 : {
116 : case APPLICATION:
117 1482 : if (!var_appears_in_graph(var, tree))
118 : /* [x] N -> K N x not appearing in N */
119 10 : r = new_application(new_combinator(COMB_K), arena_copy_graph(tree));
120 : else {
121 : /* variable getting abstracted out appears somewhere */
122 1472 : if (var_appears_in_graph(var, tree->left))
123 : {
124 194 : if (var_appears_in_graph(var, tree->right))
125 : {
126 : /* [x] M N -> S ([x]M) ([x]N) x appears in both M and N */
127 13 : r = new_application(
128 : new_application(
129 : new_combinator(COMB_S),
130 : turner_bracket_abstraction(var, tree->left)
131 : ),
132 : turner_bracket_abstraction(var, tree->right)
133 : );
134 : } else {
135 : /* [x] M N -> C ([x]M) N x appears only in M, not in N */
136 181 : r = new_application(
137 : new_application(
138 : new_combinator(COMB_C),
139 : turner_bracket_abstraction(var, tree->left)
140 : ),
141 : arena_copy_graph(tree->right)
142 : );
143 : }
144 1278 : } else if (var_appears_in_graph(var, tree->right)) {
145 1302 : if (COMBINATOR == tree->right->typ && var->name == tree->right->name)
146 : {
147 : /* [x] N x -> N x not appearing in N */
148 24 : r = arena_copy_graph(tree->left);
149 : } else {
150 : /* [x] M N -> B M ([x] N) x appears only in N, not in M */
151 1254 : r = new_application(
152 : new_application(
153 : new_combinator(COMB_B),
154 : arena_copy_graph(tree->left)
155 : ),
156 : turner_bracket_abstraction(var, tree->right)
157 : );
158 : }
159 : }
160 : }
161 1482 : break;
162 : case COMBINATOR:
163 29 : if (var->cn == tree->cn && var->name == tree->name)
164 : /* [x] x -> I */
165 14 : r = new_combinator(COMB_I);
166 : else
167 : /* [x] N -> K N */
168 1 : r = new_application(
169 : new_combinator(COMB_K),
170 : COMB_NONE == tree->cn? new_term(tree->name): new_combinator(tree->cn)
171 : );
172 : break;
173 : case UNTYPED: /* XXX */
174 : default:
175 : break;
176 : }
177 1497 : return r;
178 : }
179 :
180 : /* "A 'new' abstraction algorithm", M.A. Price, H.Simmons
181 : This actually implements "The cooked G-Algorithm".
182 : "Grzegorgczyk" algorithm.
183 : [x] x -> I
184 : [x] Z -> K Z x not appearing in Z
185 : [x] Q x -> Q x not appearing in Q
186 : [x] Q P -> B Q ([x] P) x appears only in P, not in Q
187 : [x] Q P -> C ([x]Q) P x appears only in Q, not in P
188 : [x] Q P -> W((B(C([x]Q)))([x]P)) x appears in both P and Q
189 :
190 : Note that the last transformation could just as well have a
191 : different form.
192 : */
193 : struct node *
194 : grzegorczyk_bracket_abstraction(struct node *var, struct node *tree)
195 27 : {
196 27 : struct node *r = NULL;
197 27 : switch (tree->typ)
198 : {
199 : case APPLICATION:
200 25 : if (!var_appears_in_graph(var, tree))
201 : /* [x] Z -> K Z x not appearing in Z */
202 1 : r = new_application(new_combinator(COMB_K), arena_copy_graph(tree));
203 : else {
204 : /* variable getting abstracted out appears somewhere */
205 24 : if (var_appears_in_graph(var, tree->left))
206 : {
207 4 : if (var_appears_in_graph(var, tree->right))
208 : {
209 : /* [x] Q P -> W( (B(C([x]Q))) ([x]P)) x appears in both Q and P */
210 2 : r = new_application(
211 : new_combinator(COMB_W),
212 : new_application(
213 : new_application(
214 : new_combinator(COMB_B),
215 : new_application(
216 : new_combinator(COMB_C),
217 : grzegorczyk_bracket_abstraction(var, tree->left)
218 : )
219 : ),
220 : grzegorczyk_bracket_abstraction(var, tree->right)
221 : )
222 : );
223 : } else {
224 : /* [x] M N -> C ([x]M) N x appears only in M, not in N */
225 2 : r = new_application(
226 : new_application(
227 : new_combinator(COMB_C),
228 : grzegorczyk_bracket_abstraction(var, tree->left)
229 : ),
230 : arena_copy_graph(tree->right)
231 : );
232 : }
233 20 : } else if (var_appears_in_graph(var, tree->right)) {
234 35 : if (COMBINATOR == tree->right->typ && var->name == tree->right->name)
235 : {
236 : /* [x] N x -> N x not appearing in N */
237 15 : r = arena_copy_graph(tree->left);
238 : } else {
239 : /* [x] M N -> B M ([x] N) x appears only in N, not in M */
240 5 : r = new_application(
241 : new_application(
242 : new_combinator(COMB_B),
243 : arena_copy_graph(tree->left)
244 : ),
245 : grzegorczyk_bracket_abstraction(var, tree->right)
246 : );
247 : }
248 : }
249 : }
250 25 : break;
251 : case COMBINATOR:
252 3 : if (var->cn == tree->cn && var->name == tree->name)
253 : /* [x] x -> I */
254 1 : r = new_combinator(COMB_I);
255 : else
256 : /* [x] N -> K N */
257 1 : r = new_application(
258 : new_combinator(COMB_K),
259 : COMB_NONE == tree->cn? new_term(tree->name): new_combinator(tree->cn)
260 : );
261 : break;
262 : case UNTYPED: /* XXX */
263 : default:
264 : break;
265 : }
266 27 : return r;
267 : }
268 :
269 : /*
270 : [x] x -> B (T M) K
271 : [x] Z -> K Z x not appearing in Z
272 : [x] Q x -> Q x not appearing in Q
273 : [x] Q P -> B Q ([x] P) x appears only in P, not in Q
274 : [x] Q P -> B (T P) ([x]Q) x appears only in Q, not in P
275 : [x] Q P -> W(B (B (T ([x]P)) B) ([x]Q)) x appears in both Q and P
276 : */
277 : struct node *
278 : btmk_bracket_abstraction(struct node *var, struct node *tree)
279 0 : {
280 0 : struct node *r = NULL;
281 0 : switch (tree->typ)
282 : {
283 : case APPLICATION:
284 0 : if (!var_appears_in_graph(var, tree))
285 : /* [x] Z -> K Z x not appearing in Z */
286 0 : r = new_application(new_combinator(COMB_K), arena_copy_graph(tree));
287 : else {
288 : /* variable getting abstracted out appears somewhere */
289 0 : if (var_appears_in_graph(var, tree->left))
290 : {
291 0 : if (var_appears_in_graph(var, tree->right))
292 : {
293 : /* [x] Q P -> W(B (B (T ([x]P)) B) ([x]Q)) x appears in both Q and P */
294 0 : r = new_application(
295 : new_combinator(COMB_W),
296 : new_application(
297 : new_application(
298 : new_combinator(COMB_B),
299 : new_application(
300 : new_application(
301 : new_combinator(COMB_B),
302 : new_application(
303 : new_combinator(COMB_T),
304 : btmk_bracket_abstraction(var, tree->right)
305 : )
306 : ),
307 : new_combinator(COMB_B)
308 : )
309 : ),
310 : btmk_bracket_abstraction(var, tree->left)
311 : )
312 : );
313 : } else {
314 : /* [x] Q P -> B (T P) ([x]Q) x appears only in Q, not in P */
315 0 : r = new_application(
316 : new_application(
317 : new_combinator(COMB_B),
318 : new_application(
319 : new_combinator(COMB_T),
320 : arena_copy_graph(tree->right)
321 : )
322 : ),
323 : btmk_bracket_abstraction(var, tree->left)
324 : );
325 : }
326 0 : } else if (var_appears_in_graph(var, tree->right)) {
327 0 : if (COMBINATOR == tree->right->typ && var->name == tree->right->name)
328 : {
329 : /* [x] N x -> N x not appearing in N */
330 0 : r = arena_copy_graph(tree->left);
331 : } else {
332 : /* [x] M N -> B M ([x] N) x appears only in N, not in M */
333 0 : r = new_application(
334 : new_application(
335 : new_combinator(COMB_B),
336 : arena_copy_graph(tree->left)
337 : ),
338 : btmk_bracket_abstraction(var, tree->right)
339 : );
340 : }
341 : }
342 : }
343 0 : break;
344 : case COMBINATOR:
345 0 : if (var->cn == tree->cn && var->name == tree->name)
346 : /* [x] x -> B (T M) K */
347 0 : r = new_application(
348 : new_application(
349 : new_combinator(COMB_B),
350 : new_application(
351 : new_combinator(COMB_T),
352 : new_combinator(COMB_M)
353 : )
354 : ),
355 : new_combinator(COMB_K)
356 : );
357 : else
358 : /* [x] N -> K N */
359 0 : r = new_application(
360 : new_combinator(COMB_K),
361 : COMB_NONE == tree->cn? new_term(tree->name): new_combinator(tree->cn)
362 : );
363 : break;
364 : case UNTYPED: /* XXX */
365 : default:
366 : break;
367 : }
368 0 : return r;
369 : }
370 :
371 : /* return 1 if two graphs "equate", and 0 if they don't.
372 : * "Equate" means same tree structure (application-type nodes
373 : * in the same places, leaf (combinator) nodes in the same places),
374 : * and that combinator-type nodes in the same places have the same name.
375 : * Used only to determine whether to apply this rule:
376 : * [x] ((M L) (N L)) -> [x](S M N L) (M, N combinators)
377 : * in the Tromp Bracket Abstraction algorithm, below.
378 : */
379 : int
380 : equivalent_graphs(struct node *g1, struct node *g2)
381 8 : {
382 8 : int r = 0;
383 :
384 8 : if (g1->typ == g2->typ)
385 : {
386 7 : switch (g1->typ)
387 : {
388 : case APPLICATION:
389 2 : r = equivalent_graphs(g1->left, g2->left)
390 : && equivalent_graphs(g1->right, g2->right);
391 2 : break;
392 : case COMBINATOR:
393 5 : if (g1->cn == g2->cn && g1->name == g2->name)
394 2 : r = 1;
395 5 : break;
396 : case UNTYPED:
397 0 : r = 1; /* XXX - this can't consitute correct behavior, can it? */
398 : break;
399 : }
400 :
401 : }
402 :
403 8 : return r;
404 : }
405 :
406 :
407 : /* Apply the following set of 9 rules in decreasing order
408 : * of applicability:
409 : *
410 : * [x](S K M) -> S K (For all M)
411 : * [x] M -> K M (x not appearing in M)
412 : * [x] x -> I
413 : * [x] M x -> M (x not appearing in M)
414 : * [x] x M x -> [x] (S S K x M)
415 : * [x] (M (N L)) -> [x] (S ([x] M) N L) (M, N combinators)
416 : * [x] ((M N) L) -> [x] (S M ([x] L) N) (M, L combinators)
417 : * [x] ((M L) (N L)) -> [x](S M N L) (M, N combinators)
418 : * [x] M N -> S ([x] M) ([x] N)
419 : *
420 : * tromp_bracket_abstraction() examines the parse tree argument,
421 : * and returns a parse tree with the combinator named by var argument
422 : * abstracted out of the original parse tree. The returned parse tree
423 : * has no references to the original, and the original parse tree does
424 : * not get modified in the process.
425 : * Hey, only S, K and I end up in the final abstracted expression.
426 : * How could you incorporate B and C in it? If they helped Turner, maybe
427 : * they would help here.
428 : */
429 : struct node *
430 : tromp_bracket_abstraction(struct node *var, struct node *tree)
431 82 : {
432 82 : if (APPLICATION == tree->typ
433 : && APPLICATION == tree->left->typ
434 : && COMBINATOR == tree->left->left->typ
435 : && COMB_S == tree->left->left->cn
436 : && COMBINATOR == tree->left->right->typ
437 : && COMB_K == tree->left->right->cn
438 : )
439 : {
440 : /* [x] (S K M) -> S K */
441 1 : return new_application(new_combinator(COMB_S), new_combinator(COMB_K));
442 : }
443 :
444 :
445 :
446 81 : if (!var_appears_in_graph(var, tree))
447 : {
448 : /* [x] M -> K M when x doesn't appear in M */
449 30 : return new_application(new_combinator(COMB_K),
450 : arena_copy_graph(tree));
451 : }
452 :
453 51 : if (COMBINATOR == tree->typ && var->name == tree->name)
454 : {
455 : /* [x] x -> I */
456 7 : return new_combinator(COMB_I);
457 : }
458 :
459 44 : if (APPLICATION == tree->typ
460 : && COMBINATOR == tree->right->typ
461 : && var->name == tree->right->name
462 : && !var_appears_in_graph(var, tree->left)
463 : )
464 : {
465 : /* [x] M x -> M x not in M */
466 15 : return arena_copy_graph(tree->left);
467 : }
468 :
469 29 : if (APPLICATION == tree->typ
470 : && APPLICATION == tree->left->typ
471 : && COMBINATOR == tree->right->typ
472 : && var->name == tree->right->name
473 : && COMBINATOR == tree->left->left->typ
474 : && var->name == tree->left->left->name
475 : )
476 : {
477 : /* [x] (x M x) -> [x] (S S K x M) */
478 : struct node *r;
479 : struct node *disposable = new_application(
480 : new_application(
481 : new_application(
482 : new_application(
483 : new_combinator(COMB_S),
484 : new_combinator(COMB_S)
485 : ),
486 : new_combinator(COMB_K)
487 : ),
488 : new_term(var->name)
489 : ),
490 : arena_copy_graph(tree->left->right)
491 1 : );
492 1 : ++disposable->refcnt;
493 1 : r = tromp_bracket_abstraction(var, disposable);
494 1 : free_node(disposable);
495 1 : return r;
496 : }
497 :
498 28 : if (APPLICATION == tree->typ
499 : && COMBINATOR == tree->left->typ
500 : && COMB_NONE != tree->left->cn
501 : && APPLICATION == tree->right->typ
502 : && COMBINATOR == tree->right->left->typ
503 : && COMB_NONE != tree->right->left->cn
504 : )
505 : {
506 : /* [x] (M (N L)) -> [x] (S ([x] M) N L) (M, N combinators) */
507 : struct node *r;
508 : struct node *disposable = new_application(
509 : new_application(
510 : new_application(
511 : new_combinator(COMB_S),
512 : tromp_bracket_abstraction(var, tree->left)
513 : ),
514 : arena_copy_graph(tree->right->left)
515 : ),
516 : arena_copy_graph(tree->right->right)
517 2 : );
518 2 : r = tromp_bracket_abstraction(var, disposable);
519 2 : ++disposable->refcnt;
520 2 : free_node(disposable);
521 2 : return r;
522 : }
523 :
524 26 : if (APPLICATION == tree->typ
525 : && APPLICATION == tree->left->typ
526 : && COMBINATOR == tree->left->left->typ
527 : && COMB_NONE != tree->left->left->cn
528 : && COMBINATOR == tree->right->typ
529 : && COMB_NONE != tree->right->cn
530 : )
531 : {
532 : /* [x] ((M N) L) -> [x] (S M ([x] L) N) (M, L combinators) */
533 : struct node *r;
534 : struct node *disposable = new_application(
535 : new_application(
536 : new_application(
537 : new_combinator(COMB_S),
538 : arena_copy_graph(tree->left->left)
539 : ),
540 : tromp_bracket_abstraction(var, tree->right)
541 : ),
542 : arena_copy_graph(tree->left->right)
543 1 : );
544 1 : r = tromp_bracket_abstraction(var, disposable);
545 1 : ++disposable->refcnt;
546 1 : free_node(disposable);
547 1 : return r;
548 : }
549 :
550 25 : if (APPLICATION == tree->typ
551 : && APPLICATION == tree->left->typ
552 : && APPLICATION == tree->right->typ
553 : && COMBINATOR == tree->left->left->typ
554 : && COMBINATOR == tree->right->left->typ
555 : && equivalent_graphs(tree->left->right, tree->right->right)
556 :
557 : )
558 : {
559 : /* [x] ((M L) (N L)) -> [x](S M N L) (M, N combinators) */
560 : struct node *r;
561 : struct node *disposable = new_application(
562 : new_application(
563 : new_application(
564 : new_combinator(COMB_S),
565 : arena_copy_graph(tree->left->left)
566 : ),
567 : arena_copy_graph(tree->right->left)
568 : ),
569 : arena_copy_graph(tree->right->right)
570 1 : );
571 1 : r = tromp_bracket_abstraction(var, disposable);
572 1 : ++disposable->refcnt;
573 1 : free_node(disposable);
574 1 : return r;
575 : }
576 :
577 : /* XXX - does it really make sense for the final "rule" to not
578 : * have an if() block around it? */
579 :
580 : /* [x] M N -> S ([x] M) ([x] N) */
581 24 : return new_application(
582 : new_application(
583 : new_combinator(COMB_S),
584 : tromp_bracket_abstraction(var, tree->left)
585 : ),
586 : tromp_bracket_abstraction(var, tree->right)
587 : );
588 : }
589 :
590 : bracket_abstraction_function
591 : determine_bracket_abstraction(const char *algorithm_name)
592 88 : {
593 : struct {
594 : char *algorithm_name; /* values match TK_ALGORITHM_NAME in lex.l */
595 : bracket_abstraction_function f;
596 : } afmap[] = {
597 : {"curry", curry_bracket_abstraction},
598 : {"grz", grzegorczyk_bracket_abstraction},
599 : {"tromp", tromp_bracket_abstraction},
600 : {"turner", turner_bracket_abstraction},
601 : {"btmk", btmk_bracket_abstraction}
602 88 : };
603 : int i;
604 88 : bracket_abstraction_function func = (bracket_abstraction_function)NULL;
605 :
606 264 : for (i = 0; i < sizeof(afmap)/sizeof(afmap[0]); ++i)
607 : {
608 264 : if (!strcmp(afmap[i].algorithm_name, algorithm_name))
609 : {
610 88 : func = afmap[i].f;
611 88 : break;
612 : }
613 : }
614 :
615 88 : return func;
616 : }
617 :
|
