1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795

; ACL2 Version 3.1  A Computational Logic for Applicative Common Lisp
; Copyright (C) 2006 University of Texas at Austin
; This version of ACL2 is a descendent of ACL2 Version 1.9, Copyright
; (C) 1997 Computational Logic, Inc. See the documentation topic NOTE20.
; 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 2 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, write to the Free Software
; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
; Written by: Matt Kaufmann and J Strother Moore
; email: Kaufmann@cs.utexas.edu and Moore@cs.utexas.edu
; Department of Computer Sciences
; University of Texas at Austin
; Austin, TX 787121188 U.S.A.
(inpackage "ACL2")
; Section: PREPROCESSCLAUSE
; The preprocessor is the first clause processor in the waterfall when
; we enter from prove. It contains a simple term rewriter that expands
; certain "abbreviations" and a gentle clausifier.
; We first develop the simple rewriter, called expandabbreviations.
; Rockwell Addition: We are now concerned with lambdas, where we
; didn't used to treat them differently. This extra argument will
; show up in several places during a comparewindows.
(mutualrecursion
(defun abbreviationp1 (lambdaflg vars term2)
; This function returns t if term2 is not an abbreviation of term1
; (where vars is the bag of vars in term1). Otherwise, it returns the
; excess vars of vars. If lambdaflg is t we look out for lambdas and
; do not consider something an abbreviation if we see a lambda in it.
; If lambdaflg is nil, we treat lambdas as though they were function
; symbols.
(cond ((variablep term2)
(cond ((null vars) t) (t (cdr vars))))
((fquotep term2) vars)
((and lambdaflg
(flambdaapplicationp term2))
t)
((membereq (ffnsymb term2) '(if not implies)) t)
(t (abbreviationp1lst lambdaflg vars (fargs term2)))))
(defun abbreviationp1lst (lambdaflg vars lst)
(cond ((null lst) vars)
(t (let ((vars1 (abbreviationp1 lambdaflg vars (car lst))))
(cond ((eq vars1 t) t)
(t (abbreviationp1lst lambdaflg vars1 (cdr lst))))))))
)
(defun abbreviationp (lambdaflg vars term2)
; Consider the :REWRITE rule generated from (equal term1 term2). We
; say such a rule is an "abbreviation" if term2 contains no more
; variable occurrences than term1 and term2 does not call the
; functions IF, NOT or IMPLIES or (if lambdaflg is t) any LAMBDA.
; Vars, above, is the bag of vars from term1. We return nonnil iff
; (equal term1 term2) is an abbreviation.
(not (eq (abbreviationp1 lambdaflg vars term2) t)))
(mutualrecursion
(defun allvarsbag (term ans)
(cond ((variablep term) (cons term ans))
((fquotep term) ans)
(t (allvarsbaglst (fargs term) ans))))
(defun allvarsbaglst (lst ans)
(cond ((null lst) ans)
(t (allvarsbaglst (cdr lst)
(allvarsbag (car lst) ans)))))
)
(defun findabbreviationlemma (term geneqv lemmas ens wrld)
; Term is a function application, geneqv is a generated equivalence
; relation and lemmas is the 'lemmas property of the function symbol
; of term. We find the first (enabled) abbreviation lemma that
; rewrites term maintaining geneqv. A lemma is an abbreviation if it
; is not a metalemma, has no hypotheses, has no loopstopper, and has
; an abbreviationp for the conclusion.
; If we win we return t, the rune of the :CONGRUENCE rule used, the
; lemma, and the unifysubst. Otherwise we return four nils.
(cond ((null lemmas) (mv nil nil nil nil))
((and (enablednumep (access rewriterule (car lemmas) :nume) ens)
(eq (access rewriterule (car lemmas) :subclass) 'abbreviation)
(geneqvrefinementp (access rewriterule (car lemmas) :equiv)
geneqv
wrld))
(mvlet
(wonp unifysubst)
(onewayunify (access rewriterule (car lemmas) :lhs) term)
(cond (wonp (mv t
(geneqvrefinementp
(access rewriterule (car lemmas) :equiv)
geneqv
wrld)
(car lemmas)
unifysubst))
(t (findabbreviationlemma term geneqv (cdr lemmas)
ens wrld)))))
(t (findabbreviationlemma term geneqv (cdr lemmas)
ens wrld))))
(mutualrecursion
(defun expandabbreviationswithlemma (term geneqv
fnstobeignoredbyrewrite
rdepth ens wrld state ttree)
(mvlet
(wonp crrune lemma unifysubst)
(findabbreviationlemma term geneqv
(getprop (ffnsymb term) 'lemmas nil
'currentacl2world wrld)
ens
wrld)
(cond
(wonp
(withaccumulatedpersistence
(access rewriterule lemma :rune)
(term ttree)
(expandabbreviations
(access rewriterule lemma :rhs)
unifysubst
geneqv
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state
(pushlemma crrune
(pushlemma (access rewriterule lemma :rune)
ttree)))))
(t (mv term ttree)))))
(defun expandabbreviations (term alist geneqv fnstobeignoredbyrewrite
rdepth ens wrld state ttree)
; This function is essentially like rewrite but is more restrictive in
; its use of rules. We rewrite term/alist maintaining geneqv and
; avoiding the expansion or application of lemmas to terms whose fns
; are in fnstobeignoredbyrewrite. We return a new term and a
; ttree (accumulated onto our argument) describing the rewrite. We
; only apply "abbreviations" which means we expand lambda applications
; and nonrec fns provided they do not duplicate arguments or
; introduce IFs, etc. (see abbreviationp), and we apply those
; unconditional :REWRITE rules with the same property.
; It used to be written:
; Note: In a break with Nqthm and the first four versions of ACL2, in
; Version 1.5 we also expand IMPLIES terms here. In fact, we expand
; several members of *expandablebootstrapnonrecfns* here, and
; IFF. The impetus for this decision was the forcing of impossible
; goals by simplifyclause. As of this writing, we have just added
; the idea of forcing rounds and the concommitant notion that forced
; hypotheses are proved under the typealist extant at the time of the
; force. But if the simplifer sees IMPLIES terms and rewrites their
; arguments, it does not augment the context, e.g., in (IMPLIES hyps
; concl) concl is rewritten without assuming hyps and thus assumptions
; forced in concl are context free and often impossible to prove. Now
; while the user might hide propositional structure in other functions
; and thus still suffer this failure mode, IMPLIES is the most common
; one and by opening it now we make our context clearer. See the note
; below for the reason we expand other
; *expandablebootstrapnonrecfns*.
; This is no longer true. We now expand the IMPLIES from the original
; theorem in preprocessclause before expandabbreviations is called,
; and do not expand any others here. These changes in the handling of
; IMPLIES (as well as several others) are caused by the introduction
; of assumetruefalseif. See the miniessay at
; assumetruefalseif.
(cond
((zerodepthp rdepth)
(rdeptherror
(mv term ttree)
t))
((timelimit4reachedp ; nil, or throws
"Out of time in expandabbreviations.")
(mv nil nil))
((variablep term)
(let ((temp (assoceq term alist)))
(cond (temp (mv (cdr temp) ttree))
(t (mv term ttree)))))
((fquotep term) (mv term ttree))
((eq (ffnsymb term) 'hide)
(mv (sublisvar alist term)
ttree))
(t
(mvlet
(expandedargs ttree)
(expandabbreviationslst (fargs term)
alist
(geneqvlst (ffnsymb term) geneqv ens wrld)
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state ttree)
(let* ((fn (ffnsymb term))
(term (consterm fn expandedargs)))
; If term does not collapse to a constant, fn is still its ffnsymb.
(cond
((fquotep term)
; Term collapsed to a constant. But it wasn't a constant before, and so
; it collapsed because consterm executed fn on constants. So we record
; a use of the executable counterpart.
(mv term (pushlemma (fnrunenume fn nil t wrld) ttree)))
((memberequal fn fnstobeignoredbyrewrite)
(mv (consterm fn expandedargs) ttree))
((and (allquoteps expandedargs)
(enabledxfnp fn ens wrld)
(or (flambdaapplicationp term)
(not (getprop fn 'constrainedp nil
'currentacl2world wrld))))
(cond ((flambdaapplicationp term)
(expandabbreviations
(lambdabody fn)
(pairlis$ (lambdaformals fn) expandedargs)
geneqv
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state ttree))
((programp fn wrld)
; Why is the above test here? We do not allow :program mode fns in theorems.
; However, the prover can be called during definitions, and in particular we
; wind up with the call (SYMBOLBTREEP NIL) when trying to admit the following
; definition.
#
(defun symbolbtreep (x)
(if x
(and (truelistp x)
(symbolp (car x))
(symbolbtreep (caddr x))
(symbolbtreep (cdddr x)))
t))
#
(mv (consterm fn expandedargs) ttree))
(t
(mvlet
(erp val latches)
(pstk
(evfncall fn (stripcadrs expandedargs)
(fdecrementbigclock state)
nil
t))
(declare (ignore latches))
(cond
(erp
; We following a suggestion from Matt Wilding and attempt to simplify the term
; before applying HIDE.
(let ((newterm1 (consterm fn expandedargs)))
(mvlet (newterm2 ttree)
(expandabbreviationswithlemma
newterm1 geneqv fnstobeignoredbyrewrite rdepth
ens wrld state ttree)
(cond
((equal newterm2 newterm1)
(mv (mconsterm* 'hide newterm1)
(pushlemma (fnrunenume 'hide nil nil wrld)
ttree)))
(t (mv newterm2 ttree))))))
(t (mv (kwote val)
(pushlemma (fnrunenume fn nil t wrld)
ttree))))))))
((flambdap fn)
(cond ((abbreviationp nil
(lambdaformals fn)
(lambdabody fn))
(expandabbreviations
(lambdabody fn)
(pairlis$ (lambdaformals fn) expandedargs)
geneqv
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state ttree))
(t
; Once upon a time (well into v19) we just returned (mv term ttree)
; here. But then Jun Sawada pointed out some problems with his proofs
; of some theorems of the form (let (...) (implies (and ...) ...)).
; The problem was that the implies was not getting expanded (because
; the let turns into a lambda and the implication in the body is not
; an abbreviationp, as checked above). So we decided that, in such
; cases, we would actually expand the abbreviations in the body
; without expanding the lambda itself, as we do below. This in turn
; often allows the lambda to expand via the following mechanism.
; Preprocessclause calls expandabbreviations and it expands the
; implies into IFs in the body without opening the lambda. But then
; preprocessclause calls clausifyinput which does another
; expandabbreviations and this time the expansion is allowed. We do
; not imagine that this change will adversely affect proofs, but if
; so, well, the old code is shown on the first line of this comment.
(mvlet (body ttree)
(expandabbreviations
(lambdabody fn)
nil
geneqv
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state ttree)
; Rockwell Addition:
; Once upon another time (through v25) we returned the fconsterm
; shown in the t clause below. But Rockwell proofs indicate that it
; is better to eagerly expand this lambda if the new body would make
; it an abbreviation.
(cond
((abbreviationp nil
(lambdaformals fn)
body)
(expandabbreviations
body
(pairlis$ (lambdaformals fn) expandedargs)
geneqv
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state ttree))
(t
(mv (mconsterm (list 'lambda (lambdaformals fn)
body)
expandedargs)
ttree)))))))
((membereq fn '(iff synp prog2$ mustbeequal time$
withprovertimelimit force casesplit
doublerewrite))
; The list above is an arbitrary subset of *expandablebootstrapnonrecfns*.
; Once upon a time we used the entire list here, but Bishop Brock complained
; that he did not want EQL opened. So we have limited the list to just the
; propositional function IFF and the noops.
; Note: Once upon a time we did not expand any propositional functions
; here. Indeed, one might wonder why we do now? The only place
; expandabbreviations was called was from within preprocessclause.
; And there, its output was run through clausifyinput and then
; removetrivialclauses. The latter called tautologyp on each clause
; and that, in turn, expanded all the functions above (but discarded
; the expansion except for purposes of determining tautologyhood).
; Thus, there is no real case to make against expanding these guys.
; For sanity, one might wish to keep the list above in sync with
; that in tautologyp, where we say about it: "The list is in fact
; *expandablebootstrapnonrecfns* with NOT deleted and IFF added.
; The main idea here is to include nonrec functions that users
; typically put into the elegant statements of theorems." But now we
; have deleted IMPLIES from this list, to support the assumetruefalseif
; idea, but we still keep IMPLIES in the list for tautologyp because
; if we can decide it's a tautology by expanding, all the better.
(withaccumulatedpersistence
(fnrunenume fn nil nil wrld)
(term ttree)
(expandabbreviations (body fn t wrld)
(pairlis$ (formals fn wrld) expandedargs)
geneqv
fnstobeignoredbyrewrite
(adjustrdepth rdepth) ens wrld state
(pushlemma (fnrunenume fn nil nil wrld)
ttree))))
; Rockwell Addition: We are expanding abbreviations. This is new treatment
; of IF, which didn't used to receive any special notice.
((eq fn 'if)
; There are no abbreviation (or rewrite) rules hung on IF, so coming out
; here is ok.
(let ((a (car expandedargs))
(b (cadr expandedargs))
(c (caddr expandedargs)))
(cond
((equal b c) (mv b ttree))
((quotep a)
(mv (if (eq (cadr a) nil) c b) ttree))
((and (equal geneqv *geneqviff*)
(equal b *t*)
(or (equal c *nil*)
(and (nvariablep c)
(not (fquotep c))
(eq (ffnsymb c) 'HARDERROR))))
; Some users keep HARDERROR disabled so that they can figure out
; which guard proof case they are in. HARDERROR is identically nil
; and we would really like to eliminate the IF here. So we use our
; knowledge that HARDERROR is nil even if it is disabled. We don't
; even put it in the ttree, because for all the user knows this is
; primitive type inference.
(mv a ttree))
(t (mv (mconsterm 'if expandedargs) ttree)))))
; Rockwell Addition: New treatment of equal.
((and (eq fn 'equal)
(equal (car expandedargs) (cadr expandedargs)))
(mv *t* ttree))
(t
(expandabbreviationswithlemma
term geneqv fnstobeignoredbyrewrite rdepth ens wrld state
ttree))))))))
(defun expandabbreviationslst
(lst alist geneqvlst fnstobeignoredbyrewrite rdepth ens wrld state
ttree)
(cond
((null lst) (mv nil ttree))
(t (mvlet (term1 newttree)
(expandabbreviations (car lst) alist
(car geneqvlst)
fnstobeignoredbyrewrite
rdepth ens wrld state ttree)
(mvlet (terms1 newttree)
(expandabbreviationslst (cdr lst) alist
(cdr geneqvlst)
fnstobeignoredbyrewrite
rdepth ens wrld state newttree)
(mv (cons term1 terms1) newttree))))))
)
(defun andorp (term bool)
; We return t or nil according to whether term is a disjunction
; (if bool is t) or conjunction (if bool is nil).
(casematch term
(('if & c2 c3)
(if bool
(or (equal c2 *t*) (equal c3 *t*))
(or (equal c2 *nil*) (equal c3 *nil*))))))
(defun findandorlemma (term bool lemmas ens wrld)
; Term is a function application and lemmas is the 'lemmas property of
; the function symbol of term. We find the first enabled andor
; (wrt bool) lemma that rewrites term maintaining iff.
; If we win we return t, the :CONGRUENCE rule name, the lemma, and the
; unifysubst. Otherwise we return four nils.
(cond ((null lemmas) (mv nil nil nil nil))
((and (enablednumep (access rewriterule (car lemmas) :nume) ens)
(or (eq (access rewriterule (car lemmas) :subclass) 'backchain)
(eq (access rewriterule (car lemmas) :subclass) 'abbreviation))
(null (access rewriterule (car lemmas) :hyps))
(null (access rewriterule (car lemmas) :heuristicinfo))
(geneqvrefinementp (access rewriterule (car lemmas) :equiv)
*geneqviff*
wrld)
(andorp (access rewriterule (car lemmas) :rhs) bool))
(mvlet
(wonp unifysubst)
(onewayunify (access rewriterule (car lemmas) :lhs) term)
(cond (wonp (mv t
(geneqvrefinementp
(access rewriterule (car lemmas) :equiv)
*geneqviff*
wrld)
(car lemmas)
unifysubst))
(t (findandorlemma term bool (cdr lemmas) ens wrld)))))
(t (findandorlemma term bool (cdr lemmas) ens wrld))))
(defun expandandor
(term bool fnstobeignoredbyrewrite ens wrld state ttree)
; We expand the toplevel fn symbol of term provided the expansion
; produces a conjunction  when bool is nil  or a disjunction  when
; bool is t. We return three values: wonp, the new term, and a new ttree.
; This fn is a NoChange Loser.
(cond ((variablep term) (mv nil term ttree))
((fquotep term) (mv nil term ttree))
((memberequal (ffnsymb term) fnstobeignoredbyrewrite)
(mv nil term ttree))
((flambdaapplicationp term)
(cond ((andorp (lambdabody (ffnsymb term)) bool)
(mvlet (term ttree)
(expandabbreviations
(subcorvar (lambdaformals (ffnsymb term))
(fargs term)
(lambdabody (ffnsymb term)))
nil
*geneqviff*
fnstobeignoredbyrewrite
(rewritestacklimit wrld) ens wrld state ttree)
(mv t term ttree)))
(t (mv nil term ttree))))
(t
(let ((defbody (defbody (ffnsymb term) wrld)))
(cond
((and defbody
(null (access defbody defbody :recursivep))
(null (access defbody defbody :hyp))
(enablednumep (access defbody defbody :nume)
ens)
(andorp (access defbody defbody :concl)
bool))
(mvlet (term ttree)
(withaccumulatedpersistence
(access defbody defbody :rune)
(term ttree)
(expandabbreviations
(subcorvar (access defbody defbody
:formals)
(fargs term)
(access defbody defbody :concl))
nil
*geneqviff*
fnstobeignoredbyrewrite
(rewritestacklimit wrld)
ens wrld state
(pushlemma? (access defbody defbody :rune)
ttree)))
(mv t term ttree)))
(t (mvlet (wonp crrune lemma unifysubst)
(findandorlemma
term bool
(getprop (ffnsymb term) 'lemmas nil
'currentacl2world wrld)
ens wrld)
(cond
(wonp
(mvlet
(term ttree)
(withaccumulatedpersistence
(access rewriterule lemma :rune)
(term ttree)
(expandabbreviations
(sublisvar unifysubst
(access rewriterule lemma :rhs))
nil
*geneqviff*
fnstobeignoredbyrewrite
(rewritestacklimit wrld)
ens wrld state
(pushlemma crrune
(pushlemma (access rewriterule lemma
:rune)
ttree))))
(mv t term ttree)))
(t (mv nil term ttree))))))))))
(defun clausifyinput1
(term bool fnstobeignoredbyrewrite ens wrld state ttree)
; We return two things, a clause and a ttree. If bool is t, the
; (disjunction of the literals in the) clause is equivalent to term.
; If bool is nil, the clause is equivalent to the negation of term.
; This function opens up some nonrec fns and applies some rewrite
; rules. The final ttree contains the symbols and rules used.
(cond
((equal term (if bool *nil* *t*)) (mv nil ttree))
((and (nvariablep term)
(not (fquotep term))
(eq (ffnsymb term) 'if))
(let ((t1 (fargn term 1))
(t2 (fargn term 2))
(t3 (fargn term 3)))
(cond
(bool
(cond
((equal t3 *t*)
(mvlet (cl1 ttree)
(clausifyinput1 t1 nil
fnstobeignoredbyrewrite
ens wrld state ttree)
(mvlet (cl2 ttree)
(clausifyinput1 t2 t
fnstobeignoredbyrewrite
ens wrld state ttree)
(mv (disjoinclauses cl1 cl2) ttree))))
((equal t2 *t*)
(mvlet (cl1 ttree)
(clausifyinput1 t1 t
fnstobeignoredbyrewrite
ens wrld state ttree)
(mvlet (cl2 ttree)
(clausifyinput1 t3 t
fnstobeignoredbyrewrite
ens wrld state ttree)
(mv (disjoinclauses cl1 cl2) ttree))))
(t (mv (list term) ttree))))
(t
(cond ((equal t3 *nil*)
(mvlet (cl1 ttree)
(clausifyinput1 t1 nil
fnstobeignoredbyrewrite
ens wrld state ttree)
(mvlet (cl2 ttree)
(clausifyinput1 t2 nil
fnstobeignoredbyrewrite
ens wrld state ttree)
(mv (disjoinclauses cl1 cl2) ttree))))
((equal t2 *nil*)
(mvlet (cl1 ttree)
(clausifyinput1 t1 t
fnstobeignoredbyrewrite
ens wrld state ttree)
(mvlet (cl2 ttree)
(clausifyinput1 t3 nil
fnstobeignoredbyrewrite
ens wrld state ttree)
(mv (disjoinclauses cl1 cl2) ttree))))
(t (mv (list (dumbnegatelit term)) ttree)))))))
(t (mvlet (wonp term ttree)
(expandandor term bool fnstobeignoredbyrewrite
ens wrld state ttree)
(cond (wonp
(clausifyinput1 term bool fnstobeignoredbyrewrite
ens wrld state ttree))
(bool (mv (list term) ttree))
(t (mv (list (dumbnegatelit term)) ttree)))))))
(defun clausifyinput1lst
(lst fnstobeignoredbyrewrite ens wrld state ttree)
; This function is really a subroutine of clausifyinput. It just
; applies clausifyinput1 to every element of lst, accumulating the ttrees.
; It uses bool=t.
(cond ((null lst) (mv nil ttree))
(t (mvlet (clause ttree)
(clausifyinput1 (car lst) t fnstobeignoredbyrewrite
ens wrld state ttree)
(mvlet (clauses ttree)
(clausifyinput1lst (cdr lst)
fnstobeignoredbyrewrite
ens wrld state ttree)
(mv (conjoinclausetoclauseset clause clauses) ttree))))))
(defun clausifyinput (term fnstobeignoredbyrewrite ens wrld state ttree)
; This function converts term to a set of clauses, expanding some
; nonrec functions when they produce results of the desired parity
; (i.e., we expand ANDlike functions in the hypotheses and ORlike
; functions in the conclusion.) AND and OR themselves are, of course,
; already expanded into IFs, but we will expand other functions when
; they generate the desired IF structure. We also apply :REWRITE rules
; deemed appropriate. We return two results, the set of clauses and a
; ttree documenting the expansions.
(mvlet (negclause ttree)
(clausifyinput1 term nil fnstobeignoredbyrewrite ens
wrld state ttree)
; negclause is a clause that is equivalent to the negation of term.
; That is, if the literals of negclause are lit1, ..., litn, then
; (or lit1 ... litn) <> (not term). Therefore, term is the negation
; of the clause, i.e., (and (not lit1) ... (not litn)). We will
; form a clause from each (not lit1) and return the set of clauses,
; implicitly conjoined.
(clausifyinput1lst (dumbnegatelitlst negclause)
fnstobeignoredbyrewrite
ens wrld state ttree)))
(defun expandsomenonrecfnsinclauses (fns clauses wrld)
; Warning: fns should be a subset of functions that
; This function expands the nonrec fns listed in fns in each of the clauses
; in clauses. It then throws out of the set any trivial clause, i.e.,
; tautologies. It does not normalize the expanded terms but just leaves
; the expanded bodies in situ. See the comment in preprocessclause.
(cond
((null clauses) nil)
(t (let ((cl (expandsomenonrecfnslst fns (car clauses) wrld)))
(cond
((trivialclausep cl wrld)
(expandsomenonrecfnsinclauses fns (cdr clauses) wrld))
(t (cons cl
(expandsomenonrecfnsinclauses fns (cdr clauses)
wrld))))))))
(defun noophistp (hist)
; We say a history, hist, is a "noop history" if it is empty or its most
; recent entry is a tobehidden preprocessclause (possibly followed by a
; settleddownclause).
(or (null hist)
(and hist
(eq (access historyentry (car hist) :processor)
'preprocessclause)
(tagtreeoccur 'hiddenpreprocessclause
t
(access historyentry (car hist) :ttree)))
(and hist
(eq (access historyentry (car hist) :processor)
'settleddownclause)
(cdr hist)
(eq (access historyentry (cadr hist) :processor)
'preprocessclause)
(tagtreeoccur 'hiddenpreprocessclause
t
(access historyentry (cadr hist) :ttree)))))
(mutualrecursion
; This pair of functions is copied from expandabbreviations and
; heavily modified. The idea implemented by the caller of this
; function is to expand all the IMPLIES terms in the final literal of
; the goal clause. This pair of functions actually implements that
; expansion. One might think to use expandsomenonrecfns with
; first argument '(IMPLIES). But this function is different in two
; respects. First, it respects HIDE. Second, it expands the IMPLIES
; inside of lambda bodies. The basic idea is to mimic what
; expandabbreviations used to do, before we added the
; assumetruefalseif idea.
(defun expandanyfinalimplies1 (term wrld)
(cond
((variablep term)
term)
((fquotep term)
term)
((eq (ffnsymb term) 'hide)
term)
(t
(let ((expandedargs (expandanyfinalimplies1lst (fargs term)
wrld)))
(let* ((fn (ffnsymb term))
(term (consterm fn expandedargs)))
(cond ((flambdap fn)
(let ((body (expandanyfinalimplies1 (lambdabody fn)
wrld)))
; Note: We could use a makelambdaapplication here, but if the
; original lambda used all of its variables then so does the new one,
; because IMPLIES uses all of its variables and we're not doing any
; simplification. This remark is not soundness related; there is no
; danger of introducing new variables, only the inefficiency of
; keeping a big actual which is actually not used.
(fconsterm (makelambda (lambdaformals fn) body)
expandedargs)))
((eq fn 'IMPLIES)
(subcorvar (formals 'implies wrld)
expandedargs
(body 'implies t wrld)))
(t term)))))))
(defun expandanyfinalimplies1lst (termlst wrld)
(cond ((null termlst)
nil)
(t
(cons (expandanyfinalimplies1 (car termlst) wrld)
(expandanyfinalimplies1lst (cdr termlst) wrld)))))
)
(defun expandanyfinalimplies (cl wrld)
; Cl is a clause (a list of ACL2 terms representing a goal) about to
; enter preprocessing. If the final term contains an 'IMPLIES, we
; expand those IMPLIES here. This change in the handling of IMPLIES
; (as well as several others) is caused by the introduction of
; assumetruefalseif. See the miniessay at assumetruefalseif.
; Note that we fail to report the fact that we used the definition
; of IMPLIES.
; Note also that we do not use expandsomenonrecfns here. We want
; to preserve the meaning of 'HIDE and expand an 'IMPLIES inside of
; a lambda.
(cond ((null cl) ; This should not happen.
nil)
((null (cdr cl))
(list (expandanyfinalimplies1 (car cl) wrld)))
(t
(cons (car cl)
(expandanyfinalimplies (cdr cl) wrld)))))
(defun preprocessclause (cl hist pspv wrld state)
; This is the first "real" clause processor (after a little remembered
; applytophintsclause) in the waterfall. Its arguments and
; values are the standard ones. We expand abbreviations and clausify
; the clause cl. For mainly historic reasons, expandabbreviations
; and clausifyinput operate on terms. Thus, our first move is to
; convert cl into a term.
(let ((rcnst (access provespecvar pspv :rewriteconstant)))
(mvlet
(builtinclausep ttree)
(cond
((or (eq (car (car hist)) 'simplifyclause)
(eq (car (car hist)) 'settleddownclause))
; If the hist shows that cl has just come from simplification, there is no
; need to check that it is built in, because the simplifier does that.
(mv nil nil))
(t
(builtinclausep cl
(access rewriteconstant
rcnst
:currentenabledstructure)
(access rewriteconstant
rcnst
:oncepoverride)
wrld
state)))
; Ttree is known to be 'assumption free.
(cond
(builtinclausep
(mv 'hit nil ttree pspv))
(t
; Here is where we expand the "original" IMPLIES in the conclusion but
; leave any IMPLIES in the hypotheses. These IMPLIES are thought to
; have been introduced by :USE hints.
(let ((term (disjoin (expandanyfinalimplies cl wrld))))
(mvlet (term ttree)
(expandabbreviations term nil
*geneqviff*
(access rewriteconstant
rcnst
:fnstobeignoredbyrewrite)
(rewritestacklimit wrld)
(access rewriteconstant
rcnst
:currentenabledstructure)
wrld state nil)
(mvlet (clauses ttree)
(clausifyinput term
(access rewriteconstant
(access provespecvar
pspv
:rewriteconstant)
:fnstobeignoredbyrewrite)
(access rewriteconstant
rcnst
:currentenabledstructure)
wrld
state
ttree)
;;; (let ((clauses
;;; (expandsomenonrecfnsinclauses
;;; '(iff implies)
;;; clauses
;;; wrld)))
# Previous to Version_2.6 we had written:
; Note: Once upon a time (in Version 1.5) we called "clausifyclauseset" here.
; That function called clausify on each element of clauses and unioned the
; results together, in the process naturally deleting tautologies as does
; expandsomenonrecfnsinclauses above. But Version 1.5 caused Bishop a
; lot of pain because many theorems would explode into case analyses, each of
; which was then dispatched by simplification. The reason we used a fullblown
; clausify in Version 1.5 was that in was also into that version that we
; introduced forcing rounds and the liberal use of forceflg = t. But if we
; are to force that way, we must really get all of our hypotheses out into the
; open so that they can contribute to the typealist stored in each assumption.
; For example, in Version 1.4 the concl of (IMPLIES hyps concl) was rewritten
; first without the hyps being manifest in the typealist since IMPLIES is a
; function. Not until the IMPLIES was opened did the hyps become "governers"
; in this sense. In Version 1.5 we decided to throw caution to the wind and
; just clausify the clausified input. Well, it bit us as mentioned above and
; we are now backing off to simply expanding the nonrec fns that might
; contribute hyps. But we leave the expansions in place rather than normalize
; them out so that simplification has one shot on a small set (usually
; singleton set) of clauses.
#
; But the comment above is now irrelevant to the current situation.
; Before commenting on the current situation, however, we point out that
; in (admittedly light) testing the original call to
; expandsomenonrecfnsinclauses in its original context acted as
; the identity. This seems reasonable because 'iff and 'implies were
; expanded in expandabbreviations.
; We now expand the 'implies from the original theorem (but not the
; implies from a :use hint) in the call to expandanyfinalimplies.
; This performs the expansion whose motivations are mentioned in the
; old comments above, but does not interfere with the conclusions
; of a :use hint. See the miniessay
; MiniEssay on Assumetruefalseif and Implies
; or
; How Strengthening One Part of a Theorem Prover Can Weaken the Whole.
; in typesetb for more details on this latter criterion.
(cond
((equal clauses (list cl))
; In this case, preprocessclause has made no changes to the clause.
(mv 'miss nil nil nil))
((and (consp clauses)
(null (cdr clauses))
(noophistp hist)
(equal (prettyifyclause
(car clauses)
(let*abstractionp state)
wrld)
(access provespecvar pspv
:displayedgoal)))
; In this case preprocessclause has produced a singleton set of
; clauses whose only element will be displayed exactly like what the
; user thinks is the input to prove. For example, the user might have
; invoked defthm on (implies p q) and preprocess has managed to to
; produce the singleton set of clauses containing {(not p) q}. This
; is a valuable step in the proof of course. However, users complain
; when we report that (IMPLIES P Q)  the displayed goal  is
; reduced to (IMPLIES P Q)  the prettyification of the output.
; We therefore take special steps to hide this transformation from the
; user without changing the flow of control through the waterfall. In
; particular, we will insert into the ttree the tag
; 'hiddenpreprocessclause with (irrelevant) value t. In subsequent
; places where we print explanations and clauses to the user we will
; look for this tag.
(mv 'hit
clauses
(addtotagtree
'hiddenpreprocessclause t ttree)
pspv))
(t (mv 'hit
clauses
ttree
pspv)))))))))))
; And here is the function that reports on a successful preprocessing.
(defun tilde*preprocessphrase (ttree)
; This function is like tilde*simpphrase but knows that ttree was
; constructed by preprocessclause and hence is based on abbreviation
; expansion rather than fullfledged rewriting.
; Warning: The function applytophintsclausemsg1 knows
; that if the (car (cddddr &)) of the result is nil then nothing but
; case analysis was done!
(mvlet (messagelst charalist)
(tilde*simpphrase1
(extractandclassifylemmas ttree '(implies not iff) nil nil)
; Note: The third argument to extractandclassifylemmas is the list
; of forced runes, which we assume to be nil in preprocessing. If
; this changes, see the comment in fertilizeclausemsg1.
t)
(list* "case analysis"
"~@*"
"~@* and "
"~@*, "
messagelst
charalist)))
(defun preprocessclausemsg1 (signal clauses ttree pspv state)
; This function is one of the waterfallmsg subroutines. It has the
; standard arguments of all such functions: the signal, clauses, ttree
; and pspv produced by the given processor, in this case
; preprocessclause. It produces the report for this step.
(declare (ignore signal pspv))
(cond ((tagtreeoccur 'hiddenpreprocessclause t ttree)
; If this preprocess clause is to be hidden, e.g., because it transforms
; (IMPLIES P Q) to {(NOT P) Q}, we print no message. Note that this is
; just part of the hiding. Later in the waterfall, when some other processor
; has successfully hit our output, that output will be printed and we
; need to stop that printing too.
state)
((null clauses)
(fms "But we reduce the conjecture to T, by ~*0.~"
(list (cons #\0 (tilde*preprocessphrase ttree)))
(proofsco state)
state
(termevisctuple nil state)))
(t
(fms "By ~*0 we reduce the conjecture to~#1~[~x2.~/~/ the following ~
~n3 conjectures.~]~"
(list (cons #\0 (tilde*preprocessphrase ttree))
(cons #\1 (zerooneormore clauses))
(cons #\2 t)
(cons #\3 (length clauses)))
(proofsco state)
state
(termevisctuple nil state)))))
; Section: PUSHCLAUSE and The Pool
; At the opposite end of the waterfall from the preprocessor is pushclause,
; where we actually put a clause into the pool. We develop it now.
(defun morethansimplifiedp (hist)
; Return t if hist contains a process besides simplifyclause (and its
; mates settleddownclause and preprocessclause).
(cond ((null hist) nil)
((membereq (caar hist) '(settleddownclause
simplifyclause
preprocessclause))
(morethansimplifiedp (cdr hist)))
(t t)))
; The pool is a list of poolelements, as shown below. We explain
; in pushclause.
(defrec poolelement (tag clauseset . hintsettings) t)
(defun deleteassoceqlst (lst alist)
(declare (xargs :guard (or (symbollistp lst)
(symbolalistp alist))))
(if (consp lst)
(deleteassoceqlst (cdr lst)
(deleteassoceq (car lst) alist))
alist))
(defun deleteassumptions1 (ttree onlyimmediatep)
; See comment for deleteassumptions. This function returns (mv changedp
; newttree), where if changedp is nil then newttree equals ttree. The only
; reason for the change from Version_2.6 is efficiency.
(cond ((null ttree) (mv nil nil))
((symbolp (caar ttree))
(mvlet (changedp newcdrttree)
(deleteassumptions1 (cdr ttree) onlyimmediatep)
(cond ((and (eq (caar ttree) 'assumption)
(cond
((eq onlyimmediatep 'nonnil)
(access assumption (cdar ttree) :immediatep))
((eq onlyimmediatep 'casesplit)
(eq (access assumption (cdar ttree) :immediatep)
'casesplit))
((eq onlyimmediatep t)
(eq (access assumption (cdar ttree) :immediatep)
t))
(t t)))
(mv t newcdrttree))
(changedp
(mv t
(cons (car ttree) newcdrttree)))
(t (mv nil ttree)))))
(t (mvlet (changedp1 ttree1)
(deleteassumptions1 (car ttree) onlyimmediatep)
(mvlet (changedp2 ttree2)
(deleteassumptions1 (cdr ttree) onlyimmediatep)
(if (or changedp1 changedp2)
(mv t (constagtrees ttree1 ttree2))
(mv nil ttree)))))))
(defun deleteassumptions (ttree onlyimmediatep)
; We delete the assumptions in ttree. We give the same interpretation to
; onlyimmediatep as in collectassumptions.
(mvlet (changedp newttree)
(deleteassumptions1 ttree onlyimmediatep)
(declare (ignore changedp))
newttree))
(defun pushclause (cl hist pspv wrld state)
; Roughly speaking, we drop cl into the pool of pspv and return.
; However, we sometimes cause the waterfall to abort further
; processing (either to go straight to induction or to fail) and we
; also sometimes choose to push a different clause into the pool. We
; even sometimes miss and let the waterfall fall off the end of the
; ledge! We make this precise in the code below.
; The pool is actually a list of poolelements and is treated as a
; stack. The clauseset is a set of clauses and is almost always a
; singleton set. The exception is when it contains the clausification
; of the user's initial conjecture.
; The expected tags are:
; 'TOBEPROVEDBYINDUCTION  the clause set is to be given to INDUCT
; 'BEINGPROVEDBYINDUCTION  the clause set has been given to INDUCT and
; we are working on its subgoals now.
; Like all clause processors, we return four values: the signal,
; which is either 'hit, 'miss or 'abort, the new set of clauses, in this
; case nil, the ttree for whatever action we take, and the new
; value of pspv (containing the new pool).
; Warning: Generally speaking, this function either 'HITs or 'ABORTs.
; But it is here that we look out for :DONOTINDUCT name hints. For
; such hints we want to act like a :BY nameclauseid was present for
; the clause. But we don't know the clauseid and the :BY handling is
; so complicated we don't want to reproduce it. So what we do instead
; is 'MISS and let the waterfall fall off the ledge to the nil ledge.
; See waterfall0. This function should NEVER return a 'MISS unless
; there is a :DONOTINDUCT name hint present in the hintsettings,
; since waterfall0 assumes that it falls off the ledge only in that
; case.
(declare (ignore state wrld))
(let ((pool (access provespecvar pspv :pool))
(donotinducthintval
(cdr (assoceq :donotinduct
(access provespecvar pspv :hintsettings)))))
(cond
((null cl)
; The empty clause was produced. Stop the waterfall by aborting.
; Produce the ttree that expains the abort. Drop the clause set
; containing the empty clause into the pool so that when we look for
; the next goal we see it and quit.
(mv 'abort
nil
(addtotagtree 'abortcause 'emptyclause nil)
(change provespecvar pspv
:pool (cons (make poolelement
:tag 'TOBEPROVEDBYINDUCTION
:clauseset '(nil)
:hintsettings nil)
pool))))
((and (not (access provespecvar pspv :otfflg))
(eq donotinducthintval t)
(not (assoceq :induct (access provespecvar pspv :hintsettings))))
; We need induction but can't use it. Stop the waterfall by aborting.
; Produce the ttree that expains the abort. Drop the clause set
; containing the empty clause into the pool so that when we look for
; the next goal we see it and quit. Note that if :otfflg is specified,
; then we skip this case because we do not want to quit just yet. We
; will see the :donotinduct value again in proveloop1 when we return
; to the goal we are pushing.
(mv 'abort
nil
(addtotagtree 'abortcause 'donotinduct nil)
(change provespecvar pspv
:pool (cons (make poolelement
:tag 'TOBEPROVEDBYINDUCTION
:clauseset '(nil)
:hintsettings nil)
pool))))
((and (not (access provespecvar pspv :otfflg))
(or
(and (null pool) ;(a)
(morethansimplifiedp hist)
(not (assoceq :induct (access provespecvar pspv
:hintsettings))))
(and pool ;(b)
(not (assoceq 'beingprovedbyinduction pool))
(not (assoceq :induct (access provespecvar pspv
:hintsettings))))))
; We have not been told to press Onward Thru the Fog and
; either (a) this is the first time we've ever pushed anything and we
; have applied processes other than simplification to it and we have
; not been explicitly instructed to induct for this formula, or (b) we
; have already put at least one goal into the pool but we have not yet
; done our first induction and we are not being explicitly instructed
; to induct for this formula.
; Stop the waterfall by aborting. Produce the ttree explaining the
; abort. Drop the clausification of the user's input into the pool
; in place of everything else in the pool.
; Note: We once reverted to the output of preprocessclause in prove.
; However, preprocess (and clausifyinput) applies unconditional
; :REWRITE rules and we want users to be able to type exactly what the
; system should go into induction on. The theorem that preprocessclause
; screwed us on was HACK1. It screwed us by distributing * and GCD.
(mv 'abort
nil
(addtotagtree 'abortcause 'revert nil)
(change provespecvar pspv
; Before Version_2.6 we did not modify the tag tree here. The result was that
; assumptions created by forcing before reverting to the original goal still
; generated forcing rounds after the subsequent proof by induction. When this
; bug was discovered we added code below to use deleteassumptions to remove
; assumptions from the the tag tree. Note that we are not modifying the
; 'accumulatedttree in state, so these assumptions still reside there; but
; since that ttree is only used for reporting rules used and is intended to
; reflect the entire proof attempt, this decision seems reasonable.
; Version_2.6 was released on November 29, 2001. On January 18, 2002, we
; received email from Francisco J. MartinMateos reporting a soundness bug,
; with an example that is included after the definition of pushclause.
; The problem turned out to be that we did not remove :use and :by tagged
; values from the tag tree here. The result was that if the early part of a
; successful proof attempt had involved a :use or :by hint but then the early
; part was thrown away and we reverted to the original goal, the :use or :by
; tagged value remained in the tag tree. When the proof ultimately succeeded,
; this tagged value was used to update (globalval
; 'provedfunctionalinstancesalist (w state)), which records proved
; constraints so that subsequent proofs can avoid proving them again. But
; because the prover reverted to the original goal rather than taking
; advantage of the :use hint, those constraints were not actually proved in
; this case and might not be valid!
; So, we have decided that rather than remove assumptions and :by/:use tags
; from the :tagtree of pspv, we would just replace that tag tree by the empty
; tag tree. We do not want to get burned by a third such problem!
:tagtree nil
:pool (list (make poolelement
:tag 'TOBEPROVEDBYINDUCTION
:clauseset
; At one time we clausified here. But some experiments suggested that the
; prover can perhaps do better by simply doing its thing on each induction
; goal, starting at the top of the waterfall. So, now we pass the same clause
; to induction as it would get if there were a hint of the form ("Goal" :induct
; term), where term is the usersuppliedterm.
(list (list
(access provespecvar pspv
:usersuppliedterm)))
; Below we set the :hintsettings for the input clause, doing exactly
; what findapplicablehintsettings does. Unfortunately, we haven't
; defined that function yet. Fortunately, it's just a simple
; assocequal. In addition, that function goes on to compute a second
; value we don't need here. So rather than go to the bother of moving
; its definition up to here we just open code the part we need. We
; also remove :cases, :use, and :by hints, since they were only
; supposed to apply to "Goal".
:hintsettings
(deleteassoceqlst
'(:cases :use :by :bdd)
; We could also delete :induct, but we know it's not here!
(cdr
(assocequal
*initialclauseid*
(access provespecvar pspv
:orighints)))))))))
((and donotinducthintval
(not (eq donotinducthintval t))
(not (assoceq :induct (access provespecvar pspv :hintsettings))))
; In this case, we have seen a :DONOTINDUCT name hint (where name isn't t) that
; is not overridden by an :INDUCT hint. We would like to give this clause a :BY.
; We can't do it here, as explained above. So we will 'MISS instead.
(mv 'miss nil nil nil))
(t (mv 'hit
nil
nil
(change provespecvar pspv
:pool
(cons
(make poolelement
:tag 'TOBEPROVEDBYINDUCTION
:clauseset (list cl)
:hintsettings (access provespecvar pspv
:hintsettings))
pool)))))))
; Below is the soundness bug example reported by Francisco J. MartinMateos.
#
;;;============================================================================
;;;
;;; A bug in ACL2 (2.5 and 2.6). Proving "0=1".
;;; Francisco J. MartinMateos
;;; email: FranciscoJesus.Martin@cs.us.es
;;; Dpt. of Computer Science and Artificial Intelligence
;;; University of SEVILLE
;;;
;;;============================================================================
;;; I've found a bug in ACL2 (2.5 and 2.6). The following events prove that
;;; "0=1".
(inpackage "ACL2")
(encapsulate
(((g1) => *))
(local
(defun g1 ()
0))
(defthm 0=g1
(equal 0 (g1))
:ruleclasses nil))
(defun g1lst (lst)
(cond ((endp lst) (g1))
(t (g1lst (cdr lst)))))
(defthm g1lst=g1
(equal (g1lst lst) (g1)))
(encapsulate
(((f1) => *))
(local
(defun f1 ()
1)))
(defun f1lst (lst)
(cond ((endp lst) (f1))
(t (f1lst (cdr lst)))))
(defthm f1lst=f1
(equal (f1lst lst) (f1))
:hints (("Goal"
:use (:functionalinstance g1lst=g1
(g1 f1)
(g1lst f1lst)))))
(defthm 0=f1
(equal 0 (f1))
:ruleclasses nil
:hints (("Goal"
:use (:functionalinstance 0=g1
(g1 f1)))))
(defthm 0=1
(equal 0 1)
:ruleclasses nil
:hints (("Goal"
:use (:functionalinstance 0=f1
(f1 (lambda () 1))))))
;;; The theorem F1LST=F1 is not proved via functional instantiation but it
;;; can be proved via induction. So, the constraints generated by the
;;; functional instantiation hint has not been proved. But when the theorem
;;; 0=F1 is considered, the constraints generated in the functional
;;; instantiation hint are bypassed because they ".. have been proved when
;;; processing the event F1LST=F1", and the theorem is proved !!!. Finally,
;;; an instance of 0=F1 can be used to prove 0=1.
;;;============================================================================
#
; We now develop the functions for reporting what pushclause did.
(defun poollst1 (pool n ans)
(cond ((null pool) (cons n ans))
((eq (access poolelement (car pool) :tag)
'tobeprovedbyinduction)
(poollst1 (cdr pool) (1+ n) ans))
(t (poollst1 (cdr pool) 1 (cons n ans)))))
(defun poollst (pool)
; Pool is a pool as constructed by pushclause. That is, it is a list
; of poolelements and the tag of each is either 'tobeprovedby
; induction or 'beingprovedbyinduction. Generally when we refer to
; a poollst we mean the output of this function, which is a list of
; natural numbers. For example, '(3 2 1) is a poollst and *3.2.1 is
; its printed representation.
; If one thinks of the pool being divided into gaps by the
; 'beingprovedbyinductions (with gaps at both ends) then the lst
; has as many elements as there are gaps and the ith element, k, in
; the lst tells us there are k1 'tobeprovedbyinductions in the
; ith gap.
; Warning: It is assumed that the value of this function is always
; nonnil. See the use of "jpplflg" in the waterfall and in
; popclause.
(poollst1 pool 1 nil))
(defun pushclausemsg1 (forcinground signal clauses ttree pspv state)
; Push clause was given a clause and produced a signal and ttree. We
; are responsible for printing out an explanation of what happened.
; We look at the ttree to determine what happened. We return state.
(declare (ignore clauses))
(cond ((eq signal 'abort)
(let ((temp (cdr (taggedobject 'abortcause ttree))))
(case temp
(emptyclause
(fms "Obviously, the proof attempt has failed.~"
nil
(proofsco state)
state
(termevisctuple nil state)))
(donotinduct
(fms "Normally we would attempt to prove this formula by ~
induction. However, since the DONOTINDUCT hint was ~
supplied, we can't do that and the proof attempt has ~
failed.~"
nil
(proofsco state)
state
(termevisctuple nil state)))
(otherwise
(fms "Normally we would attempt to prove this ~
formula by induction. However, we prefer in ~
this instance to focus on the original input ~
conjecture rather than this simplified ~
special case. We therefore abandon our ~
previous work on this conjecture and reassign ~
the name ~@0 to the original conjecture. ~
(See :DOC otfflg.)~#1~[~/ [Note: Thanks ~
again for the hint.]~]~"
(list (cons #\0 (tilde@poolnamephrase
forcinground
(poollst
(cdr (access provespecvar pspv
:pool)))))
(cons #\1
(if (access provespecvar pspv :hintsettings)
1
0)))
(proofsco state)
state
(termevisctuple nil state))))))
(t
(fms "Name the formula above ~@0.~"
(list (cons #\0 (tilde@poolnamephrase
forcinground
(poollst
(cdr (access provespecvar pspv
:pool))))))
(proofsco state)
state
nil))))
(deflabel otfflg
:doc
":DocSection Miscellaneous
pushing all the initial subgoals~/
The value of this flag is normally ~c[nil]. If you want to prevent the
theorem prover from abandoning its initial work upon pushing the
second subgoal, set ~c[:otfflg] to ~c[t].~/
Suppose you submit a conjecture to the theorem prover and the system
splits it up into many subgoals. Any subgoal not proved by other
methods is eventually set aside for an attempted induction proof.
But upon setting aside the second such subgoal, the system chickens
out and decides that rather than prove n>1 subgoals inductively, it
will abandon its initial work and attempt induction on the
originally submitted conjecture. The ~c[:otfflg] (Onward Thru the Fog)
allows you to override this chickening out. When ~c[:otfflg] is ~c[t], the
system will push all the initial subgoals and proceed to try to
prove each, independently, by induction.
Even when you don't expect induction to be used or to succeed,
setting the ~c[:otfflg] is a good way to force the system to generate
and display all the initial subgoals.
For ~ilc[defthm] and ~ilc[thm], ~c[:otfflg] is a keyword argument that is a peer to
~c[:]~ilc[ruleclasses] and ~c[:]~ilc[hints]. It may be supplied as in the following
examples; also ~pl[defthm].
~bv[]
(thm (mypredicate x y) :ruleclasses nil :otfflg t)
(defthm appendassoc
(equal (append (append x y) z)
(append x (append y z)))
:hints ((\"Goal\" :induct t))
:otfflg t)
~ev[]
The ~c[:otfflg] may be supplied to ~ilc[defun] via the ~ilc[xargs]
declare option. When you supply an ~c[:otfflg] hint to ~c[defun], the
flag is effective for the termination proofs and the guard proofs, if
any.~/")
; Section: Use and By hints
(defun clausesetsubsumes1 (initsubsumescount clset1 clset2 acc)
; We return t if the first set of clauses subsumes the second in the sense that
; for every member of clset2 there exists a member of clset1 that subsumes
; it. We return '? if we don't know (but this can only happen if
; initsubsumescount is nonnil); see the comment in subsumes.
(cond ((null clset2) acc)
(t (let ((temp (somemembersubsumes initsubsumescount
clset1 (car clset2) nil)))
(and temp ; thus t or maybe, if initsubsumescount is nonnil, ?
(clausesetsubsumes1 initsubsumescount
clset1 (cdr clset2) temp))))))
(defun clausesetsubsumes (initsubsumescount clset1 clset2)
; This function is intended to be identical, as a function, to
; clausesetsubsumes1 (with acc set to t). The first two disjuncts are
; optimizations that may often apply.
(or (equal clset1 clset2)
(and clset1
clset2
(null (cdr clset2))
(subsetpequal (car clset1) (car clset2)))
(clausesetsubsumes1 initsubsumescount clset1 clset2 t)))
(defun applyusehintclauses (temp clauses pspv wrld state)
; Note: There is no applyusehintclause. We just call this function
; on a singleton list of clauses.
; Temp is the result of assoceq :use in a pspv :hintsettings and is
; nonnil. We discuss its shape below. But this function applies the
; given :use hint to each clause in clauses and returns (mv 'hit
; newclauses ttree newpspv).
; Temp is of the form (:USE lmilst (hyp1 ... hypn) constraintcl k
; eventnames newentries) where each hypi is a theorem and
; constraintcl is a clause that expresses the conjunction of all k
; constraints. Lmilst is the list of lmis that generated these hyps.
; Constraintcl is (probably) of the form {(if constr1 (if constr2 ...
; (if constrk t nil)... nil) nil)}. We add each hypi as a hypothesis
; to each goal clause, cl, and in addition, create one new goal for
; each constraint. Note that we discard the extended goal clause if
; it is a tautology. Note too that the constraints generated by the
; production of the hyps are conjoined into a single clause in temp.
; But we hit that constraintcl with preprocessclause to pick out its
; (nontautologial) cases and that code will readily unpack the if
; structure of a typical conjunct. We remove the :use hint from the
; hintsettings so we don't fire the same :use again on the subgoals.
; We return (mv 'hit newclauses ttree newpspv).
; The ttree returned has at most two tags. The first is :use and has
; ((lmilst hyps constraintcl k eventnames newentries)
; . nontautpapplications) as its value, where nontautpapplications
; is the number of nontautologous clauses we got by adding the hypi
; to each clause. However, it is possible the :use tag is not
; present: if clauses is nil, we don't report a :use. The optional
; second tag is the ttree produced by preprocessclause on the
; constraintcl. If the preprocessclause is to be hidden anyway, we
; ignore its tree (but use its clauses).
(let* ((hyps (caddr temp))
(constraintcl (cadddr temp))
(newpspv (change provespecvar pspv
:hintsettings
(remove1equal temp
(access provespecvar
pspv
:hintsettings))))
(A (disjoinclausesegmenttoclauseset (dumbnegatelitlst hyps)
clauses))
(nontautpapplications (length A)))
; In this treatment, the final set of goal clauses will the union of
; sets A and C. A stands for the "application clauses" (obtained by
; adding the use hyps to each clause) and C stands for the "constraint
; clauses." Nontautpapplications is A.
(cond
((null clauses)
; In this case, there is no point in generating the constraints! We
; anticipate this happening if the user provides both a :use and a
; :cases hint and the :cases hint (which is applied first) proves the
; goal completely. If that were to happen, clauses would be output of
; the :cases hint and pspv would be its output pspv, from which the
; :cases had been deleted. So we just delete the :use hint from that
; pspv and call it quits, without reporting a :use hint at all.
(mv 'hit nil nil newpspv))
(t
(mvlet
(signal C ttree irrelpspv)
(preprocessclause constraintcl nil pspv wrld state)
(declare (ignore irrelpspv))
(cond
((eq signal 'miss)
(mv 'hit
(conjoinclausesets
A
(conjoinclausetoclauseset constraintcl
nil))
(addtotagtree :use
(cons (cdr temp)
nontautpapplications)
nil)
newpspv))
((or (tagtreeoccur 'hiddenpreprocessclause
t
ttree)
(and C
(null (cdr C))
(equal (list (prettyifyclause
(car C)
(let*abstractionp state)
wrld))
constraintcl)))
(mv 'hit
(conjoinclausesets A C)
(addtotagtree :use
(cons (cdr temp)
nontautpapplications)
nil)
newpspv))
(t (mv 'hit
(conjoinclausesets A C)
(addtotagtree :use
(cons (cdr temp)
nontautpapplications)
(addtotagtree 'preprocessttree
ttree
nil))
newpspv))))))))
(defun applycaseshintclause (temp cl pspv wrld)
; Temp is the value associated with :cases in a pspv :hintsettings
; and is nonnil. It is thus of the form (:cases term1 ... termn).
; For each termi we create a new clause by adding its negation to the
; goal clause, cl, and in addition, we create a final goal by adding
; all termi. As with a :use hint, we remove the :cases hint from the
; hintsettings so that the waterfall doesn't loop!
; We return (mv 'hit newclauses ttree newpspv).
(let ((newclauses
(removetrivialclauses
(conjoinclausetoclauseset
(disjoinclauses
(cdr temp)
cl)
(splitonassumptions
; We reverse the termlist so the user can see goals corresponding to the
; order of the terms supplied.
(dumbnegatelitlst (reverse (cdr temp)))
cl
nil))
wrld)))
(mv 'hit
newclauses
(addtotagtree :cases (cons (cdr temp) newclauses) nil)
(change provespecvar pspv
:hintsettings
(remove1equal temp
(access provespecvar
pspv
:hintsettings))))))
(defun applytophintsclause (clid cl hist pspv wrld state)
; This is a standard clause processor of the waterfall. It is odd in that it
; is a noop unless there is a :use, :by, :cases, or :bdd hint in the
; :hintsettings of pspv. If there is, we remove it and apply it. By
; implementing these hints via this specialpurpose processor we can take
; advantage of the waterfall's alreadyprovided mechanisms for handling
; multiple clauses and output.
; We return 4 values. The first is a signal that is either 'hit,
; 'miss, or 'error. When the signal is 'miss, the other 3 values are
; irrelevant. When the signal is 'error, the second result is a pair
; of the form (str . alist) which allows us to give our caller an
; error message to print. In this case, the other two values are
; irrelevant. When the signal is 'hit, the second result is the list
; of new clauses, the third is a ttree that will become that component
; of the historyentry for this process, and the fourth is the
; modified pspv.
; We need clid passed in so that we can store it in the bddnote, in the case
; of a :bdd hint.
(declare (ignore hist))
(let ((usetemp
(assoceq :use (access provespecvar pspv :hintsettings))))
(cond
((null usetemp)
(let ((temp (assoceq :by (access provespecvar pspv :hintsettings))))
(cond
((null temp)
(let ((temp (assoceq :cases
(access provespecvar pspv :hintsettings))))
(cond
((null temp)
(let ((temp (assoceq :bdd
(access provespecvar pspv :hintsettings))))
(cond
((null temp)
(mv 'miss nil nil nil))
(t (bddclause (cdr temp) clid cl
(change provespecvar pspv
:hintsettings
(remove1equal temp
(access provespecvar
pspv
:hintsettings)))
wrld state)))))
(t
(applycaseshintclause temp cl pspv wrld)))))
; If there is a :by hint then it is of one of the two forms (:by . name) or
; (:by lmilst thm constraintcl k eventnames newentries). The first form
; indicates that we are to give this clause a bye and let the proof fail late.
; The second form indicates that the clause is supposed to be subsumed by thm,
; viewed as a set of clauses, but that we have to prove constraintcl to obtain
; thm and that constraintcl is really a conjunction of k constraints. Lmilst
; is a singleton list containing the lmi that generated this thmcl.
((symbolp (cdr temp))
; So this is of the first form, (:by . name). We want the proof to fail, but
; not now. So we act as though we proved cl (we hit, produce no new clauses
; and don't change the pspv) but we return a tag tree containing the tag
; :bye with the value (name . cl). At the end of the proof we must search
; the tag tree and see if there are any :byes in it. If so, the proof failed
; and we should display the named clauses.
(mv 'hit nil (addtotagtree :bye (cons (cdr temp) cl) nil) pspv))
(t
(let ((lmilst (cadr temp)) ; a singleton list
(thm (caddr temp))
(constraintcl (cadddr temp))
(newpspv
(change provespecvar pspv
:hintsettings
(remove1equal temp
(access provespecvar
pspv
:hintsettings)))))
; We remove the :by from the hintsettings. Why do we remove the :by?
; If we don't the subgoals we create from constraintcl will also see
; the :by!
; We insist that thmclset subsume cl  more precisely, that cl be
; subsumed by some member of thmclset.
; WARNING: See the warning about the processing in translatebyhint.
(let* ((easywinp
(if (and cl (null (cdr cl)))
(equal (car cl) thm)
(equal thm
(implicate (conjoin
(dumbnegatelitlst (butlast cl 1)))
(car (last cl))))))
(cl1 (if (and (not easywinp)
(ffnnameplst 'implies cl))
(expandsomenonrecfnslst '(implies) cl wrld)
cl))
(clset (if (not easywinp)
; Before Version_2.7 we only called clausify here when (and (null hist) cl1
; (null (cdr cl1))). But Robert Krug sent an example in which a :by hint was
; given on a subgoal that had been produced from "Goal" by destructor
; elimination. That subgoal was identical to the theorem given in the :by
; hint, and hence easywinp is true; but before Version_2.7 we did not look for
; the easy win. So, what happened was that thmclset was the result of
; clausifying the theorem given in the :by hint, but clset was a singleton
; containing cl1, which still has IF terms.
(clausify (disjoin cl1) nil t wrld)
(list cl1)))
(thmclset (if easywinp
(list (list thm))
; WARNING: Below we process the thm obtained from the lmi. In particular, we
; expand certain nonrec fns and we clausify it. For heuristic sanity, the
; processing done here should exactly duplicate that done above for clset.
; The reason is that we want it to be the case that if the user gives a :by
; hint that is identical to the goal theorem, the subsumption is guaranteed to
; succeed. If the processing of the goal theorem is slightly different than
; the processing of the hint, that guarantee is invalid.
(clausify
(expandsomenonrecfns '(implies) thm wrld)
nil
t
wrld)))
(val (list* (cadr temp) thmclset (cdddr temp)))
(subsumes (and (not easywinp) ; otherwise we don't care
(clausesetsubsumes nil
; We supply nil just above, rather than (say) *initsubsumescount*, because
; the user will be able to see that if the subsumption check goes out to lunch
; then it must be because of the :by hint. For example, it takes 167,997,825
; calls of onewayunify1 (more than 2^27, not far from the fixnum limit in
; many Lisps) to do the subsumption check for the following, yet in a feasible
; time (26 seconds on Allegro CL 7.0, on a 2.6GH Pentium 4). So we prefer not
; to set a limit.
#
(defstub p (x) t)
(defstub s (x1 x2 x3 x4 x5 x6 x7 x8) t)
(defaxiom ax
(implies (and (p x1) (p x2) (p x3) (p x4)
(p x5) (p x6) (p x7) (p x8))
(s x1 x2 x3 x4 x5 x6 x7 x8))
:ruleclasses nil)
(defthm prop
(implies (and (p x1) (p x2) (p x3) (p x4)
(p x5) (p x6) (p x7) (p x8))
(s x8 x7 x3 x4 x5 x6 x1 x2))
:hints (("Goal" :by ax)))
#
thmclset clset)))
(success (or easywinp subsumes)))
; Before the fullblown subsumption check we ask if the two sets are identical
; and also if they are each singleton sets and the thmclset's clause is a
; subset of the other clause. These are fast and commonly successful checks.
(cond
(success
; Ok! We won! To produce constraintcl as our goal we first
; preprocess it as though it had come down from the top. See the
; handling of :use hints below for some comments on this. This code
; was copied from that historically older code.
(mvlet (signal clauses ttree irrelpspv)
(preprocessclause constraintcl nil pspv wrld state)
(declare (ignore irrelpspv))
(cond ((eq signal 'miss)
(mv 'hit
(conjoinclausetoclauseset constraintcl
nil)
(addtotagtree :by val nil)
newpspv))
((or (tagtreeoccur 'hiddenpreprocessclause
t
ttree)
(and clauses
(null (cdr clauses))
(equal (list
(prettyifyclause
(car clauses)
(let*abstractionp state)
wrld))
constraintcl)))
; If preprocessing produced a single clause that prettyifies to the
; clause we had, then act as though it didn't do anything (but use its
; output clause set). This is akin to the 'hiddenpreprocessclause
; hack of preprocessclause, which, however, is intimately tied to the
; displayedgoal input to prove and not to the input to prettyify
; clause. We look for the 'hiddenpreprocessclause tag just in case.
(mv 'hit
clauses
(addtotagtree :by val nil)
newpspv))
(t
(mv 'hit
clauses
(addtotagtree
:by val
(addtotagtree 'preprocessttree
ttree
nil))
newpspv)))))
(t (mv 'error
(msg "When a :by hint is used to supply a lemmainstance ~
for a given goalspec, the formula denoted by the ~
lemmainstance must subsume the goal. This did not ~
happen~@1! The lemmainstance provided was ~x0, ~
which denotes the formula ~P24 (when converted to a ~
set of clauses and then printed as a formula). ~
This formula was not found to subsume the goal ~
clause, ~P34.~~%Consider a :use hint instead; see ~
:DOC hints."
(car lmilst)
; The following is not possible, because we are not putting a limit on the
; number of onewayunify1 calls in our subsumption check (see above). But we
; leave this code here in case we change our minds on that.
(if (eq subsumes '?)
" because our subsumption heuristics were unable ~
to decide the question"
"")
(untranslate thm t wrld)
(prettyifyclauseset clset
(let*abstractionp state)
wrld)
nil)
nil
nil)))))))))
(t
; Usetemp is a nonnil :use hint.
(let ((casestemp
(assoceq :cases
(access provespecvar pspv :hintsettings))))
(cond
((null casestemp)
(applyusehintclauses usetemp (list cl) pspv wrld state))
(t
; In this case, we have both :use and :cases hints. Our
; interpretation of this is that we split clause cl according to the
; :cases and then apply the :use hint to each case. By the way, we
; don't have to consider the possibility of our having a :use and :by
; or :bdd. That is ruled out by translatehints.
(mvlet
(signal casesclauses casesttree casespspv)
(applycaseshintclause casestemp cl pspv wrld)
(declare (ignore signal))
; We know the signal is 'HIT.
(mvlet
(signal useclauses usettree usepspv)
(applyusehintclauses usetemp
casesclauses
casespspv
wrld state)
(declare (ignore signal))
; Despite the names, useclauses and usepspv both reflect the work we
; did for cases. However, usettree was built from scratch as was
; casesttree and we must combine them.
(mv 'HIT
useclauses
(constagtrees usettree casesttree)
usepspv))))))))))
; We now develop the code for explaining the action taken above. First we
; arrange to print a phrase describing a list of lmis.
(defun lmiseed (lmi)
; The "seed" of an lmi is either a symbolic name or else a term. In
; particular, the seed of a symbolp lmi is the lmi itself, the seed of
; a rune is its base symbol, the seed of a :theorem is the term
; indicated, and the seed of an :instance or :functionalinstance is
; obtained recursively from the inner lmi.
; Warning: If this is changed so that runes are returned as seeds, it
; will be necessary to change the use of filteratoms below.
(cond ((atom lmi) lmi)
((eq (car lmi) :theorem) (cadr lmi))
((or (eq (car lmi) :instance)
(eq (car lmi) :functionalinstance))
(lmiseed (cadr lmi)))
(t (basesymbol lmi))))
(defun lmitechs (lmi)
(cond
((atom lmi) nil)
((eq (car lmi) :theorem) nil)
((eq (car lmi) :instance)
(addtosetequal "instantiation" (lmitechs (cadr lmi))))
((eq (car lmi) :functionalinstance)
(addtosetequal "functional instantiation" (lmitechs (cadr lmi))))
(t nil)))
(defun lmiseedlst (lmilst)
(cond ((null lmilst) nil)
(t (addtoseteq (lmiseed (car lmilst))
(lmiseedlst (cdr lmilst))))))
(defun lmitechslst (lmilst)
(cond ((null lmilst) nil)
(t (unionequal (lmitechs (car lmilst))
(lmitechslst (cdr lmilst))))))
(defun filteratoms (flg lst)
; If flg=t we return all the atoms in lst. If flg=nil we return all
; the nonatoms in lst.
(cond ((null lst) nil)
((eq (atom (car lst)) flg)
(cons (car lst) (filteratoms flg (cdr lst))))
(t (filteratoms flg (cdr lst)))))
(defun tilde@lmiphrase (lmilst k eventnames)
; Lmilst is a list of lmis. K is the number of constraints we have to
; establish. Eventnames is a list of names of events that justify the
; omission of certain proof obligations, because they have already been proved
; on behalf of those events. We return an object suitable for printing via ~@
; that will print the phrase
; can be derived from ~&0 via instantiation and functional
; instantiation, provided we can establish the ~n1 constraints
; when eventnames is nil, or else
; can be derived from ~&0 via instantiation and functional instantiation,
; bypassing constraints that have been proved when processing the events ...,
; [or: instead of ``the events,'' use ``events including'' when there
; is at least one unnamed event involved, such as a verifyguards
; event]
; provided we can establish the remaining ~n1 constraints
; Of course, the phrase is altered appropriately depending on the lmis
; involved. There are two uses of this phrase. When :by reports it
; says "As indicated by the hint, this goal is subsumed by ~x0, which
; CAN BE ...". When :use reports it says "We now add the hypotheses
; indicated by the hint, which CAN BE ...".
(let* ((seeds (lmiseedlst lmilst))
(lemmanames (filteratoms t seeds))
(thms (filteratoms nil seeds))
(techs (lmitechslst lmilst)))
(cond ((null techs)
(cond ((null thms)
(msg "can be obtained from ~&0"
lemmanames))
((null lemmanames)
(msg "can be obtained from the ~
~#0~[~/constraint~/~n1 constraints~] generated"
(zerooneormore k)
k))
(t (msg "can be obtained from ~&0 and the ~
~#1~[~/constraint~/~n2 constraints~] ~
generated"
lemmanames
(zerooneormore k)
k))))
((null eventnames)
(msg "can be derived from ~&0 via ~*1~#2~[~/, provided we can ~
establish the constraint generated~/, provided we can ~
establish the ~n3 constraints generated~]"
seeds
(list "" "~s*" "~s* and " "~s*, " techs)
(zerooneormore k)
k))
(t
(msg "can be derived from ~&0 via ~*1, bypassing constraints that ~
have been proved when processing ~#2~[events including~/the ~
event~#3~[~/s~]~] ~&3~#4~[~/, provided we can establish the ~
constraint generated~/, provided we can establish the ~n5 ~
constraints generated~]"
seeds
(list "" "~s*" "~s* and " "~s*, " techs)
; Recall that an eventname of 0 is really an indication that the event in
; question didn't actually have a name. See installevent.
(if (member 0 eventnames) 0 1)
(if (member 0 eventnames)
(remove 0 eventnames)
eventnames)
(zerooneormore k)
k)))))
(defun applytophintsclausemsg1
(signal clid clauses speciousp ttree pspv state)
; This function is one of the waterfallmsg subroutines. It has the standard
; arguments of all such functions: the signal, clauses, ttree and pspv produced
; by the given processor, in this case preprocessclause (except that for bdd
; processing, the ttree comes from bddclause, which is similar to
; simplifyclause, which explains why we also pass in the argument speciousp).
; It produces the report for this step.
; Note: signal and pspv are really ignored, but they don't appear to be when
; they are passed to simplifyclausemsg1 below, so we cannot declare them
; ignored here.
(cond ((taggedobject :bye ttree)
; The object associated with the :bye tag is (name . cl). We are interested
; only in name here.
(fms "But we have been asked to pretend that this goal is ~
subsumed by the asyettobeproved ~x0.~"
(list (cons #\0 (car (cdr (taggedobject :bye ttree)))))
(proofsco state)
state
nil))
((taggedobject :by ttree)
(let* ((obj (cdr (taggedobject :by ttree)))
; Obj is of the form (lmilst thmclset constraintcl k eventnames
; newentries).
(lmilst (car obj))
(thmclset (cadr obj))
(k (car (cdddr obj)))
(eventnames (cadr (cdddr obj)))
(ttree (cdr (taggedobject 'preprocessttree ttree))))
(fms "~#0~[But, as~/As~/As~] indicated by the hint, this goal is ~
subsumed by ~P18, which ~@2.~#3~[~/ By ~*4 we reduce the ~
~#5~[constraint~/~n6 constraints~] to ~#0~[T~/the following ~
conjecture~/the following ~n7 conjectures~].~]~"
(list (cons #\0 (zerooneormore clauses))
(cons #\1 (prettyifyclauseset
thmclset
(let*abstractionp state)
(w state)))
(cons #\2 (tilde@lmiphrase lmilst k eventnames))
(cons #\3 (if (int= k 0) 0 1))
(cons #\4 (tilde*preprocessphrase ttree))
(cons #\5 (if (int= k 1) 0 1))
(cons #\6 k)
(cons #\7 (length clauses))
(cons #\8 nil))
(proofsco state)
state
(termevisctuple nil state))))
((taggedobject :use ttree)
(let* ((useobj (cdr (taggedobject :use ttree)))
; The presence of :use indicates that a :use hint was applied to one
; or more clauses to give the output clauses. If there is also a
; :cases tag in the ttree, then the input clause was split into to 2
; or more cases first and then the :use hint was applied to each. If
; there is no :cases tag, the :use hint was applied to the input
; clause alone. Each application of the :use hint adds literals to
; the target clause(s). This generates a set, A, of ``applications''
; but A need not be the same length as the set of clauses to which we
; applied the :use hint since some of those applications might be
; tautologies. In addition, the :use hint generated some constraints,
; C. The set of output clauses, say G, is (C U A). But C and A are
; not necessarily disjoint, e.g., some constraints might happen to be
; in A. Once upon a time, we reported on the number of nonA
; constraints, i.e., C', where C' = C\A. Because of the complexity
; of the grammar, we do not reveal to the user all the numbers: how
; many nontautological cases, how many hypotheses, how many
; nontautological applications, how many constraints generated, how
; many after preprocessing the constraints, how many overlaps between
; C and A, etc. Instead, we give a fairly generic message. But we
; have left (as comments) the calculation of the key numbers in case
; someday we revisit this.
; The shape of the useobj, which is the value of the :use tag, is
; ((lmilst (hyp1 ...) cl k eventnames newentries)
; . nontautpapplications) where nontautpapplications is the number
; of nontautologies created by the one or more applications of the
; :use hint, i.e., A. (But we do not report this.)
(lmilst (car (car useobj)))
(hyps (cadr (car useobj)))
(k (car (cdddr (car useobj)))) ;;; C
(eventnames (cadr (cdddr (car useobj))))
; (nontautpapplications (cdr useobj)) ;;; A
(preprocessttree
(cdr (taggedobject 'preprocessttree ttree)))
; (lenA nontautpapplications) ;;; A
(lenG (len clauses)) ;;; G
(lenC k) ;;; C
; (lenCprime ( lenG lenA)) ;;; C'
(casesobj (cdr (taggedobject :cases ttree)))
; If there is a casesobj it means we had a :cases and a :use; the
; form of casesobj is (splittingterms . caseclauses), where
; caseclauses is the result of splitting on the literals in
; splittingterms. We know that caseclauses is nonnil. (Had it
; been nil, no :use would have been reported.) Note that if casesobj
; is nil, i.e., there was no :cases hint applied, then these next two
; are just nil. But we'll want to ignore them if casesobj is nil.
; (splittingterms (car casesobj))
; (caseclauses (cdr casesobj))
)
(fms
"~#0~[But we~/We~] ~
~#x~[split the goal into the cases specified by ~
the :CASES hint and augment each case~
~/~
augment the goal~] ~
with the ~#1~[hypothesis~/hypotheses~] provided by ~
the :USE hint. ~#1~[The hypothesis~/These hypotheses~] ~
~@2~
~#3~[~/; the constraint~#4~[~/s~] can be ~
simplified using ~*5~]. ~
~#6~[This reduces the goal to T.~/~
We are left with the following subgoal.~/~
We are left with the following ~n7 subgoals.~]~%"
(list
(cons #\x (if casesobj 0 1))
(cons #\0 (if (> lenG 0) 1 0)) ;;; G>0
(cons #\1 hyps)
(cons #\2 (tilde@lmiphrase lmilst k eventnames))
(cons #\3 (if (> lenC 0) 1 0)) ;;; C>0
(cons #\4 (if (> lenC 1) 1 0)) ;;; C>1
(cons #\5 (tilde*preprocessphrase preprocessttree))
(cons #\6 (if (equal lenG 0) 0 (if (equal lenG 1) 1 2)))
(cons #\7 lenG))
(proofsco state)
state
(termevisctuple nil state))))
((taggedobject :cases ttree)
(let* ((casesobj (cdr (taggedobject :cases ttree)))
; The casesobj here is of the form (termlist . newclauses), where
; newclauses is the result of splitting on the literals in termlist.
; (splittingterms (car casesobj))
(newclauses (cdr casesobj)))
(cond
(newclauses
(fms "We now split the goal into the cases specified by ~
the :CASES hint to produce ~n0 new nontrivial ~
subgoal~#1~[~/s~].~"
(list (cons #\0 (length newclauses))
(cons #\1 (if (cdr newclauses) 1 0)))
(proofsco state)
state
(termevisctuple nil state)))
(t
(fms "But the resulting goals are all true by case reasoning."
nil
(proofsco state)
state
nil)))))
(t
; Normally we expect (taggedobject 'bddnote ttree) in this case, but it is
; possible that forwardchaining after trivial equivalence removal proved
; the clause, without actually resorting to bdd processing.
(simplifyclausemsg1 signal clid clauses speciousp ttree pspv
state))))
(mutualrecursion
(defun decorateforcedgoals1 (goaltree clauseidlist forcedclauseid)
(let ((clid (access goaltree goaltree :clid))
(newchildren (decorateforcedgoals1lst
(access goaltree goaltree :children)
clauseidlist
forcedclauseid)))
(cond
((memberequal clid clauseidlist)
(let ((processor (access goaltree goaltree :processor)))
(change goaltree goaltree
:processor
(list* (car processor) :forced forcedclauseid (cddr processor))
:children newchildren)))
(t
(change goaltree goaltree
:children newchildren)))))
(defun decorateforcedgoals1lst
(goaltreelst clauseidlist forcedclauseid)
(cond
((null goaltreelst)
nil)
((atom goaltreelst)
; By the time we've gotten this far, we've gotten to the next forcing round,
; and hence there shouldn't be any children remaining to process. Of course, a
; forced goal can generate forced subgoals, so we can't say that there are no
; children  but we CAN say that there are none remaining to process.
(er hard 'decorateforcedgoals1lst
"Unexpected goaltree in call ~x0"
(list 'decorateforcedgoals1lst
goaltreelst
clauseidlist
forcedclauseid)))
(t (cons (decorateforcedgoals1
(car goaltreelst) clauseidlist forcedclauseid)
(decorateforcedgoals1lst
(cdr goaltreelst) clauseidlist forcedclauseid)))))
)
(defun decorateforcedgoals (forcinground goaltree clauseidlistlist n)
; At the top level, n is either an integer greater than 1 or else is nil. This
; corresponds respectively to whether or not there is more than one goal
; produced by the forcing round.
(if (null clauseidlistlist)
goaltree
(decorateforcedgoals
forcinground
(decorateforcedgoals1 goaltree
(car clauseidlistlist)
(make clauseid
:forcinground forcinground
:poollst nil
:caselst (and n (list n))
:primes 0))
(cdr clauseidlistlist)
(and n (1 n)))))
(defun decorateforcedgoalsinprooftree
(forcinground prooftree clauseidlistlist n)
(if (null prooftree)
nil
(cons (decorateforcedgoals
forcinground (car prooftree) clauseidlistlist n)
(decorateforcedgoalsinprooftree
forcinground (cdr prooftree) clauseidlistlist n))))
(defun assumnotelisttoclauseidlist (assumnotelist)
(if (null assumnotelist)
nil
(cons (access assumnote (car assumnotelist) :clid)
(assumnotelisttoclauseidlist (cdr assumnotelist)))))
(defun assumnotelistlisttoclauseidlistlist (assumnotelistlist)
(if (null assumnotelistlist)
nil
(cons (assumnotelisttoclauseidlist (car assumnotelistlist))
(assumnotelistlisttoclauseidlistlist (cdr assumnotelistlist)))))
(defun extendprooftreeforforcinground
(forcinground parentclauseid clauseidlistlist state)
; This function pushes a new goal tree onto the global prooftree. However, it
; decorates the existing goal trees so that the appropriate previous forcing
; round's goals are "blamed" for the new forcing round goals.
(cond
((null clauseidlistlist)
; then the proof is complete!
state)
(t
(let ((n (length clauseidlistlist))) ;note n>0
(fputglobal
'prooftree
(cons (make goaltree
:clid parentclauseid
:processor :FORCINGROUND
:children n
:fanout n)
(decorateforcedgoalsinprooftree
forcinground
(fgetglobal 'prooftree state)
clauseidlistlist
(if (null (cdr clauseidlistlist))
nil
(length clauseidlistlist))))
state)))))
(defun previousprocesswasspeciousp (hist)
; Context: We are about to print clid and clause in waterfallmsg.
; Then we will print the message associated with the first entry in
; hist, which is the entry for the processor which just hit clause and
; for whom we are reporting. However, if the previous entry in the
; history was specious, then the clid and clause were printed when
; the specious hit occurred and we should not reprint them. Thus, our
; job here is to decide whether the previous process in the history
; was specious.
; There are complications though, introduced by the existence of
; settleddownclause. In the first place, settleddownclause ALWAYS
; produces a set of clauses containing the input clause and so ought
; to be considered specious every time it hits! We avoid that in
; waterfallstep and never mark a settleddownclause as specious, so
; we can assoc for them. More problematically, consider the
; possibility that the first simplification  the one before the
; clause settled down  was specious. Recall that the
; presettleddownclause simplifications are weak. Thus, it is
; imaginable that after settling down, other simplifications may
; happen and allow a nonspecious simplification. Thus,
; settleddownclause actually does report its "hit" (and thus add its
; mark to the history so as to enable the subsequent simplifyclause
; to pull out the stops) following even specious simplifications.
; Thus, we must be prepared here to see a nonspecious
; settleddownclause which followed a specious simplification.
; Note: It is possible that the first entry on hist is specious. That
; is, if the process on behalf of which we are about to print is in
; fact specious, it is so marked right now in the history. But that
; is irrelevant to our question. We don't care if the current guy
; specious, we want to know if his "predecessor" was. For what it is
; worth, as of this writing, it is thought to be impossible for two
; adjacent history entries to be marked 'SPECIOUS. Only
; simplifyclause, we think, can produce specious hits. Whenever a
; specious simplifyclause occurs, it is treated as a 'miss and we go
; on to the next process, which is not simplifyclause. Note that if
; elim could produce specious 'hits, then we might get two in a row.
; Observe also that it is possible for two successive simplifies to be
; specious, but that they are separated by a nonspecious
; settleddownclause. (Our code doesn't rely on any of this, but it
; is sometimes helpful to be able to read such thoughts later as a
; hint of what we were thinking when we made some terrible coding
; mistake and so this might illuminate some error we're making today.)
(cond ((null hist) nil)
((null (cdr hist)) nil)
((consp (access historyentry (cadr hist) :processor)) t)
((and (eq (access historyentry (cadr hist) :processor)
'settleddownclause)
(consp (cddr hist))
(consp (access historyentry (caddr hist) :processor)))
t)
(t nil)))
(defun initializeprooftree1 (parentclauseid x poollst forcinground ctx
state)
; x is from the "x" argument of waterfall. Thus, if we are starting a forcing
; round then x is list of pairs (assumnotelst . clause) where the clauseids
; from the assumnotes are the names of goals from the previous forcing round to
; "blame" for the creation of that clause.
(pprogn
; The user might have started up proof trees with something like (assign
; inhibitoutputlst nil). In that case we need to ensure that appropriate
; state globals are initialized. Note that startprooftreefn does not
; override existing bindings of those state globals (which the user may have
; deliberately set).
(startprooftreefn nil state)
(fputglobal 'prooftreectx ctx state)
(cond
((and (null poollst)
(eql forcinground 0))
(fputglobal 'prooftree
nil ;CAR doesn't matter (to be overwritten)
state))
(poollst
(fputglobal 'prooftree
(cons (let ((n (length x)))
(make goaltree
:clid parentclauseid
:processor :INDUCT
:children (if (= n 0) nil n)
:fanout n))
(fgetglobal 'prooftree state))
state))
(t
(extendprooftreeforforcinground
forcinground parentclauseid
(assumnotelistlisttoclauseidlistlist (stripcars x))
state)))))
(defun initializeprooftree (parentclauseid x ctx state)
; We assume (not (outputignoredp 'prooftree state)).
(let ((poollst (access clauseid parentclauseid :poollst))
(forcinground (access clauseid parentclauseid
:forcinground))
(inhibitoutputlst (fgetglobal 'inhibitoutputlst state)))
(pprogn
(io? prooftree nil state
(ctx forcinground poollst x parentclauseid)
(initializeprooftree1 parentclauseid x poollst forcinground ctx
state))
(cond ((and (null poollst)
(eql forcinground 0)
(membereq 'prove inhibitoutputlst)
(not (membereq 'prooftree inhibitoutputlst)))
(warning$ ctx nil
"The printing of prooftrees is enabled, but the ~
printing of proofs is not. You may want to execute ~
:STOPPROOFTREE in order to inhibit prooftrees as ~
well."))
(t state))
(io? prove nil state
(forcinground poollst)
(cond ((intersectpeq '(prove prooftree)
(fgetglobal 'inhibitoutputlst state))
state)
((and (null poollst)
(eql forcinground 0))
(fms "<< Starting proof tree logging >>~"
nil (proofsco state) state nil))
(t state))))))
(defconst *star1clauseid*
(make clauseid
:forcinground 0
:poollst '(1)
:caselst nil
:primes 0))
(mutualrecursion
(defun revertgoaltree (goaltree)
; Replaces every (pushclause *n) with (pushclause *star1clauseid*
; :REVERT), meaning that we are reverting.
(let ((processor (access goaltree goaltree :processor)))
(cond
((and (consp processor)
(eq (car processor) 'pushclause))
(change goaltree goaltree
:processor (list 'pushclause *star1clauseid* :REVERT)))
(t
(change goaltree goaltree
:children
(revertgoaltreelst (access goaltree goaltree
:children)))))))
(defun revertgoaltreelst (goaltreelst)
(cond
((atom goaltreelst)
nil)
(t (cons (revertgoaltree (car goaltreelst))
(revertgoaltreelst (cdr goaltreelst))))))
)
(defun incrementprooftree
(clid ttree processor clauses newhist signal pspv state)
; Modifies the global prooftree so that it incorporates the given clid, which
; creates n child goals via processor. Also prints out the proof tree.
(if (or (eq processor 'settleddownclause)
(and (consp newhist)
(consp (access historyentry (car newhist)
:processor))))
state
(let* ((forcinground (access clauseid clid :forcinground))
(abortingp (and (eq signal 'abort)
(membereq
(cdr (taggedobject 'abortcause ttree))
'(emptyclause donotinduct))))
(processor
(cond
((taggedobject 'assumption ttree)
(list processor :forced))
((eq processor 'pushclause)
(list* 'pushclause
(make clauseid
:forcinground forcinground
:poollst
(poollst
(cdr (access provespecvar pspv
:pool)))
:caselst nil
:primes 0)
(if abortingp '(:ABORT) nil)))
(t processor)))
(n (length clauses))
(startingprooftree (fgetglobal 'prooftree state))
(newgoaltree
(insertintogoaltree clid
processor
(if (= n 0)
nil
n)
(car startingprooftree))))
(pprogn
(if newgoaltree
(fputglobal 'prooftree
(if (and (consp processor)
(eq (car processor) 'pushclause)
(eq signal 'abort)
(not abortingp))
(if (and (= forcinground 0)
(null (cdr startingprooftree)))
(list (revertgoaltree newgoaltree))
(er hard 'incrementprooftree
"Attempted to ``revert'' the proof tree ~
with forcing round ~x0 and proof tree of ~
length ~x1. This reversion should only ~
have been tried with forcing round 0 and ~
proof tree of length 1."
forcinground
(length startingprooftree)))
(pruneprooftree
forcinground nil
(cons newgoaltree
(cdr startingprooftree))))
state)
(let ((err (er hard 'incrementprooftree
"Found empty goal tree from call ~x0"
(list 'insertintogoaltree
clid
processor
(if (= n 0)
nil
n)
(car startingprooftree)))))
(declare (ignore err))
state))
(printprooftree state)))))
; Section: WATERFALL
; The waterfall is a simple finite state machine (whose individual
; state transitions are very complicated). Abstractly, each state
; contains a "processor" and two neighbor states, the "hit" state and
; the "miss" state. Roughly speaking, when we are in a state we apply
; its processor to the input clause and obtain either a "hit" signal
; (and some new clauses) or "miss" signal. We then transit to the
; appropriate state and continue.
; However, the "hit" state for every state is that point in the falls,
; where 'applytophintsclause is the processor.
; applytophintsclause <+
;  
; preprocessclause >
;  
; simplifyclause >
;  
; settleddownclause>
;  
; ... 
;  
; pushclause >+
; WARNING: Waterfall1lst knows that 'preprocessclause follows
; 'applytophintsclause!
; We therefore represent a state s of the waterfall as a pair whose car
; is the processor for s and whose cdr is the miss state for s. The hit
; state for every state is the constant state below, which includes, by
; successive cdrs, every state below it in the falls.
; Because the word "STATE" has a very different meaning in ACL2 than we have
; been using thus far in this discussion, we refer to the "states" of the
; waterfall as "ledges" and basically name them by the processors on each.
(defconst *preprocessclauseledge*
'(applytophintsclause
preprocessclause
simplifyclause
settleddownclause
eliminatedestructorsclause
fertilizeclause
generalizeclause
eliminateirrelevanceclause
pushclause))
; Observe that the cdr of the 'simplifyclause ledge, for example, is the
; 'settleddownclause ledge, etc. That is, each ledge contains the
; ones below it.
; Note: To add a new processor to the waterfall you must add the
; appropriate entry to the *preprocessclauseledge* and redefine
; waterfallstep and waterfallmsg, below.
; If we are on ledge p with input cl and pspv, we apply processor p to
; our input and obtain signal, some cli, and pspv'. If signal is
; 'abort, we stop and return pspv'. If signal indicates a hit, we
; successively process each cli, starting each at the top ledge, and
; accumulating the successive pspvs starting from pspv'. If any cli
; aborts, we abort; otherwise, we return the final pspv. If signal is
; 'miss, we fall to the next lower ledge with cl and pspv. If signal
; is 'error, we return abort and propagate the error message upwards.
; The waterfall also manages the output, by case switching on the
; processor. The next function handles the printing of the formula
; and the output for those processes that hit.
(defun waterfallmsg1
(processor clid signal clauses newhist ttree pspv state)
(pprogn
(case
processor
(applytophintsclause
; Note that the args passed to applytophintsclause, and to
; simplifyclausemsg1 below, are nonstandard. This is what allows the
; simplify message to detect and report if the just performed simplification
; was specious.
(applytophintsclausemsg1
signal clid clauses
(consp (access historyentry (car newhist)
:processor))
ttree pspv state))
(preprocessclause
(preprocessclausemsg1 signal clauses ttree pspv state))
(simplifyclause
(simplifyclausemsg1 signal clid clauses
(consp (access historyentry (car newhist)
:processor))
ttree pspv state))
(settleddownclause
(settleddownclausemsg1 signal clauses ttree pspv state))
(eliminatedestructorsclause
(eliminatedestructorsclausemsg1 signal clauses ttree
pspv state))
(fertilizeclause
(fertilizeclausemsg1 signal clauses ttree pspv state))
(generalizeclause
(generalizeclausemsg1 signal clauses ttree pspv state))
(eliminateirrelevanceclause
(eliminateirrelevanceclausemsg1 signal clauses ttree
pspv state))
(otherwise
(pushclausemsg1 (access clauseid clid :forcinground)
signal clauses ttree pspv state)))
(incrementtimer 'printtime state)))
(defun waterfallmsg
(processor clid signal clauses newhist ttree pspv state)
; This function prints the report associated with the given processor
; on some input clause, clause, with output signal, clauses, ttree,
; and pspv. The code below consists of two distinct parts. First we
; print the message associated with the particular processor. Then we
; return two results: a "jpplflg" and the state.
; The jpplflg is either nil or a poollst. When nonnil, the
; jpplflg means we just pushed a clause into the pool and assigned it
; the name that is the value of the flag. "Jppl" stands for "just
; pushed pool list". This flag is passed through the waterfall and
; eventually finds its way to the popclause after the waterfall,
; where it is used to control the optional printing of the popped
; clause. If the jpplflg is nonnil when we pop, it means we need
; not redisplay the clause because it was just pushed and we can
; refer to it by name.
; This function increments timers. Upon entry, the accumulated time is
; charged to 'provetime. The time spent in this function is charged
; to 'printtime.
(pprogn
(incrementtimer 'provetime state)
(io? prooftree nil state
(pspv signal
newhist clauses processor ttree clid)
(pprogn
(incrementprooftree
clid ttree processor clauses newhist signal pspv state)
(incrementtimer 'prooftreetime state)))
(io? prove nil state
(pspv ttree newhist clauses signal clid processor)
(waterfallmsg1 processor clid signal clauses newhist ttree pspv
state))
(mv (cond ((eq processor 'pushclause)
(poollst (cdr (access provespecvar pspv :pool))))
(t nil))
state)))
; The waterfall is responsible for storing the ttree produced by each
; processor in the pspv. That is done with:
(defun putttreeintopspv (ttree pspv)
(change provespecvar pspv
:tagtree (constagtrees ttree
(access provespecvar pspv :tagtree))))
(defun setclidsofassumptions (ttree clid)
; We scan the tag tree ttree, looking for 'assumptions. Recall that each has a
; :assumnotes field containing exactly one assumnote record, which contains a
; :clid field. We assume that :clid field is empty. We put clid into it.
; We return a copy of ttree.
(cond
((null ttree) nil)
((symbolp (caar ttree))
(cond
((eq (caar ttree) 'assumption)
; Picky Note: The doublecons nest below is used as though it were equivalent
; to (addtotagtree 'assumption & &) and is justified with the reasoning: if
; the original assumption was added to the cdr subtree with addtotagtree
; (and thus, is known not to occur in that subtree), then the changed
; assumption does not occur in the changed cdr subtree. That is true. But we
; don't really know that the original assumption was ever checked by
; addtotagtree. It doesn't really matter, tag trees being sets anyway. But
; this optimization does mean that this function knows how to construct tag
; trees without using the official constructors. But of course it knows that:
; it destructures them to explore them. This same picky note could be placed
; in front of the final cons below, as well as in
; stripnonrewrittenpassumptions.
(cons (cons 'assumption
(change assumption (cdar ttree)
:assumnotes
(list (change assumnote
(car (access assumption (cdar ttree)
:assumnotes))
:clid clid))))
(setclidsofassumptions (cdr ttree) clid)))
((taggedobject 'assumption (cdr ttree))
(cons (car ttree)
(setclidsofassumptions (cdr ttree) clid)))
(t ttree )))
((taggedobject 'assumption ttree)
(cons (setclidsofassumptions (car ttree) clid)
(setclidsofassumptions (cdr ttree) clid)))
(t ttree)))
; We now develop the code for proving the assumptions that are forced during
; the first part of the proof. These assumptions are all carried in the ttree
; on 'assumption tags. (Deleteassumptions was originally defined just below
; collectassumptions, but has been move up since it is used in pushclause.)
(defun collectassumptions (ttree onlyimmediatep ans)
; We collect the assumptions in ttree and accumulate them onto ans.
; Onlyimmediatep determines exactly which assumptions we collect:
; * 'nonnil  only collect those with :immediatep /= nil
; * 'casesplit  only collect those with :immediatep = 'casesplit
; * t  only collect those with :immediatep = t
; * nil  collect ALL assumptions
(cond ((null ttree) ans)
((symbolp (caar ttree))
(cond ((and (eq (caar ttree) 'assumption)
(cond
((eq onlyimmediatep 'nonnil)
(access assumption (cdar ttree) :immediatep))
((eq onlyimmediatep 'casesplit)
(eq (access assumption (cdar ttree) :immediatep)
'casesplit))
((eq onlyimmediatep t)
(eq (access assumption (cdar ttree) :immediatep)
t))
(t t)))
(collectassumptions (cdr ttree)
onlyimmediatep
(addtosetequal (cdar ttree) ans)))
(t (collectassumptions (cdr ttree) onlyimmediatep ans))))
(t (collectassumptions
(car ttree)
onlyimmediatep
(collectassumptions (cdr ttree) onlyimmediatep ans)))))
; We are now concerned with trying to shorten the typealists used to
; govern assumptions. We have two mechanisms. One is
; ``disguarding,'' the throwing out of any binding whose term
; requires, among its guard clauses, the truth of the term we are
; trying to prove. The second is ``disvaring,'' the throwing out of
; any binding that does not mention any variable linked to term.
; First, disguarding... We must first define the fundamental process
; of generating the guard clauses for a term. This "ought" to be in
; the vicinity of our definition of defun and verifyguards. But we
; need it now.
(defun sublisvarlstlst (alist clauses)
(cond ((null clauses) nil)
(t (cons (sublisvarlst alist (car clauses))
(sublisvarlstlst alist (cdr clauses))))))
(defun addsegmentstoclause (clause segments)
(cond ((null segments) nil)
(t (conjoinclausetoclauseset
(disjoinclauses clause (car segments))
(addsegmentstoclause clause (cdr segments))))))
; Rockwell Addition: A major change is the removal of THEs from
; many terms.
; Essay on the Removal of Guard Holders
; We now develop the code to remove THEs from a term. Suppose the
; user types (THE type expr), type is translated (using
; translatedeclarationtoguard) into a predicate in one variable.
; The variable is always VAR. Denote this predicate as (guard VAR).
; Then the entire (THE type expr) is translated into ((LAMBDA (VAR)
; (IF (guard VAR) VAR (THEERROR 'type VAR))) expr). Theerror is
; defined to have a guard of nil and so when we generate guards for
; the translation above we generate the obligation to prove (guard
; expr). Futhermore, the definition of theerror is such that
; executing it in the *1* function tests (guard expr) at runtime and
; signals an error.
; But logically speaking, the definition of (THEERROR x y) is (CDR
; (CONS x y)). The silly expression is just to keep x from being
; irrelevant. Thus, (THEERROR x y) is identically y. Hence,
; (THE type expr)
; = ((LAMBDA (VAR) (IF (guard VAR) VAR (THEERROR 'type VAR))) expr)
; = ((LAMBDA (VAR) (IF (guard VAR) VAR VAR)) expr)
; = ((LAMBDA (VAR) VAR) expr)
; = expr.
; Observe that this is essentially just the expansion of certain
; nonrec functions (namely, THEERROR, if one thinks of it as defined
; to be y rather than (cdr (cons x y)), and the lambda application)
; and IFnormalization.
; We belabor this obvious point because until Version_2.5, we kept the
; THEs in bodies, which injected them into the theorem proving
; process. We now remove them from the stored BODY property. It is
; not obvious that this is a benign change; it might have had
; unintended sideaffects on other processing, e.g., guard generation.
; But the BODY property has long been normalized with certain nonrec
; fns expanded, and so we argue that the removal of THE could have
; been accomplished by the processing we were already doing.
; But there is another place we wish to remove such ``guard holders.''
; We want the guard clauses we generate not to have these tests in
; them. The terms we explore to generate the guards WILL have these
; tests in them. But the output we produce will not, courtesy of the
; following code which is used to strip the guard holders out of a
; term.
; Starting with Version_2.8 the ``guard holders'' code appears elsewhere,
; because removeguardholders needs to be defined before it is called by
; constraintinfo.
(mutualrecursion
(defun guardclauses (term stobjoptp clause wrld ttree)
; We return two results. The first is a set of clauses whose
; conjunction establishes that all of the guards in term are
; satisfied. The second result is a ttree justifying the
; simplification we do and extending ttree. Stobjoptp indicates
; whether we are to optimize away stobj recognizers. Call this with
; stobjoptp = t only when it is known that the term in question has
; been translated with full enforcement of the stobj rules. Clause is
; the list of accumulated, negated tests passed so far on this branch.
; It is maintained in reverse order, but reversed before we return it.
; Note: Once upon a time, this function took an additional argument,
; alist, and was understood to be generating the guards for term/alist.
; Alist was used to carry the guard generation process into lambdas.
(cond ((variablep term) (mv nil ttree))
((fquotep term) (mv nil ttree))
((flambdaapplicationp term)
(mvlet
(clset1 ttree)
(guardclauseslst (fargs term) stobjoptp clause wrld ttree)
(mvlet
(clset2 ttree)
(guardclauses (lambdabody (ffnsymb term))
stobjoptp
; We pass in the empty clause here, because we do not want it involved
; in wrapping up the lambda term that we are about to create.
nil
wrld ttree)
(let* ((term1 (makelambdaapplication
(lambdaformals (ffnsymb term))
(termifyclauseset clset2)
(removeguardholderslst (fargs term))))
(cl (reverse (addliteral term1 clause nil)))
(clset3 (if (equal cl *trueclause*)
clset1
(conjoinclausesets clset1
(list cl)))))
(mv clset3 ttree)))))
((eq (ffnsymb term) 'if)
(let ((test (removeguardholders (fargn term 1))))
(mvlet
(clset1 ttree)
; Note: We generate guards from the original test, not the one with guard
; holders removed!
(guardclauses (fargn term 1) stobjoptp clause wrld ttree)
(mvlet
(clset2 ttree)
(guardclauses (fargn term 2)
stobjoptp
; But the additions we make to the two branches is based on the
; simplified test.
(addliteral (dumbnegatelit test)
clause
nil)
wrld ttree)
(mvlet
(clset3 ttree)
(guardclauses (fargn term 3)
stobjoptp
(addliteral test
clause
nil)
wrld ttree)
(mv (conjoinclausesets
clset1
(conjoinclausesets clset2 clset3))
ttree))))))
; At one time we optimized away the guards on (nth 'n MV) if n is an
; integerp and MV is bound in (former parameter) alist to a call of a
; multivalued function that returns more than n values. Later we
; changed the way mvlet is handled so that we generated calls of
; mvnth instead of nth, but we inadvertently left the code here
; unchanged. Since we have not noticed resulting performance
; problems, and since this was the only remaining use of alist when we
; started generating lambda terms as guards, we choose for
; simplicity's sake to eliminate this special optimization for mvnth.
(t
; Here we generate the conclusion clauses we must prove. These
; clauses establish that the guard of the function being called is
; satisfied. We first convert the guard into a set of clause
; segments, called the guardconclsegments.
; We optimize stobj recognizer calls to true here. That is, if the
; function traffics in stobjs (and is not :nonexecutablep!), then it
; was so translated and we know that all those stobj recognizer calls
; are true.
; Once upon a time, we normalized the 'guard first. Is that important?
(let ((guardconclsegments (clausify
(guard (ffnsymb term)
stobjoptp
wrld)
; Warning: It might be tempting to pass in the assumptions of clause into
; the second argument of clausify. That would be wrong! The guard has not
; yet been instantiated and so the variables it mentions are not the same
; ones in clause!
nil
; Should we expand lambdas here? I say ``yes,'' but only to be
; conservative with old code. Perhaps we should change the t to nil?
t
wrld)))
(mvlet
(clset1 ttree)
(guardclauseslst (cond ((eq (ffnsymb term) 'mustbeequal)
; Since (mustbeequal x y) macroexpands to y in raw Common Lisp, we need only
; verify guards for the :exec part of an mbe call.
(cdr (fargs term)))
(t (fargs term)))
stobjoptp clause wrld ttree)
(mv (conjoinclausesets
clset1
(addsegmentstoclause (reverse clause)
(addeachliterallst
(sublisvarlstlst
(pairlis$
(formals (ffnsymb term) wrld)
(removeguardholderslst
(fargs term)))
guardconclsegments))))
ttree))))))
(defun guardclauseslst (lst stobjoptp clause wrld ttree)
(cond ((null lst) (mv nil ttree))
(t (mvlet
(clset1 ttree)
(guardclauses (car lst) stobjoptp clause wrld ttree)
(mvlet
(clset2 ttree)
(guardclauseslst (cdr lst) stobjoptp clause wrld ttree)
(mv (conjoinclausesets clset1 clset2) ttree))))))
)
; And now disvaring...
(defun linkedvariables1 (vars directlinks changedp directlinks0)
; We union into vars those elements of directlinks that overlap its
; current value. When we have done them all we ask if anything
; changed and if so, start over at the beginning of directlinks.
(cond
((null directlinks)
(cond (changedp (linkedvariables1 vars directlinks0 nil directlinks0))
(t vars)))
((and (intersectpeq (car directlinks) vars)
(not (subsetpeq (car directlinks) vars)))
(linkedvariables1 (unioneq (car directlinks) vars)
(cdr directlinks)
t directlinks0))
(t (linkedvariables1 vars (cdr directlinks) changedp directlinks0))))
(defun linkedvariables (vars directlinks)
; Vars is a list of variables. Directlinks is a list of lists of
; variables, e.g., '((X Y) (Y Z) (A B) (M)). Let's say that one
; variable is "directly linked" to another if they both appear in one
; of the lists in directlinks. Thus, above, X and Y are directly
; linked, as are Y and Z, and A and B. This function returns the list
; of all variables that are linked (directly or transitively) to those
; in vars. Thus, in our example, if vars is '(X) the answer is '(X Y
; Z), up to order of appearance.
; Note on Higher Order Definitions and the Inconvenience of ACL2:
; Later in these sources we will define the "mate and merge" function,
; m&m, which computes certain kinds of transitive closures. We really
; wish we had that function now, because this function could use it
; for the bulk of this computation. But we can't define it here
; without moving up some of the data structures associated with
; induction. Rather than rip our code apart, we define a simple
; version of m&m that does the job.
; This suggests that we really ought to support the idea of defining a
; function before all of its subroutines are defined  a feature that
; ultimately involves the possibility of implicit mutual recursion.
; It should also be noted that the problem with moving m&m is not so
; much with the code for the mate and merge process as it is with the
; pseudo functional argument it takes. M&m naturally is a higher
; order function that compute the transitive closure of an operation
; supplied to it. Because ACL2 is first order, our m&m doesn't really
; take a function but rather a symbol and has a finite table mapping
; symbols to functions (m&mapply). It is only that table that we
; can't move up to here! So if ACL2 were higher order, we could
; define m&m now and everything would be neat. Of course, if ACL2
; were higher order, we suspect some other aspects of our coding
; (perhaps efficiency and almost certainly theorem proving power)
; would be degraded.
(linkedvariables1 vars directlinks nil directlinks))
; Part of disvaring a typealist to is keep typealist entries about
; constrained constants. This goes to a problem that Eric Smith noted.
; He had constrained (thebit) to be 0 or 1 and had a typealist entry
; stating that (thebit) was not 0. In a forcing round he needed that
; (thebit) was 1. But disvaring had thrown out of the typealist the
; entry for (thebit) because it did not mention any of the relevant
; variables. So, in a change for Version_2.7 we now keep entries that
; mention constrained constants. We considered the idea of keeping
; entries that mention any constrained function, regardless of arity.
; But that seems like overkill. Had Eric constrained (thebit x) to
; be 0 or 1 and then had a hypothesis that it was not 0, it seems
; unlikely that the forcing round would need to know (thebit x) is 1
; if x is not among the relevant vars. That is, one assumes that if a
; constrained function has arguments then the function's behavior on
; those arguments does not determine the function's behavior on other
; arguments. This need not be the case. One can constrain (thebit x)
; so that if it is 0 on some x then it is 0 on all x.
; (implies (equal (thebit x) 0) (equal (thebit y) 0))
; But this seems unlikely.
(mutualrecursion
(defun containsconstrainedconstantp (term wrld)
(cond ((variablep term) nil)
((fquotep term) nil)
((flambdaapplicationp term)
(or (containsconstrainedconstantplst (fargs term) wrld)
(containsconstrainedconstantp (lambdabody (ffnsymb term))
wrld)))
((and (getprop (ffnsymb term) 'constrainedp nil
'currentacl2world wrld)
(null (getprop (ffnsymb term) 'formals t
'currentacl2world wrld)))
t)
(t (containsconstrainedconstantplst (fargs term) wrld))))
(defun containsconstrainedconstantplst (lst wrld)
(cond ((null lst) nil)
(t (or (containsconstrainedconstantp (car lst) wrld)
(containsconstrainedconstantplst (cdr lst) wrld))))))
; So now we can define the notion of ``disvaring'' a typealist.
(defun disvartypealist1 (vars typealist wrld)
(cond ((null typealist) nil)
((or (intersectpeq vars (allvars (caar typealist)))
(containsconstrainedconstantp (caar typealist) wrld))
(cons (car typealist)
(disvartypealist1 vars (cdr typealist) wrld)))
(t (disvartypealist1 vars (cdr typealist) wrld))))
(defun collectallvars (lst)
(cond ((null lst) nil)
(t (cons (allvars (car lst)) (collectallvars (cdr lst))))))
(defun disvartypealist (typealist term wrld)
; We throw out of typealist any binding that does not involve a
; variable linked by typealist to those in term. Thus, if term
; involves only the variables X and Y and typealist binds a term that
; links Y to Z (and nothing else is linked to X, Y, or Z), then the
; resulting typealist only binds terms containing X, Y, and/or Z.
; We actually keep entries about constrained constants.
; As we did for ``disguard'' we apologize for (but stand by) the
; nonword ``disvar.''
(let* ((vars (allvars term))
(directlinks (collectallvars (stripcars typealist)))
(vars* (linkedvariables vars directlinks)))
(disvartypealist1 vars* typealist wrld)))
; Finally we can define the notion of ``unencumbering'' a typealist.
(defun unencumbertypealist (typealist term rewrittenp wrld)
; We wish to prove term under typealist. If rewrittenp is nonnil,
; it is also a term, namely the unrewritten term from which we
; obtained term. Generally, term (actually its unrewritten version)
; is some conjunct from a guard. In many cases we expect term to be
; something very simple like (RATIONALP X). But chances are high that
; type alist talks about many other variables and many irrelevant
; terms. We wish to throw out irrelevant bindings from typealist and
; return a new typealist that is weaker but, we believe, as
; sufficient as the original for proving term. We call this
; ``unencumbering'' the typealist.
; The following paragraph is inaccurate because we no longer use
; disguarding.
; Historical Comment:
; We apply two different techniques. The first is ``disguarding.''
; Roughly, the idea is to throw out the binding of any term that
; requires the truth of term in its guard. Since we are trying to
; prove term true we will assume it false. If a hypothesis in the
; typealist requires term to get past the guard, we'll never do it.
; This is not unlikely since term is (probably) a forced guard from
; the very clause from which typealist was created.
; End of Historical Comment
; The second technique, applied after disguarding, is to throw out any
; binding of a term that is not linked to the variables used by term.
; For example, if term is (RATIONALP X) then we won't keep a
; hypothesis about (PRIMEP Y) unless some kept hypothesis links X and
; Y. This is called ``disvaring'' and is applied after diguarding
; because the terms thrown out by disguarding are likely to link
; variables in a bogus way. For example, (< X Y) would link X and Y,
; but is thrown out by disguarding since it requires (RATIONALP X).
; While disvaring, we actually keep typealist entries about constrained
; constants.
(declare (ignore rewrittenp))
(disvartypealist
typealist
term
wrld))
(defun unencumberassumption (assn wrld)
; Given an assumption we try to unencumber (i.e., shorten) its
; :typealist. We return an assumption that may be proved in place of
; assn and is supposedly simpler to prove.
(change assumption assn
:typealist
(unencumbertypealist (access assumption assn :typealist)
(access assumption assn :term)
(access assumption assn :rewrittenp)
wrld)))
(defun unencumberassumptions (assumptions wrld ans)
; We unencumber every assumption in assumptions and return the
; modified list, accumulated onto ans.
; Note: This process is mentioned in :DOC forcinground. So if we change it,
; update the documentation.
(cond
((null assumptions) ans)
(t (unencumberassumptions
(cdr assumptions) wrld
(cons (unencumberassumption (car assumptions) wrld)
ans)))))
; We are now concerned, for a while, with the idea of deleting from a
; set of assumptions those implied by others. We call this
; assumptionsubsumption. Each assumption can be thought of as a goal
; of the form typealist > term. Observe that if you have two
; assumptions with the same term, then the first implies the second if
; the typealist of the second implies the typealist of the first.
; That is,
; (thm (implies (implies ta2 ta1)
; (implies (implies ta1 term) (implies ta2 term))))
; First we develop the idea that one typealist implies another.
(defun dumbtypealistimplicationp1 (typealist1 typealist2 seen)
(cond ((null typealist1) t)
((memberequal (caar typealist1) seen)
(dumbtypealistimplicationp1 (cdr typealist1) typealist2 seen))
(t (let ((ts1 (cadar typealist1))
(ts2 (or (cadr (assocequal (caar typealist1) typealist2))
*tsunknown*)))
(and (tssubsetp ts1 ts2)
(dumbtypealistimplicationp1 (cdr typealist1)
typealist2
(cons (caar typealist1) seen)))))))
(defun dumbtypealistimplicationp2 (typealist1 typealist2)
(cond ((null typealist2) t)
(t (and (assocequal (caar typealist2) typealist1)
(dumbtypealistimplicationp2 typealist1
(cdr typealist2))))))
(defun dumbtypealistimplicationp (typealist1 typealist2)
; NOTE: This function is intended to be dumb but fast. One can
; imagine that we should be concerned with the types deduced by
; typeset under these typealists. For example, instead of asking
; whether every term bound in typealist1 is bound to a bigger type
; set in typealist2, we should perhaps ask whether the term has a
; bigger typeset under typealist2. Similarly, if we find a term
; bound in typealist2 we should make sure that its typeset under
; typealist1 is smaller. If we need the smarter function we'll write
; it. That's why we call this one "dumb."
; We say typealist1 implies typealist2 if (1) for every
; "significant" entry in typealist1, (term ts1 . ttree1) it is the
; case that either term is not bound in typealist2 or term is bound
; to some ts2 in typealist2 and (tssubsetp ts1 ts2), and (2) every
; term bound in typealist2 is bound in typealist1. The case where
; term is not bound in typealist2 can be seen as the natural
; treatment of the equivalent situation in which term is bound to
; *tsunknown* in typeset2. An entry (term ts . ttree) is
; "significant" if it is the first binding of term in the alist.
; We can treat a typealist as a conjunction of assumptions about the
; terms it binds. Each relevant entry gives rise to an assumption
; about its term. Call the conjunction the "assumptions" encoded in
; the typealist. If typealist1 implies typealist2 then the
; assumptions of the first imply those of the second. Consider an
; assumption of the first. It restricts its term to some type. But
; the corresponding assumption about term in the second typealist
; restricts term to a larger type. Thus, each assumption of the first
; typealist implies the corresponding assumption of the second.
; The end result of all of this is that if you need to prove some
; condition, say g, under typealist1 and also under typealist2, and
; you can determine that typealist1 implies typealist2, then it is
; sufficient to prove g under typealist2.
; Here is an example. Let typealist1 be
; ((x *tst*) (y *tsinteger*) (z *tssymbol*))
; and typealist2 be
; ((x *tsboolean*)(y *tsrational*)).
; Observe that typealist1 implies typealist2: *tst* is a subset of
; *ts boolean*, *tsinteger* is a subset of *tsrational*, and
; *tssymbol* is a subset of *tsunknown*, and there are no terms
; bound in typealist2 that aren't bound in typealist1. If we needed
; to prove g under both of these typealists, it would suffice to
; prove it under typealist2 (the weaker) because we must ultimately
; prove g under typealist2 and the proof of g under typealist1
; follows from that for free.
; Observe also that if we added to typealist2 the binding (u
; *tscons*) then condition (1) of our definition still holds but (2)
; does not. Further, if we mistakenly regarded typealist2 as the
; weaker then proving (consp u) under typealist2 would not ensure a
; proof of (consp u) under typealist1.
(and (dumbtypealistimplicationp1 typealist1 typealist2 nil)
(dumbtypealistimplicationp2 typealist1 typealist2)))
; Now we arrange to partition a bunch of assumptions into pots
; according to their :terms, so we can do the typealist implication
; work just on those assumptions that share a :term.
(defun partitionaccordingtoassumptionterm (assumptions alist)
; We partition assumptions into pots, where the assumptions in a
; single pot all share the same :term. The result is an alist whose
; keys are the :terms and whose values are the assumptions which have
; those terms.
(cond ((null assumptions) alist)
(t (partitionaccordingtoassumptionterm
(cdr assumptions)
(putassocequal
(access assumption (car assumptions) :term)
(cons (car assumptions)
(cdr (assocequal
(access assumption (car assumptions) :term)
alist)))
alist)))))
; So now imagine we have a bunch of assumptions that share a term. We
; want to delete from the set any whose typealist implies any one
; kept. See dumbkeepassumptionswithweakesttypealists.
(defun existsassumptionwithweakertypealist (assumption assumptions i)
; If there is an assumption, assn, in assumptions whose typealist is
; implied by that of the given assumption, we return (mv pos assn),
; where pos is the position in assumptions of the first such assn. We
; assume i is the position of the first assumption in assumptions.
; Otherwise we return (mv nil nil).
(cond
((null assumptions) (mv nil nil))
((dumbtypealistimplicationp
(access assumption assumption :typealist)
(access assumption (car assumptions) :typealist))
(mv i (car assumptions)))
(t (existsassumptionwithweakertypealist assumption
(cdr assumptions)
(1+ i)))))
(defun addassumptionwithweaktypealist (assumption assumptions ans)
; We add assumption to assumptions, deleting any member of assumptions
; whose typealist implies that of the given assumption. When we
; delete an assumption we union its :assumnotes field into that of the
; assumption we are adding. We accumulate our answer onto ans to keep
; this tail recursive; we presume that there will be a bunch of
; assumptions when this stuff gets going.
(cond
((null assumptions) (cons assumption ans))
((dumbtypealistimplicationp
(access assumption (car assumptions) :typealist)
(access assumption assumption :typealist))
(addassumptionwithweaktypealist
(change assumption assumption
:assumnotes
(unionequal (access assumption assumption :assumnotes)
(access assumption (car assumptions) :assumnotes)))
(cdr assumptions)
ans))
(t (addassumptionwithweaktypealist assumption
(cdr assumptions)
(cons (car assumptions) ans)))))
(defun dumbkeepassumptionswithweakesttypealists (assumptions kept)
; We return that subset of assumptions with the property that for
; every member, a, of assumptions there is one, b, among those
; returned such that (dumbtypealistimplicationp a b). Thus, we keep
; all the ones with the weakest hypotheses. If we can prove all the
; ones kept, then we can prove them all, because each one thrown away
; has even stronger hypotheses than one of the ones we'll prove.
; (These comments assume that kept is initially nil and that all of
; the assumptions have the same :term.) Whenever we throw out a in
; favor of b, we union into b's :assumnotes those of a.
(cond
((null assumptions) kept)
(t (mvlet
(i assn)
(existsassumptionwithweakertypealist (car assumptions) kept 0)
(cond
(i (dumbkeepassumptionswithweakesttypealists
(cdr assumptions)
(updatenth
i
(change assumption assn
:assumnotes
(unionequal
(access assumption (car assumptions) :assumnotes)
(access assumption assn :assumnotes)))
kept)))
(t (dumbkeepassumptionswithweakesttypealists
(cdr assumptions)
(addassumptionwithweaktypealist (car assumptions)
kept nil))))))))
; And now we can write the toplevel function for dumbassumptionsubsumption.
(defun dumbassumptionsubsumption1 (partitions ans)
; Having partitioned the original assumptions into pots by :term, we
; now simply clean up the cdr of each pot  which is the list of all
; assumptions with the given :term  and append the results of all
; the pots together.
(cond
((null partitions) ans)
(t (dumbassumptionsubsumption1
(cdr partitions)
(append (dumbkeepassumptionswithweakesttypealists
(cdr (car partitions))
nil)
ans)))))
(defun dumbassumptionsubsumption (assumptions)
; We throw out of assumptions any assumption implied by any of the others. Our
; notion of "implies" here is quite weak, being a simple comparison of
; typealists. Briefly, we partition the set of assumptions into pots by :term
; and then, within each pot throw out any assumption whose typealist is
; stronger than some other in the pot. When we throw some assumption out in
; favor of another we combine its :assumnotes into that of the one we keep, so
; we can report the cases for which each final assumption accounts.
(dumbassumptionsubsumption1
(partitionaccordingtoassumptionterm assumptions nil)
nil))
; Now we move on to the problem of converting an unemcumbered and subsumption
; cleansed assumption into a clause to prove.
(defun clausifytypealist (typealist cl ens w seen ttree)
; Consider a typealist such as
; `((x ,*tscons*) (y ,*tsinteger*) (z ,(tsunion *tsrational* *tssymbol*)))
; and some term, such as (p x y z). We wish to construct a clause
; that represents the goal of proving the term under the assumption of
; the typealist. A suitable clause in this instance is
; (implies (and (consp x)
; (integerp y)
; (or (rationalp z) (symbolp z)))
; (p x y z))
; We return (mv clause ttree), where clause is the clause constructed.
(cond ((null typealist) (mv cl ttree))
((memberequal (caar typealist) seen)
(clausifytypealist (cdr typealist) cl ens w seen ttree))
(t (mvlet (term ttree)
(converttypesettoterm (caar typealist)
(cadar typealist)
ens w ttree)
(clausifytypealist (cdr typealist)
(cons (dumbnegatelit term) cl)
ens w
(cons (caar typealist) seen)
ttree)))))
(defun clausifyassumption (assumption ens wrld)
; We convert the assumption assumption into a clause.
; Note: If you ever change this so that the assumption :term is not the last
; literal of the clause, change the printer processassumptionsmsg1.
(clausifytypealist
(access assumption assumption :typealist)
(list (access assumption assumption :term))
ens
wrld
nil
nil))
(defun clausifyassumptions (assumptions ens wrld pairs ttree)
; We clausify every assumption in assumptions. We return (mv pairs ttree),
; where pairs is a list of pairs, each of the form (assumnotes . clause) where
; the assumnotes are the corresponding field of the clausified assumption.
(cond
((null assumptions) (mv pairs ttree))
(t (mvlet (clause ttree1)
(clausifyassumption (car assumptions) ens wrld)
(clausifyassumptions
(cdr assumptions)
ens wrld
(cons (cons (access assumption (car assumptions) :assumnotes)
clause)
pairs)
(constagtrees ttree1 ttree))))))
(defun stripassumptionterms (lst)
; Given a list of assumptions, return the set of their terms.
(cond ((endp lst) nil)
(t (addtosetequal (access assumption (car lst) :term)
(stripassumptionterms (cdr lst))))))
(defun extractandclausifyassumptions (cl ttree onlyimmediatep ens wrld)
; WARNING: This function is overloaded. Onlyimmediatep can take only only two
; values in this function: 'nonnil or nil. The interpretation is as in
; collectassumptions. Cl is irrelevant if onlyimmediatep is nil. We always
; return four results. But when onlyimmediatep = 'nonnil, the first and part
; of the third result are irrelevant. We know that onlyimmediatep = 'nonnil
; is used only in waterfallstep to do CASESPLITs and immediate FORCEs. We
; know that onlyimmediatep = nil is used for forcinground applications and in
; the proof checker. When CASESPLIT type assumptions are collected with
; onlyimmediatep = nil, then they are given the semantics of FORCE rather
; than CASESPLIT. This could happen in the proof checker, but it is thought
; not to happen otherwise.
; In the case that onlyimmediatep is nil: we strip all assumptions out of
; ttree, obtaining an assumptionfree ttree, ttree'. We then cleanup the
; assumptions, by unencumbering their typealists of presumed irrelevant
; bindings and then removing subsumed ones. We then convert each kept
; assumption into a clause encoding the implication from the unencumbered
; typealist to the assumed term. We pair each clause with the :assumnotes of
; the assumptions for which it accounts, to produce a list of pairs, which is
; among the things we return. Each pair is of the form (assumnotes . clause).
; We return four results, (mv n a pairs ttree'), where n is the number of
; assumptions in the tree, a is the cleaned up assumptions we have to prove,
; whose length is the same as the length of pairs.
; In the case that onlyimmediatep is 'nonnil: we strip out of ttree only
; those assumptions with nonnil :immediatep flags. As before, we generate a
; clause for each, but those with :immediatep = 'casesplit we handle
; differently now: the clause for such an assumption is the one that encodes
; the implication from the negation of cl to the assumed term, rather than the
; one involving the typealist of the assumption. The assumnotes paired with
; such a clause is nil. We do not really care about the assumnotes in
; casesplits or immediatep = t cases (e.g., they are ignored by the
; waterfallstep processing). The final ttree, ttree', may still contain
; nonimmediatep assumptions.
; To keep the definition simpler, we split into just the two cases outlined
; above.
(cond
((eq onlyimmediatep nil)
(let* ((rawassumptions (collectassumptions ttree onlyimmediatep nil))
(cleanedassumptions (dumbassumptionsubsumption
(unencumberassumptions rawassumptions
wrld nil))))
(mvlet
(pairs ttree1)
(clausifyassumptions cleanedassumptions ens wrld nil nil)
; We check below that ttree1 is 'assumption free, so that when we add it to the
; result of cleansing 'assumptions from ttree we get an assumptionfree ttree.
; If ttree1 contains assumptions we believe it must be because the bottommost
; generator of those ttrees, namely converttypesettoterm, was changed to
; force assumptions. But if that happens, we will have to rethink a lot here.
; How can we ensure that we get rid of all assumptions if we make assumptions
; while trying to express our assumptions as clauses?
(mv (length rawassumptions)
cleanedassumptions
pairs
(constagtrees
(cond
((taggedobject 'assumption ttree1)
(er hard 'extractandclausifyassumptions
"Converttypesettoterm apparently returned a ttree that ~
contained an 'assumption tag. This violates the ~
assumption in this function."))
(t ttree1))
(deleteassumptions ttree onlyimmediatep))))))
((eq onlyimmediatep 'nonnil)
(let* ((assumedterms
(stripassumptionterms
(collectassumptions ttree 'casesplit nil)))
(casesplitclauses (splitonassumptions assumedterms cl nil))
(casesplitpairs (pairlis2 nil casesplitclauses))
(rawassumptions (collectassumptions ttree t nil))
(cleanedassumptions (dumbassumptionsubsumption
(unencumberassumptions rawassumptions
wrld nil))))
(mvlet
(pairs ttree1)
(clausifyassumptions cleanedassumptions ens wrld nil nil)
; We check below that ttree1 is 'assumption free, so that when we add it to the
; result of cleansing 'assumptions from ttree we get an assumptionfree ttree.
; If ttree1 contains assumptions we believe it must be because the bottommost
; generator of those ttrees, namely converttypesettoterm, was changed to
; force assumptions. But if that happens, we will have to rethink a lot here.
; How can we ensure that we get rid of all assumptions if we make assumptions
; while trying to express our assumptions as clauses?
(mv 'ignored
assumedterms
(append casesplitpairs pairs)
(constagtrees
(cond
((taggedobject 'assumption ttree1)
(er hard 'extractandclausifyassumptions
"Converttypesettoterm apparently returned a ttree that ~
contained an 'assumption tag. This violates the assumption ~
in this function."))
(t ttree1))
(deleteassumptions ttree 'nonnil))))))
(t (mv 0 nil
(er hard 'extractandclausifyassumptions
"We only implemented two cases for onlyimmediatep: 'nonnil ~
and nil. But you now call it on ~p0."
onlyimmediatep)
nil))))
; Finally, we put it all together in the primitive function that
; applies a processor to a clause.
(defun waterfallstep1 (processor clid clause hist pspv wrld state)
(case processor
(applytophintsclause
(pstk
(applytophintsclause clid clause hist pspv wrld state)))
(preprocessclause
(pstk
(preprocessclause clause hist pspv wrld state)))
(simplifyclause
(pstk
(simplifyclause clause hist pspv wrld state)))
(settleddownclause
(pstk
(settleddownclause clause hist pspv wrld state)))
(eliminatedestructorsclause
(pstk
(eliminatedestructorsclause clause hist pspv wrld state)))
(fertilizeclause
(pstk
(fertilizeclause clid clause hist pspv wrld state)))
(generalizeclause
(pstk
(generalizeclause clause hist pspv wrld state)))
(eliminateirrelevanceclause
(pstk
(eliminateirrelevanceclause clause hist pspv wrld state)))
(otherwise
(pstk
(pushclause clause hist pspv wrld state)))))
(defun waterfallstep (processor clid clause hist pspv wrld ctx state)
; Processor is one of the known waterfall processors. This function
; applies processor and returns six results: signal, clauses, newhist,
; newpspv, jpplflg, and state.
; All processor functions take as input a clause, its hist, a pspv,
; wrld, and state. They all deliver four values: a signal, some
; clauses, a ttree, and a new pspv. The signal delivered by such
; processors is one of 'error, 'miss, 'abort, or else indicates a "hit"
; (often, though not necessarily, with 'hit).
; If the returned signal is 'error or 'miss, we immediately return
; with that signal. But if the signal is a "hit" or 'abort (which in
; this context means "the processor did something but it has demanded
; the cessation of the waterfall process"), we add a new history entry
; to hist, store the ttree into the new pspv, print the message
; associated with this processor, and then return.
; When a processor "hit"s, we check whether it is a specious hit, i.e.,
; whether the input is a member of the output. If so, the history
; entry for the hit is marked specious by having the :processor field
; '(SPECIOUS . processor). However, we report the step as a 'miss, passing
; back the extended history to be passed. Specious processors have to
; be recorded in the history so that waterfallmsg can detect that they
; have occurred and not reprint the formula. Mild Retraction: Actually,
; settleddownclause always produces speciousappearing output but we
; never mark it as 'SPECIOUS because we want to be able to assoc for
; settleddownclause and we know it's specious anyway.
; We typically return (mv signal clauses newhist newpspv jpplflg state).
; Signal Meaning
; 'error Halt the entire proof attempt with an error. We
; print out the error message to the returned state.
; In this case, clauses, newhist, newpspv, and jpplflg
; are all irrelevant (and nil).
; 'miss The processor did not apply or was specious. Clauses,
; newpspv, and jpplflg are irrelevant and nil. But
; newhist has the specious processor recorded in it.
; State is unchanged.
; 'abort Like a "hit", except that we are not to continue with
; the waterfall. We are to use the new pspv as the
; final pspv produced by the waterfall.
; [otherwise] A "hit": The processor applied and produced the new set of
; clauses returned. The appropriate new history and
; new pspv are returned. Jpplflg is either nil
; (indicating that the processor was not pushclause)
; or is a pool lst (indicating that a clause was pushed
; and assigned that lst). The jpplflg of the last executed
; processor should find its way out of the waterfall so
; that when we get out and pop a clause we know if we
; just pushed it. Finally, the message describing the
; transformation has been printed to state.
(mvlet
(erp signal clauses ttree newpspv state)
(catchtimelimit4
(waterfallstep1 processor clid clause hist pspv wrld state))
(cond
(erp ; an outoftime message; treat like a signal of 'error
(mvlet (erp val state)
(er soft ctx "~@0" erp)
(declare (ignore erp val))
(mv 'error nil nil nil nil state)))
(t
(pprogn ; account for bddnote in case we do not have a hit
(cond ((and (eq processor 'applytophintsclause)
(membereq signal '(error miss))
ttree) ; a bddnote; see bddclause
(fputglobal 'bddnotes
(cons ttree
(fgetglobal 'bddnotes state))
state))
(t state))
(cond ((eq signal 'error)
; As of this writing, the only processor which might cause an error is
; applytophintsclause. But processors can't actually cause
; errors in the error/value/state sense because they don't return
; state and so can't print their own error messages. We therefore
; make the convention that if they signal error then the "clauses"
; value they return is in fact a pair (fmtstring . alist) suitable
; for giving error1. Moreover, in this case ttree is an alist
; assigning state global variables to values.
(mvlet (erp val state)
(error1 ctx (car clauses) (cdr clauses) state)
(declare (ignore erp val))
(mv 'error nil nil nil nil state)))
((eq signal 'miss)
(mv 'miss nil hist nil nil state))
(t
; Observe that we update the :clid field (in the :assumnote) of every
; 'assumption.
(mvlet
(erp ttree state)
(accumulatettreeintostate
(setclidsofassumptions ttree clid)
state)
(declare (ignore erp))
(mvlet
(n assumedterms pairs ttree)
(extractandclausifyassumptions
clause
ttree
'nonnil ; collect CASESPLIT and immediate FORCE assumptions
(access rewriteconstant
(access provespecvar newpspv :rewriteconstant)
:currentenabledstructure)
wrld)
(declare (ignore n))
; Note below that we throw away the cars of the pairs. We keep only the
; clauses themselves.
(let* ((splitclauses (stripcdrs pairs))
(clauses
(if (and (null splitclauses)
(null assumedterms)
(membereq processor
'(preprocessclause
applytophintsclause)))
clauses
(removetrivialclauses
(unionequal splitclauses
(disjoinclausesegmenttoclauseset
(dumbnegatelitlst assumedterms)
clauses))
wrld)))
(newhist
(cons (make historyentry
:signal signal ; indicating type of "hit"
:processor
(if (and (not (membereq
processor
'(settleddownclause
; The addition here of applytophintsclause is new for Version_2.7. Consider
; what happens when a :by hint produces a subgoal that is identical to the
; current goal. If the subgoal is labeled as 'SPECIOUS, then we will 'MISS
; below. This was causing the waterfall to apply the :by hint a second time,
; resulting in output such as the following:
#
As indicated by the hint, this goal is subsumed by (EQUAL (F1 X) (F0 X)),
which can be derived from LEMMA1 via functional instantiation, provided
we can establish the constraint generated.
As indicated by the hint, this goal is subsumed by (EQUAL (F1 X) (F0 X)),
which can be derived from LEMMA1 via functional instantiation, provided
we can establish the constraint generated.
#
; The following example reproduces the above output. The toplevel hints (:by,
; :use, :cases, :bdd) should never be 'SPECIOUS anyhow, because the user will
; more than likely prefer to see the output before the proof (probably) fails.
#
(defstub f0 (x) t)
(defstub f1 (x) t)
(defstub f2 (x) t)
(defaxiom lemma1
(equal (f2 x) (f1 x)))
(defthm main
(equal (f1 x) (f0 x))
:hints (("Goal" :by (:functionalinstance lemma1 (f2 f1) (f1 f0)))))
#
applytophintsclause)))
(memberequal clause clauses))
(cons 'SPECIOUS processor)
processor)
:ttree ttree)
hist))
(newpspv (putttreeintopspv ttree newpspv)))
(mvlet (jpplflg state)
(waterfallmsg processor
clid
signal clauses newhist ttree
newpspv state)
(cond
((consp (access historyentry (car newhist) :processor))
(mv 'miss nil newhist nil nil state))
(t
(mv signal clauses newhist newpspv
jpplflg state))))))))))))))
; Section: FINDAPPLICABLEHINTSETTINGS
; Here we develop the code that recognizes that some usersupplied
; hint settings are applicable and we develop the routine to use
; hints. It all comes together in waterfall1.
(defun findapplicablehintsettings
(clid clause hist pspv ctx hints hints0 wrld stableundersimplificationp
state)
; We scan down hints looking for the first one that matches clid and
; clause. If we find none, we return nil. Otherwise, we return a
; pair consisting of the corresponding hintsettings and hints0
; modified as directed by the hint that was applied. By "match" here,
; of course, we mean either
; (a) the hint is of the form (clid . hintsettings), or
; (b) the hint is of the form
; (evalandtranslatehintexpression nametree flg term) where term
; evaluates to nonnil when ID is bound to clid, CLAUSE to clause,
; WORLD to wrld, STABLEUNDERSIMPLIFICATIONP to
; stableundersimplificationp, HIST to hist, PSPV to pspv, and
; ctx to CTX. In this case the corresponding
; hintsettings is the translated version of what the term produced.
; This function is responsible for interpreting computed hints,
; including the meaning of the :computedhintreplacement keyword.
; Stableundersimplificationp is t when the clause has been found not
; to change when simplified. In particular, it is t if we are about
; to transition to destructor elimination.
; Optimization: By convention, when this function is called with
; stableundersimplificationp = t, we know that the function returns
; nil for stableundersimplificationp = nil. That is, if we know the
; clause is stable under simplification, then we have already tried
; and failed to find an applicable hint for it before we knew it was
; stable. So when stableundersimplificationp is t, we avoid some
; work and just eval those hints that might be sensitive to
; stableundersimplificationp. The flg component of (b)style hints
; indicates whether the term contains the free variable
; stableundersimplificationp.
(cond ((null hints) (value nil))
((eq (car (car hints)) 'evalandtranslatehintexpression)
(cond
((and stableundersimplificationp
(not (caddr (car hints)))) ; flg
(findapplicablehintsettings clid clause
hist pspv ctx
(cdr hints)
hints0 wrld
stableundersimplificationp state))
(t
(erlet* ((hintsettings (evalandtranslatehintexpression
(cdr (car hints))
clid clause wrld
stableundersimplificationp
hist pspv ctx
state)))
(cond
((null hintsettings)
(findapplicablehintsettings clid clause
hist pspv ctx
(cdr hints)
hints0 wrld
stableundersimplificationp
state))
((eq (car hintsettings) :COMPUTEDHINTREPLACEMENT)
(value
(cond
((eq (cadr hintsettings) nil)
(cons (cddr hintsettings)
(remove1equal (car hints) hints0)))
((eq (cadr hintsettings) t)
(cons (cddr hintsettings)
hints0))
(t (cons (cddr hintsettings)
(append (cadr hintsettings)
(remove1equal (car hints) hints0)))))))
(t (value (cons hintsettings
(remove1equal (car hints) hints0)))))))))
((and (not stableundersimplificationp)
(consp (car hints))
(equal (caar hints) clid))
(value (cons (cdar hints)
(remove1equal (car hints) hints0))))
(t (findapplicablehintsettings clid clause
hist pspv ctx
(cdr hints)
hints0 wrld
stableundersimplificationp
state))))
(defun thanksforthehint (goalalreadyprintedp state)
; This function prints the note that we have noticed the hint. We have to
; decide whether the clause to which this hint was attached was printed out
; above or below us. We return state.
(io? prove nil state
(goalalreadyprintedp)
(fms "[Note: A hint was supplied for our processing of the ~
goal ~#0~[above~/below~]. Thanks!]~%"
(list
(cons #\0
(if goalalreadyprintedp 0 1)))
(proofsco state)
state
nil)))
; We now develop the code for warning users about :USEing enabled
; :REWRITE and :DEFINITION rules.
(defun lminameorrune (lmi)
; See also lmiseed, which is similar except that it returns a base
; symbol where we are happy to return a rune, and when it returns a
; term we return nil.
(cond ((atom lmi) lmi)
((eq (car lmi) :theorem) nil)
((or (eq (car lmi) :instance)
(eq (car lmi) :functionalinstance))
(lminameorrune (cadr lmi)))
(t lmi)))
(defun enabledlminames1 (ens pairs)
; Pairs is the runicmappingpairs for some symbol, and hence each of
; its elements looks like (nume . rune). We collect the enabled
; :definition and :rewrite runes from pairs.
(cond
((null pairs) nil)
((and (or (eq (cadr (car pairs)) :definition)
(eq (cadr (car pairs)) :rewrite))
(enablednumep (car (car pairs)) ens))
(addtosetequal (cdr (car pairs))
(enabledlminames1 ens (cdr pairs))))
(t (enabledlminames1 ens (cdr pairs)))))
(defun enabledlminames (ens lmilst wrld)
(cond
((null lmilst) nil)
(t (let ((x (lminameorrune (car lmilst))))
; x is either nil, a name, or a rune
(cond
((null x)
(enabledlminames ens (cdr lmilst) wrld))
((symbolp x)
(unionequal (enabledlminames1
ens
(getprop x 'runicmappingpairs nil
'currentacl2world wrld))
(enabledlminames ens (cdr lmilst) wrld)))
((enabledrunep x ens wrld)
(addtosetequal x (enabledlminames ens (cdr lmilst) wrld)))
(t (enabledlminames ens (cdr lmilst) wrld)))))))
(defun maybewarnforusehint (pspv ctx wrld state)
(cond
((warningdisabledp "Use")
state)
(t
(let ((enabledlminames
(enabledlminames
(access rewriteconstant
(access provespecvar pspv :rewriteconstant)
:currentenabledstructure)
(cadr (assoceq :use
(access provespecvar pspv :hintsettings)))
wrld)))
(cond
(enabledlminames
(warning$ ctx ("Use")
"It is unusual to :USE an enabled :REWRITE or :DEFINITION ~
rule, so you may want to consider disabling ~&0."
enabledlminames))
(t state))))))
(defun maybewarnabouttheorysimple (ens1 ens2 ctx wrld state)
; We may use this function instead of maybewarnabouttheory when we know that
; ens1 contains a compressed theory array (and so does ens2, but that should
; always be the case).
(let ((forcexnumeen1 (enablednumep *forcexnume* ens1))
(immxnumeen1 (enablednumep *immediateforcemodepxnume* ens1)))
(maybewarnabouttheory ens1 forcexnumeen1 immxnumeen1 ens2
ctx wrld state)))
(defun maybewarnabouttheoryfromrcnsts (rcnst1 rcnst2 ctx ens wrld state)
(let ((ens1 (access rewriteconstant rcnst1 :currentenabledstructure))
(ens2 (access rewriteconstant rcnst2 :currentenabledstructure)))
(cond
((eql (access enabledstructure ens1 :arraynamesuffix)
(access enabledstructure ens2 :arraynamesuffix))
; We want to avoid printing a warning in those cases where we have not really
; created a new enabled structure. In this case, the enabled structures could
; still in principle be different, in which case we are missing some possible
; warnings. In practice, this function is only called when ens2 is either
; identical to ens1 or is created from ens1 by a call of
; loadtheoryintoenabledstructure where incrmtarraynameflg is t, in which
; case the eql test above will fail.
state)
(t
; The new theory is being constructed from the user's hint and the ACL2 world.
; The most coherent thing to do is contruct the warning in an analogous manner,
; which is why we use ens below rather than ens1.
(maybewarnabouttheorysimple ens ens2 ctx wrld state)))))
(defun waterfallprintclause (suppressprint clid clause state)
(cond ((or suppressprint (equal clid *initialclauseid*))
state)
(t (pprogn
(if (and (membereq 'prove
(fgetglobal 'inhibitoutputlst state))
(fgetglobal 'printclauseids state))
(pprogn
(incrementtimer 'provetime state)
(mvlet (col state)
(fmt1 "~@0~"
(list (cons #\0 (tilde@clauseidphrase clid)))
0 (proofsco state) state nil)
(declare (ignore col))
(incrementtimer 'printtime state)))
state)
(io? prove nil state
(clid clause)
(pprogn
(incrementtimer 'provetime state)
(fms "~@0~~q1.~"
(list (cons #\0 (tilde@clauseidphrase clid))
(cons #\1 (prettyifyclause
clause
(let*abstractionp state)
(w state))))
(proofsco state)
state
(termevisctuple nil state))
(incrementtimer 'printtime state)))))))
; This completes the preliminaries for hints and we can get on with the
; waterfall itself.
(mutualrecursion
(defun waterfall1
(ledge clid clause hist pspv hints suppressprint ens wrld ctx state)
; ledge  In general in this mutually recursive definition, the
; formal "ledge" is any one of the waterfall ledges. But
; by convention, in this function, waterfall1, it is
; always either the 'applytophintsclause ledge or
; the next one, 'preprocessclause. Waterfall1 is the
; place in the waterfall that hints are applied.
; Waterfall0 is the straightforward encoding of the
; waterfall, except that every time it sends clauses back
; to the top, it send them to waterfall1 so that hints get
; used again.
; clid  the clause id for clause.
; clause  the clause to process
; hist  the history of clause
; pspv  an assortment of special vars that any clause processor might
; change
; jpplflg  either nil or a poollst that indicates that the most recently
; executed process was a pushclause that assigned that poollst.
; hints  an alist mapping clauseids to hintsettings.
; wrld  the current world
; state  the usual state.
; We return 4 values: the first is a "signal" and is one of 'abort,
; 'error, or 'continue. The last three returned values are the final
; values of pspv, the jpplflg for this trip through the falls, and
; state. The 'abort signal is used by our recursive processing to
; implement aborts from below. When an abort occurs, the clause
; processor that caused the abort sets the pspv and state as it wishes
; the top to see them. When the signal is 'error, the returned "new
; pspv" is really an error message.
(mvlet
(erp pair state)
(findapplicablehintsettings clid clause
hist pspv ctx
hints hints wrld nil state)
; If no error occurs and pair is nonnil, then pair is of the form
; (hintsettings . hints') where hintsettings is the hintsettings
; corresponding to clid and clause and hints' is hints with the appropriate
; element removed.
(cond
(erp
; This only happens if some hint function caused an error, e.g., by
; generating a hint that would not translate. We pass the error up.
(mv 'error pspv nil state))
((null pair)
; There was no hint.
(pprogn (waterfallprintclause suppressprint clid clause state)
(waterfall0 ledge clid clause hist pspv hints ens wrld ctx
state)))
(t
(waterfall0withhintsettings
(car pair)
ledge clid clause hist pspv (cdr pair) suppressprint ens wrld ctx
state)))))
(defun waterfall0withhintsettings
(hintsettings ledge clid clause hist pspv hints goalalreadyprintedp
ens wrld ctx state)
; We ``install'' the hintsettings given and call waterfall0 on the
; rest of the arguments.
(pprogn
(thanksforthehint goalalreadyprintedp state)
(waterfallprintclause goalalreadyprintedp clid clause state)
(cond
((assoceq :induct hintsettings)
; If the hintsettings contain an :INDUCT hint then we immediately
; push the current clause into the pool. We first smash the
; hintsettings field of the pspv to contain the newly found hint
; settings. Pushclause will store these settings in the pool entry
; it creates and they will be popped with the clause and acted upon by
; induct. We call waterfall0 on 'pushclause here just to avoid
; writing special code to push the clause, compute the jpplflg,
; explain the push, etc. However, we get back a newpspv which has
; the modified pool in it (which we want to pass on) but which also
; has the modified hintsettings (which we don't want to pass on). So
; we restore the hintsettings to what they were in the original pspv
; before continuing.
(mvlet (signal newpspv newjpplflg state)
(waterfall0 '(pushclause) clid clause hist
(change provespecvar pspv
:hintsettings hintsettings)
hints ens wrld ctx state)
(mv signal
(change provespecvar newpspv
:hintsettings
(access provespecvar pspv
:hintsettings))
newjpplflg
state)))
(t
(mvlet
(erp newpspv1 state)
(loadhintsettingsintopspv t hintsettings pspv wrld ctx state)
(cond
(erp (mv 'error pspv nil state))
(t
(pprogn
(maybewarnforusehint newpspv1 ctx wrld state)
(maybewarnabouttheoryfromrcnsts
(access provespecvar pspv :rewriteconstant)
(access provespecvar newpspv1 :rewriteconstant)
ctx ens wrld state)
; If there is no :INDUCT hint, then the hintsettings can be handled by
; modifying the clause and the pspv we use subsequently in the falls.
(mvlet (signal newpspv newjpplflg state)
(waterfall0 ledge clid
clause
hist
newpspv1
hints ens wrld ctx state)
(mv signal
(restorehintsettingsinpspv newpspv pspv)
newjpplflg
state))))))))))
(defun waterfall0
(ledge clid clause hist pspv hints ens wrld ctx state)
(mvlet
(signal clauses newhist newpspv newjpplflg state)
(cond
((null ledge)
; The only way that the ledge can be nil is if the pushclause at the
; bottom of the waterfall signalled 'MISS. This only happens if
; pushclause found a :DONOTINDUCT name hint. That being the case,
; we want to act like a :BY name' hint was attached to that clause,
; where name' is the result of extending the supplied name with the
; clause id. This fancy call of waterfallstep is just a cheap way to
; get the standard :BY name' processing to happen. All it will do is
; add a :BYE (name' . clause) to the tag tree of the newpspv. We
; know that the signal returned will be a "hit". Because we had to smash
; the hintsettings to get this to happen, we'll have to restore them
; in the newpspv.
(waterfallstep
'applytophintsclause
clid clause hist
(change provespecvar pspv
:hintsettings
(list
(cons :by
(convertnametreetonewname
(cons (cdr (assoceq
:donotinduct
(access provespecvar pspv :hintsettings)))
(stringfortilde@clauseidphrase clid))
wrld))))
wrld ctx state))
((eq (car ledge) 'eliminatedestructorsclause)
(mvlet (erp pair state)
(findapplicablehintsettings clid clause
hist pspv ctx
hints hints
wrld t state)
(cond
(erp
; A hint generated an error. We cause it to be passed up, by
; signalling an error. Note that newpspv is just pspv. This way,
; the restorehintsettingsinpspv below is ok.
(mv 'error nil nil pspv nil state))
((null pair)
; No hint was applicable. We do exactly the same thing we would have done
; had (car ledge) not been 'eliminatedestructorsclause. Keep these two
; code segments in sync!
(cond
((membereq (car ledge)
(assoceq :donot
(access provespecvar pspv
:hintsettings)))
(mv 'miss nil hist nil nil state))
(t (waterfallstep (car ledge) clid clause hist pspv
wrld ctx state))))
(t
; A hint was found. The car of pair is the new hintsettings and the
; cdr of pair is the new value of hints. We need to arrange for
; waterfall0withhintsettings to be called. But we are inside
; mvlet binding signal, etc., above. We generate a fake ``signal''
; to get out of here and handle it below.
(mv 'stableundersimplificationphint pair hist nil nil state)))))
((membereq (car ledge)
(assoceq :donot (access provespecvar pspv :hintsettings)))
(mv 'miss nil hist nil nil state))
(t (waterfallstep (car ledge) clid clause hist pspv wrld ctx state)))
(let ((newpspv
(if (null ledge)
(restorehintsettingsinpspv newpspv pspv)
newpspv)))
(cond
((eq signal 'stableundersimplificationphint)
; This fake signal just means we have found an applicable hint for a
; clause that was stable under simplification (stableundersimplificationp = t). The
; variable named clause is holding the pair generated by
; findapplicablehintsettings. We reenter the top of the falls with
; the new hint setting and hints.
(let ((hintsettings (car clauses))
(hints (cdr clauses)))
(waterfall0withhintsettings
hintsettings
(cdr *preprocessclauseledge*)
clid clause
; Simplifyclause contains an optimization that lets us avoid resimplifying
; the clause if the most recent history entry is settleddownclause and
; the induction hyp and concl terms don't occur in it. We shortcircuit that
; shortcircuit by removing the settleddownclause entry if it is the most
; recent.
(cond ((and (consp hist)
(eq (access historyentry (car hist) :processor)
'settleddownclause))
(cdr hist))
(t hist))
pspv hints nil ens wrld ctx state)))
((eq signal 'error) (mv 'error pspv nil state))
((eq signal 'abort) (mv 'abort newpspv newjpplflg state))
((eq signal 'miss)
(if ledge
(waterfall0 (cdr ledge)
clid
clause
newhist ; We use newhist because of specious entries.
pspv
hints
ens
wrld
ctx
state)
(mv (er hard 'waterfall0
"The empty ledge signalled 'MISS! This can only ~
happen if we changed ~
APPLYTOPHINTSCLAUSE so that when given ~
a single :BY name hint it fails to hit.")
nil nil state)))
(t (waterfall1lst (cond ((eq (car ledge) 'settleddownclause)
'settleddownclause)
((null clauses) 0)
((null (cdr clauses)) nil)
(t (length clauses)))
clid
clauses
newhist
newpspv
newjpplflg
hints
(eq (car ledge) 'settleddownclause)
ens
wrld
ctx
state))))))
(defun waterfall1lst (n parentclid clauses hist pspv jpplflg
hints suppressprint ens wrld ctx state)
; N is either 'settleddownclause, nil, or an integer. 'Settled
; downclause means that we just executed settleddownclause and so
; should pass the parent's clause id through as though nothing
; happened. Nil means we produced one child and so its clauseid is
; that of the parent with the primes field incremented by 1. An
; integer means we produced n children and they each get a clauseid
; derived by extending the parent's caselst.
(cond
((null clauses) (mv 'continue pspv jpplflg state))
(t (let ((clid (cond
((and (equal parentclid *initialclauseid*)
(noophistp hist))
parentclid)
((eq n 'settleddownclause) parentclid)
((null n)
(change clauseid parentclid
:primes
(1+ (access clauseid
parentclid
:primes))))
(t (change clauseid parentclid
:caselst
(append (access clauseid
parentclid
:caselst)
(list n))
:primes 0)))))
(mvlet
(signal newpspv newjpplflg state)
(waterfall1 *preprocessclauseledge*
clid
(car clauses)
hist
pspv
hints
suppressprint
ens
wrld
ctx
state)
(cond
((eq signal 'error) (mv 'error pspv nil state))
((eq signal 'abort) (mv 'abort newpspv newjpplflg state))
(t
(waterfall1lst (cond ((eq n 'settleddownclause) n)
((null n) nil)
(t (1 n)))
parentclid
(cdr clauses)
hist
newpspv
newjpplflg
hints
nil
ens
wrld
ctx
state))))))))
)
; And here is the waterfall:
(defun waterfall (forcinground poollst x pspv hints ens wrld ctx state)
; Here x is a list of clauses, except that when we are beginning a forcing
; round other than the first, x is really a list of pairs (assumnotes .
; clause).
; Poollst is the poollst of the clauses and will be used as the
; first field in the clauseid's we generate for them. We return the
; four values: an error flag, the final value of pspv, the jpplflg,
; and the final state.
(let ((parentclauseid
(cond ((and (= forcinground 0)
(null poollst))
; Note: This cond is not necessary. We could just do the make clauseid
; below. We recognize this case just to avoid the consing.
*initialclauseid*)
(t (make clauseid
:forcinground forcinground
:poollst poollst
:caselst nil
:primes 0))))
(clauses
(cond ((and (not (= forcinground 0))
(null poollst))
(stripcdrs x))
(t x))))
(pprogn
(cond ((outputignoredp 'prooftree state)
state)
(t (initializeprooftree parentclauseid x ctx state)))
(mvlet (signal newpspv newjpplflg state)
(waterfall1lst (cond ((null clauses) 0)
((null (cdr clauses))
'settleddownclause)
(t (length clauses)))
parentclauseid
clauses nil
pspv nil hints
(and (eql forcinground 0)
(null poollst)) ; suppressprint
ens wrld ctx state)
(cond ((eq signal 'error)
; If the waterfall signalled an error then it printed the message and we
; just pass the error up.
(mv t nil nil state))
(t
; Otherwise, the signal is either 'abort or 'continue. But 'abort here
; was meant as an internal signal only, used to get out of the recursion
; in waterfall1. We now simply fold those two signals together into the
; nonerroneous return of the newpspv and final flg.
(mv nil newpspv newjpplflg state)))))))
; After the waterfall has finished we have a pool of goals. We
; now develop the functions to extract a goal from the pool for
; induction. It is in this process that we check for subsumption
; among the goals in the pool.
(defun somepoolmembersubsumes (pool clauseset)
; We attempt to determine if there is a clause set in the pool that subsumes
; every member of the given clauseset. If we make that determination, we
; return the tail of pool that begins with that member. Otherwise, no such
; subsumption was found, perhaps because of the limitation in our subsumption
; check (see subsumes), and we return nil.
(cond ((null pool) nil)
((eq (clausesetsubsumes *initsubsumescount*
(access poolelement (car pool) :clauseset)
clauseset)
t)
pool)
(t (somepoolmembersubsumes (cdr pool) clauseset))))
(defun addtopophistory
(action clset poollst subsumerpoollst pophistory)
; Extracting a clauseset from the pool is called "popping". It is
; complicated by the fact that we do subsumption checking and other
; things. To report what happened when we popped, we maintain a "pophistory"
; which is used by the popclausemsg fn below. This function maintains
; pophistories.
; A pophistory is a list that records the sequence of events that
; occurred when we popped a clause set from the pool. The pophistory
; is used only by the output routine popclausemsg.
; The pophistory is built from nil by repeated calls of this
; function. Thus, this function completely specifies the format. The
; elements in a pophistory are each of one of the following forms.
; All the "lst"s below are poollsts.
; (pop lst1 ... lstk) finished the proofs of the lstd goals
; (consider clset lst) induct on clset
; (subsumedbyparent clset lst subsumerlst)
; clset is subsumed by lstd parent
; (subsumedbelow clset lst subsumerlst)
; clset is subsumed by lstd peer
; (qed) pool is empty  but there might be
; assumptions or :byes yet to deal with.
; and has the property that no two pop entries are adjacent. When
; this function is called with an action that does not require all of
; the arguments, nils may be provided.
; The entries are in reverse chronological order and the lsts in each
; pop entry are in reverse chronological order.
(cond ((eq action 'pop)
(cond ((and pophistory
(eq (caar pophistory) 'pop))
(cons (cons 'pop (cons poollst (cdar pophistory)))
(cdr pophistory)))
(t (cons (list 'pop poollst) pophistory))))
((eq action 'consider)
(cons (list 'consider clset poollst) pophistory))
((eq action 'qed)
(cons '(qed) pophistory))
(t (cons (list action clset poollst subsumerpoollst)
pophistory))))
(defun popclause1 (pool pophistory)
; We scan down pool looking for the next 'tobeprovedbyinduction
; clauseset. We mark it 'beingprovedbyinduction and return six
; things: one of the signals 'continue, 'win, or 'lose, the poollst
; for the popped clauseset, the clauseset, its hintsettings, a
; pophistory explaining what we did, and a new pool.
(cond ((null pool)
; It looks like we won this one! But don't be fooled. There may be
; 'assumptions or :byes in the ttree associated with this proof and
; that will cause the proof to fail. But for now we continue to just
; act happy. This is called denial.
(mv 'win nil nil nil
(addtopophistory 'qed nil nil nil pophistory)
nil))
((eq (access poolelement (car pool) :tag) 'beingprovedbyinduction)
(popclause1 (cdr pool)
(addtopophistory 'pop
nil
(poollst (cdr pool))
nil
pophistory)))
((equal (access poolelement (car pool) :clauseset)
'(nil))
; The empty set was put into the pool! We lose. We report the empty name
; and clause set, and an empty pophistory (so no output occurs). We leave
; the pool as is. So we'll go right out of popclause and up to the prover
; with the 'lose signal.
(mv 'lose nil nil nil nil pool))
(t
(let ((poollst (poollst (cdr pool)))
(subpool
(somepoolmembersubsumes (cdr pool)
(access poolelement (car pool)
:clauseset))))
(cond
((null subpool)
(mv 'continue
poollst
(access poolelement (car pool) :clauseset)
(access poolelement (car pool) :hintsettings)
(addtopophistory 'consider
(access poolelement (car pool)
:clauseset)
poollst
nil
pophistory)
(cons (change poolelement (car pool)
:tag 'beingprovedbyinduction)
(cdr pool))))
((eq (access poolelement (car subpool) :tag)
'beingprovedbyinduction)
(mv 'lose nil nil nil
(addtopophistory 'subsumedbyparent
(access poolelement (car pool)
:clauseset)
poollst
(poollst (cdr subpool))
pophistory)
pool))
(t
(popclause1 (cdr pool)
(addtopophistory 'subsumedbelow
(access poolelement (car pool)
:clauseset)
poollst
(poollst (cdr subpool))
pophistory))))))))
; Here we develop the functions for reporting on a pop.
(defun makedefthmformsforbyes (byes wrld)
; Each element of byes is of the form (name . clause) and we create
; a list of the corresponding defthm events.
(cond ((null byes) nil)
(t (cons (list 'defthm (caar byes)
(prettyifyclause (cdar byes) nil wrld)
:ruleclasses nil)
(makedefthmformsforbyes (cdr byes) wrld)))))
(defun popclausemsg1 (forcinground lst jpplflg prevaction state)
; Lst is a reversed pophistory. Since pophistories are in reverse
; chronological order, lst is in chronological order. We scan down
; lst, printing out an explanation of each action. Prevaction is the
; most recently explained action in this scan, or else nil if we are
; just beginning. Jpplflg, if nonnil, means that the last executed
; waterfall process was 'pushclause; the poollst of the clause pushed is
; in the value of jpplflg.
; We return state.
(cond
((null lst) state)
(t
(let ((entry (car lst)))
(mvlet
(col state)
(casematch
entry
(('pop . poollsts)
(fmt
(cond ((null prevaction)
"That completes the proof~#0~[~/s~] of ~*1.~%")
(t "That, in turn, completes the proof~#0~[~/s~] of ~*1.~%"))
(list (cons #\0 poollsts)
(cons #\1
(list "" "~@*" "~@* and " "~@*, "
(tilde@poolnamephraselst
forcinground
(reverse poollsts)))))
(proofsco state)
state nil))
(('qed)
; We used to print Q.E.D. here, but that is premature now that we know
; there might be assumptions or :byes in the pspv. We let
; processassumptions announce the definitive completion of the proof.
(mv 0 state))
(&
; Entry is either a 'consider or one of the two 'subsumed... actions. For all
; three we print out the clause we are working on. Then we print out the
; action specific stuff.
(let ((clset (cadr entry))
(poollst (caddr entry))
(pushpopflg
(and jpplflg
(equal jpplflg (caddr entry)))))
; The pushpopflg is set if the clause just popped is the same as the
; one we just pushed. It and its name have just been printed.
; There's no need to identify it here.
(mvlet (col state)
(cond
(pushpopflg
; If the current entry is a subsumption report, but we are not going to
; identify the clause, then we need to do a terpri to get away from the
; "Name this clause *1." message of the preceding report.
(cond ((eq (car entry) 'consider) (mv 0 state))
(t (fmt "" nil (proofsco state)
state nil))))
(t (fmt (cond
((eq prevaction 'pop)
"We therefore turn our attention to ~
~@1, which is~~%~y0.~")
((null prevaction)
"So we now return to ~@1, which ~
is~~%~q0.~")
(t
"We next consider ~@1, which ~
is~~%~q0.~"))
(list (cons #\0 (prettyifyclauseset
clset
(let*abstractionp state)
(w state)))
(cons #\1 (tilde@poolnamephrase
forcinground poollst)))
(proofsco state)
state
(termevisctuple nil state))))
(casematch
entry
(('subsumedbelow & & subsumerpoollst)
(fmt1 "~%But this formula is subsumed by ~@1, ~
which we'll try to prove later. We ~
therefore regard ~@0 as proved (pending ~
the proof of the more general ~@1).~%"
(list
(cons #\0
(tilde@poolnamephrase
forcinground poollst))
(cons #\1
(tilde@poolnamephrase
forcinground subsumerpoollst)))
col
(proofsco state)
state nil))
(('subsumedbyparent & & subsumerpoollst)
(fmt1 "~%This formula is subsumed by one of its ~
parents, ~@0, which we're in the process ~
of trying to prove by induction. When an ~
inductive proof gives rise to a subgoal ~
that is less general than the original ~
goal it is a sign that either an ~
inappropriate induction was chosen or ~
that the original goal is insufficiently ~
general. In any case, our proof attempt ~
has failed.~"
(list
(cons #\0
(tilde@poolnamephrase
forcinground subsumerpoollst)))
col
(proofsco state)
state nil))
(& ; (consider clset poollst)
(mv col state)))))))
(declare (ignore col))
(popclausemsg1 forcinground (cdr lst) jpplflg (caar lst) state))))))
(defun popclausemsg (forcinground pophistory jpplflg state)
; We print the messages explaining the pops we did.
; This function increments timers. Upon entry, the accumulated time is
; charged to 'provetime. The time spent in this function is charged
; to 'printtime.
(io? prove nil state
(forcinground pophistory jpplflg)
(pprogn
(incrementtimer 'provetime state)
(popclausemsg1 forcinground
(reverse pophistory)
jpplflg
nil
state)
(incrementtimer 'printtime state))))
(defun popclause (forcinground pspv jpplflg state)
; We pop the first available clause from the pool in pspv. We print
; out an explanation of what we do. If jpplflg is nonnil
; then it means the last executed waterfall processor was 'pushclause
; and the poollst of the clause pushed is the value of jpplflg.
; We return 7 results. The first is a signal: 'win, 'lose, or
; 'continue and indicates that we have finished successfully (modulo,
; perhaps, some assumptions and :byes in the tag tree), arrived at a
; definite failure, or should continue. If the first result is
; 'continue, the second, third and fourth are the pool name phrase,
; the set of clauses to induct upon, and the hintsettings, if any.
; The remaining results are the new values of pspv and state.
(mvlet (signal poollst clset hintsettings pophistory newpool)
(popclause1 (access provespecvar pspv :pool)
nil)
(let ((state (popclausemsg forcinground pophistory jpplflg state)))
(mv signal
poollst
clset
hintsettings
(change provespecvar pspv :pool newpool)
state))))
(defun tilde@assumnotesphraselst (lst wrld)
; WARNING: Note that the phrase is encoded twelve times below, to put
; in the appropriate noise words and punctuation!
; Note: As of this writing it is believed that the only time the :rune of an
; assumnote is a fake rune, as in cases 1, 5, and 9 below, is when the
; assumnote is in the impossible assumption. However, we haven't coded this
; specially because such an assumption will be brought immediately to our
; attention in the forcing round by its *nil* :term.
(cond
((null lst) nil)
(t (cons
(cons
(cond ((null (cdr lst))
(cond ((and (consp (access assumnote (car lst) :rune))
(null (basesymbol (access assumnote (car lst) :rune))))
" ~@0, above,~% by primitive type reasoning about~% ~q2,~ and~")
((eq (access assumnote (car lst) :rune) 'equal)
" ~@0, above,~% by the linearization of~% ~q2.~")
((symbolp (access assumnote (car lst) :rune))
" ~@0, above,~% by assuming the guard for ~x1 in~% ~q2.~")
(t " ~@0, above,~% by applying ~x1 to~% ~q2.~")))
((null (cddr lst))
(cond ((and (consp (access assumnote (car lst) :rune))
(null (basesymbol (access assumnote (car lst) :rune))))
" ~@0, above,~% by primitive type reasoning about~% ~q2,~ and~")
((eq (access assumnote (car lst) :rune) 'equal)
" ~@0, above,~% by the linearization of~% ~q2,~ and~")
((symbolp (access assumnote (car lst) :rune))
" ~@0, above,~% by assuming the guard for ~x1 in~% ~q2,~ and~")
(t " ~@0, above,~% by applying ~x1 to~% ~q2,~ and~")))
(t
(cond ((and (consp (access assumnote (car lst) :rune))
(null (basesymbol (access assumnote (car lst) :rune))))
" ~@0, above,~% by primitive type reasoning about~% ~q2,~")
((eq (access assumnote (car lst) :rune) 'equal)
" ~@0, above,~% by the linearization of~% ~q2,~")
((symbolp (access assumnote (car lst) :rune))
" ~@0, above,~% by assuming the guard for ~x1 in~% ~q2,~")
(t " ~@0, above,~% by applying ~x1 to~% ~q2,~"))))
(list
(cons #\0 (tilde@clauseidphrase
(access assumnote (car lst) :clid)))
(cons #\1 (access assumnote (car lst) :rune))
(cons #\2 (untranslate (access assumnote (car lst) :target) nil wrld))))
(tilde@assumnotesphraselst (cdr lst) wrld)))))
(defun tilde*assumnotescolumnphrase (assumnotes wrld)
; We create a tilde* phrase that will print a column of assumnotes.
(list "" "~@*" "~@*" "~@*"
(tilde@assumnotesphraselst assumnotes wrld)))
(defun processassumptionsmsg1 (forcinground n pairs state)
; N is either nil (meaning the length of pairs is 1) or n is the length of
; pairs.
(cond
((null pairs) state)
(t (pprogn
(fms "~@0, below, will focus on~%~q1,~which was forced in~%~*2"
(list (cons #\0 (tilde@clauseidphrase
(make clauseid
:forcinground (1+ forcinground)
:poollst nil
:caselst (if n
(list n)
nil)
:primes 0)))
(cons #\1 (untranslate (car (last (cdr (car pairs))))
t (w state)))
(cons #\2 (tilde*assumnotescolumnphrase
(car (car pairs))
(w state))))
(proofsco state) state nil)
(processassumptionsmsg1 forcinground
(if n (1 n) nil)
(cdr pairs) state)))))
(defun processassumptionsmsg (forcinground n0 n pairs state)
; This function is called when we have completed the given forcinground and
; are about to begin the next one. Forcinground is an integer, r. Pairs is a
; list of n pairs, each of the form (assumnotes . clause). It was generated by
; cleaning up n0 assumptions. We are about to pour all n clauses into the
; waterfall, where they will be given clauseids of the form [r+1]Subgoal i,
; for i from 1 to n, or, if there is only one clause, [r+1]Goal.
; The list of assumnotes associated with each clause explain the need for the
; assumption. Each assumnote is a record of that class, containing the clid
; of the clause we were working on when we generated the assumption, the rune
; (a symbol as per forceassumption) generating the assumption, and the target
; term to which the rule was being applied. We print a table explaining the
; derivation of the new goals from the old ones and then announce the beginning
; of the next round.
(io? prove nil state
(n0 forcinground n pairs)
(pprogn
(fms
"Modulo the following~#0~[~/ ~n1~]~#2~[~/ newly~] forced ~
goal~#0~[~/s~], that completes ~#2~[the proof of the input ~
Goal~/Forcing Round ~x3~].~#4~[~/ For what it is worth, the~#0~[~/ ~
~n1~] new goal~#0~[ was~/s were~] generated by cleaning up ~n5 ~
forced hypotheses.~] See :DOC forcinground.~%"
(list (cons #\0 (if (cdr pairs) 1 0))
(cons #\1 n)
(cons #\2 (if (= forcinground 0) 0 1))
(cons #\3 forcinground)
(cons #\4 (if (= n0 n) 0 1))
(cons #\5 n0)
(cons #\6 (1+ forcinground)))
(proofsco state)
state
nil)
(processassumptionsmsg1 forcinground
(if (= n 1) nil n)
pairs
state)
(fms "We now undertake Forcing Round ~x0.~%"
(list (cons #\0 (1+ forcinground)))
(proofsco state)
state
nil))))
(deflabel forcinground
:doc
":DocSection Miscellaneous
a section of a proof dealing with ~il[force]d assumptions~/
If ACL2 ``~il[force]s'' some hypothesis of some rule to be true, it is
obliged later to prove the hypothesis. ~l[force]. ACL2 delays
the consideration of ~il[force]d hypotheses until the main goal has been
proved. It then undertakes a new round of proofs in which the main
goal is essentially the conjunction of all hypotheses ~il[force]d in the
preceding proof. Call this round of proofs the ``Forcing Round.''
Additional hypotheses may be ~il[force]d by the proofs in the Forcing
Round. The attempt to prove these hypotheses is delayed until the
Forcing Round has been successfully completed. Then a new Forcing
Round is undertaken to prove the recently ~il[force]d hypotheses and this
continues until no hypotheses are ~il[force]d. Thus, there is a
succession of Forcing Rounds.~/
The Forcing Rounds are enumerated starting from 1. The Goals and
Subgoals of a Forcing Round are printed with the round's number
displayed in square brackets. Thus, ~c[\"[1~]Subgoal 1.3\"] means that
the goal in question is Subgoal 1.3 of the 1st forcing round. To
supply a hint for use in the proof of that subgoal, you should use
the goal specifier ~c[\"[1~]Subgoal 1.3\"]. ~l[goalspec].
When a round is successfully completed ~[] and for these purposes you
may think of the proof of the main goal as being the 0th forcing
round ~[] the system collects all of the assumptions ~il[force]d by the
justcompleted round. Here, an assumption should be thought of as
an implication, ~c[(implies context hyp)], where context describes the
context in which hyp was assumed true. Before undertaking the
proofs of these assumptions, we try to ``clean them up'' in an
effort to reduce the amount of work required. This is often
possible because the ~il[force]d assumptions are generated by the same
rule being applied repeatedly in a given context.
For example, suppose the main goal is about some term
~c[(pred (xtrans i) i)] and that some rule rewriting ~c[pred] contains a
~il[force]d hypothesis that the first argument is a ~c[goodinputp].
Suppose that during the proof of Subgoal 14 of the main goal,
~c[(goodinputp (xtrans i))] is ~il[force]d in a context in which ~c[i] is
an ~ilc[integerp] and ~c[x] is a ~ilc[consp]. (Note that ~c[x] is
irrelevant.) Suppose finally that during the proof of Subgoal 28,
~c[(goodinputp (xtrans i))] is ~il[force]d ``again,'' but this time in a
context in which ~c[i] is a ~ilc[rationalp] and ~c[x] is a ~ilc[symbolp].
Since the ~il[force]d hypothesis does not mention ~c[x], we deem the
contextual information about ~c[x] to be irrelevant and discard it
from both contexts. We are then left with two ~il[force]d assumptions:
~c[(implies (integerp i) (goodinputp (xtrans i)))] from Subgoal 14,
and ~c[(implies (rationalp i) (goodinputp (xtrans i)))] from Subgoal
28. Note that if we can prove the assumption required by Subgoal 28
we can easily get that for Subgoal 14, since the context of Subgoal
28 is the more general. Thus, in the next forcing round we will
attempt to prove just
~bv[]
(implies (rationalp i) (goodinputp (xtrans i)))
~ev[]
and ``blame'' both Subgoal 14 and Subgoal 28 of the previous round
for causing us to prove this.
By delaying and collecting the ~c[forced] assumptions until the
completion of the ``main goal'' we gain two advantages. First, the
user gets confirmation that the ``gist'' of the proof is complete
and that all that remains are ``technical details.'' Second, by
delaying the proofs of the ~il[force]d assumptions ACL2 can undertake the
proof of each assumption only once, no matter how many times it was
~il[force]d in the main goal.
In order to indicate which proof steps of the previous round were
responsible for which ~il[force]d assumptions, we print a sentence
explaining the origins of each newly ~il[force]d goal. For example,
~bv[]
[1]Subgoal 1, below, will focus on
(GOODINPUTP (XTRANS I)),
which was forced in
Subgoal 14, above,
by applying (:REWRITE PREDCRUNCHER) to
(PRED (XTRANS I) I),
and
Subgoal 28, above,
by applying (:REWRITE PREDCRUNCHER) to
(PRED (XTRANS I) I).
~ev[]
In this entry, ``[1]Subgoal 1'' is the name of a goal which will be
proved in the next forcing round. On the next line we display the
~il[force]d hypothesis, call it ~c[x], which is
~c[(goodinputp (xtrans i))] in this example. This term will be the
conclusion of the new subgoal. Since the new subgoal will be
printed in its entirety when its proof is undertaken, we do not here
exhibit the context in which ~c[x] was ~il[force]d. The sentence then
lists (possibly a succession of) a goal name from the justcompleted
round and some step in the proof of that goal that ~il[force]d ~c[x]. In
the example above we see that Subgoals 14 and 28 of the
justcompleted proof ~il[force]d ~c[(goodinputp (xtrans i))] by applying
~c[(:rewrite predcruncher)] to the term ~c[(pred (xtrans i) i)].
If one were to inspect the theorem prover's description of the proof
steps applied to Subgoals 14 and 28 one would find the word
``~il[force]d'' (or sometimes ``forcibly'') occurring in the commentary.
Whenever you see that word in the output, you know you will get a
subsequent forcing round to deal with the hypotheses ~il[force]d.
Similarly, if at the beginning of a forcing round a ~il[rune] is blamed
for causing a ~il[force] in some subgoal, inspection of the commentary
for that subgoal will reveal the word ``~il[force]d'' after the rule name
blamed.
Most ~il[force]d hypotheses come from within the prover's simplifier.
When the simplifier encounters a hypothesis of the form ~c[(force hyp)]
it first attempts to establish it by rewriting ~c[hyp] to, say, ~c[hyp'].
If the truth or falsity of ~c[hyp'] is known, forcing is not required.
Otherwise, the simplifier actually ~il[force]s ~c[hyp']. That is, the ~c[x]
mentioned above is ~c[hyp'], not ~c[hyp], when the ~il[force]d subgoal was
generated by the simplifier.
Once the system has printed out the origins of the newly ~il[force]d
goals, it proceeds to the next forcing round, where those goals are
individually displayed and attacked.
At the beginning of a forcing round, the ~il[enable]d structure defaults
to the global ~il[enable]d structure. For example, suppose some ~il[rune],
~c[rune], is globally ~il[enable]d. Suppose in some event you ~il[disable] the
~il[rune] at ~c[\"Goal\"] and successfully prove the goal but ~il[force] ~c[\"[1~]Goal\"].
Then during the proof of ~c[\"[1~]Goal\"], ~il[rune] is ~il[enable]d ``again.'' The
right way to think about this is that the ~il[rune] is ``still'' ~il[enable]d.
That is, it is ~il[enable]d globally and each forcing round resumes with
the global ~il[enable]d structure.")
(deflabel failure
:doc
":DocSection Miscellaneous
how to deal with a proof failure~/
When ACL2 gives up it does not mean that the submitted conjecture is
invalid, even if the last formula ACL2 printed in its proof attempt
is manifestly false. Since ACL2 sometimes ~il[generalize]s the goal
being proved, it is possible it adopted an invalid subgoal as a
legitimate (but doomed) strategy for proving a valid goal.
Nevertheless, conjectures submitted to ACL2 are often invalid and
the proof attempt often leads the careful reader to the realization
that a hypothesis has been omitted or that some special case has
been forgotten. It is good practice to ask yourself, when you see a
proof attempt fail, whether the conjecture submitted is actually a
theorem.~/
If you think the conjecture is a theorem, then you must figure out
from ACL2's output what you know that ACL2 doesn't about the
functions in the conjecture and how to impart that knowledge to ACL2
in the form of rules. However, ~pl[prooftree] for a utility that
may be very helpful in locating parts of the failed proof that are
of particular interest. See also the book ``ComputerAided
Reasoning: An Approach'' (Kaufmann, Manolios, Moore), as well as the
discussion of how to read Nqthm proofs and how to use Nqthm rules in
``A Computational Logic Handbook'' by Boyer and Moore (Academic
Press, 1988).
If the failure occurred during a forcing round,
~pl[failedforcing].")
(deflabel failedforcing
:doc
":DocSection Miscellaneous
how to deal with a proof ~il[failure] in a forcing round~/
~l[forcinground] for a background discussion of the notion of
forcing rounds. When a proof fails during a forcing round it means
that the ``gist'' of the proof succeeded but some ``technical
detail'' failed. The first question you must ask yourself is
whether the ~il[force]d goals are indeed theorems. We discuss the
possibilities below.~/
If you believe the ~il[force]d goals are theorems, you should follow the
usual methodology for ``fixing'' failed ACL2 proofs, e.g., the
identification of key lemmas and their timely and proper use as
rules. ~l[failure] and ~pl[prooftree].
The rules designed for the goals of forcing rounds are often just
what is needed to prove the ~il[force]d hypothesis at the time it is
~il[force]d. Thus, you may find that when the system has been ``taught''
how to prove the goals of the forcing round no forcing round is
needed. This is intended as a feature to help structure the
discovery of the necessary rules.
If a hint must be provided to prove a goal in a forcing round, the
appropriate ``goal specifier'' (the string used to identify the goal
to which the hint is to be applied) is just the text printed on the
line above the formula, e.g., ~c[\"[1~]Subgoal *1/3''\"].
~l[goalspec].
If you solve a forcing problem by giving explicit ~il[hints] for the
goals of forcing rounds, you might consider whether you could avoid
forcing the assumption in the first place by giving those ~il[hints] in
the appropriate places of the main proof. This is one reason that
we print out the origins of each ~il[force]d assumption. An argument
against this style, however, is that an assumption might be ~il[force]d
in hundreds of places in the main goal and proved only once in the
forcing round, so that by delaying the proof you actually save time.
We now turn to the possibility that some goal in the forcing round
is not a theorem.
There are two possibilities to consider. The first is that the
original theorem has insufficient hypotheses to ensure that all the
~il[force]d hypotheses are in fact always true. The ``fix'' in this case
is to amend the original conjecture so that it has adequate
hypotheses.
A more difficult situation can arise and that is when the conjecture
has sufficient hypotheses but they are not present in the forcing
round goal. This can be caused by what we call ``premature''
forcing.
Because ACL2 rewrites from the inside out, it is possible that it
will ~il[force] hypotheses while the context is insufficient to establish
them. Consider trying to prove ~c[(p x (foo x))]. We first rewrite the
formula in an empty context, i.e., assuming nothing. Thus, we
rewrite ~c[(foo x)] in an empty context. If rewriting ~c[(foo x)] ~il[force]s
anything, that ~il[force]d assumption will have to be proved in an empty
context. This will likely be impossible.
On the other hand, suppose we did not attack ~c[(foo x)] until after we
had expanded ~c[p]. We might find that the value of its second
argument, ~c[(foo x)], is relevant only in some cases and in those cases
we might be able to establish the hypotheses ~il[force]d by ~c[(foo x)]. Our
premature forcing is thus seen to be a consequence of our ``over
eager'' rewriting.
Here, just for concreteness, is an example you can try. In this
example, ~c[(foo x)] rewrites to ~c[x] but has a ~il[force]d hypothesis of
~c[(rationalp x)]. ~c[P] does a case split on that very hypothesis
and uses its second argument only when ~c[x] is known to be rational.
Thus, the hypothesis for the ~c[(foo x)] rewrite is satisfied. On
the false branch of its case split, ~c[p] simplies to ~c[(p1 x)] which
can be proved under the assumption that ~c[x] is not rational.
~bv[]
(defun p1 (x) (not (rationalp x)))
(defun p (x y)(if (rationalp x) (equal x y) (p1 x)))
(defun foo (x) x)
(defthm foorewrite (implies (force (rationalp x)) (equal (foo x) x)))
(intheory (disable foo))
~ev[]
The attempt then to do ~c[(thm (p x (foo x)))] ~il[force]s the unprovable
goal ~c[(rationalp x)].
Since all ``formulas'' are presented to the theorem prover as single
terms with no hypotheses (e.g., since ~ilc[implies] is a function), this
problem would occur routinely were it not for the fact that the
theorem prover expands certain ``simple'' definitions immediately
without doing anything that can cause a hypothesis to be ~il[force]d.
~l[simple]. This does not solve the problem, since it is
possible to hide the propositional structure arbitrarily deeply.
For example, one could define ~c[p], above, recursively so that the test
that ~c[x] is rational and the subsequent first ``real'' use of ~c[y]
occurred arbitrarily deeply.
Therefore, the problem remains: what do you do if an impossible goal
is ~il[force]d and yet you know that the original conjecture was
adequately protected by hypotheses?
One alternative is to disable forcing entirely.
~l[disableforcing]. Another is to ~il[disable] the rule that
caused the ~il[force].
A third alternative is to prove that the negation of the main goal
implies the ~il[force]d hypothesis. For example,
~bv[]
(defthm notpimpliesrationalp
(implies (not (p x (foo x))) (rationalp x))
:ruleclasses nil)
~ev[]
Observe that we make no rules from this formula. Instead, we
merely ~c[:use] it in the subgoal where we must establish ~c[(rationalp x)].
~bv[]
(thm (p x (foo x))
:hints ((\"Goal\" :use notpimpliesrationalp)))
~ev[]
When we said, above, that ~c[(p x (foo x))] is first rewritten in an
empty context we were misrepresenting the situation slightly. When
we rewrite a literal we know what literal we are rewriting and we
implicitly assume it false. This assumption is ``dangerous'' in
that it can lead us to simplify our goal to ~c[nil] and give up ~[] we
have even seen people make the mistake of assuming the negation of
what they wished to prove and then via a very complicated series of
transformations convince themselves that the formula is false.
Because of this ``tail biting'' we make very weak use of the
negation of our goal. But the use we make of it is sufficient to
establish the ~il[force]d hypothesis above.
A fourth alternative is to weaken your desired theorem so as to make
explicit the required hypotheses, e.g., to prove
~bv[]
(defthm rationalpimpliesmain
(implies (rationalp x) (p x (foo x)))
:ruleclasses nil)
~ev[]
This of course is unsatisfying because it is not what you
originally intended. But all is not lost. You can now prove your
main theorem from this one, letting the ~ilc[implies] here provide the
necessary case split.
~bv[]
(thm (p x (foo x))
:hints ((\"Goal\" :use rationalpimpliesmain)))
~ev[]")
(defun quicklycountassumptions (ttree n mx)
; If there are no 'assumption tags in ttree, return 0. If there are fewer than
; mx, return the number there are. Else return mx. Mx must be greater than 0.
; The soundness of the system depends on this function returning 0 only if
; there are no assumptions.
(cond ((null ttree) n)
((symbolp (caar ttree))
(cond ((eq (caar ttree) 'assumption)
(let ((n+1 (1+ n)))
(cond ((= n+1 mx) mx)
(t (quicklycountassumptions (cdr ttree) n+1 mx)))))
(t (quicklycountassumptions (cdr ttree) n mx))))
(t (let ((n+car (quicklycountassumptions (car ttree) n mx)))
(cond ((= n+car mx) mx)
(t (quicklycountassumptions (cdr ttree) n+car mx)))))))
(defun processassumptions (forcinground pspv wrld state)
; This function is called when proveloop1 appears to have won the
; indicated forcinground, producing pspv. We inspect the :tagtree
; in pspv and determines whether there are forced 'assumptions in it.
; If so, the "win" reported is actually conditional upon the
; successful relieving of those assumptions. We create an appropriate
; set of clauses to prove, newclauses, each paired with a list of
; assumnotes. We also return a modified pspv, newpspv,
; just like pspv except with the assumptions stripped out of its
; :tagtree. We do the output related to explaining all this to the
; user and return (mv newclauses newpspv state). If newclauses is
; nil, then the proof is really done. Otherwise, we are obliged to
; prove newclauses under newpspv and should do so in another "round"
; of forcing.
(let ((n (quicklycountassumptions (access provespecvar pspv :tagtree)
0
101)))
(pprogn
(cond
((= n 0)
(pprogn (if (and (savedoutputtokenp 'prove state)
(membereq 'prove (fgetglobal 'inhibitoutputlst state)))
(fms "Q.E.D.~%" nil (proofsco state) state nil)
state)
(io? prove nil state
nil
(fms "Q.E.D.~%" nil (proofsco state) state nil))))
((< n 101)
(io? prove nil state
(n)
(fms "q.e.d. (given ~n0 forced ~#1~[hypothesis~/hypotheses~])~%"
(list (cons #\0 n)
(cons #\1 (if (= n 1) 0 1)))
(proofsco state) state nil)))
(t
(io? prove nil state
nil
(fms "q.e.d. (given over 100 forced hypotheses which we now ~
collect)~%"
nil
(proofsco state) state nil))))
(mvlet
(n0 assns pairs ttree1)
(extractandclausifyassumptions
nil ;;; irrelevant with onlyimmediatep = nil
(access provespecvar pspv :tagtree)
nil ;;; all assumptions, not onlyimmediatep
; Note: We here obtain the enabled structure. Because the rewriteconstant of
; the pspv is restored after being smashed by hints, we know that this enabled
; structure is in fact the one in the pspv on which prove was called, which is
; the global enabled structure if prove was called by defthm. This enabled
; structure is, as of this writing, only used in unencumbering the assumptions:
; while throwing out irrelevant typealist entries governing assumptions we
; have occasion to call typeset and typeset needs an ens.
(access rewriteconstant
(access provespecvar pspv
:rewriteconstant)
:currentenabledstructure)
wrld)
(cond
((= n0 0)
(mv nil pspv state))
(t
(pprogn
(processassumptionsmsg
forcinground n0 (length assns) pairs state)
(mv pairs
(change provespecvar pspv
:tagtree ttree1
; Note: In an earlier version of this code, we failed to set :otfflg here and
; that caused us to backup and try to prove the original thm (i.e., "Goal") by
; induction.
:otfflg t)
state))))))))
(defun donotinductmsg (forcinground poollst state)
; We print a message explaining that because of :donotinduct, we quit.
; This function increments timers. Upon entry, the accumulated time is
; charged to 'provetime. The time spent in this function is charged
; to 'printtime.
(io? prove nil state
(forcinground poollst)
(pprogn
(incrementtimer 'provetime state)
; It is probably a good idea to keep the following wording in sync with
; pushclausemsg1.
(fms "Normally we would attempt to prove ~@0 ~
by induction. However, since the ~
DONOTINDUCT hint was supplied, we can't do ~
that and the proof attempt has failed.~"
(list (cons #\0
(tilde@poolnamephrase
forcinground
poollst)))
(proofsco state)
state
nil)
(incrementtimer 'printtime state))))
(defun proveloop1 (forcinground poollst clauses pspv hints ens wrld ctx
state)
; We are given some clauses to prove. Forcinground and poollst are
; the first two fields of the clauseids for the clauses. The pool of
; the prove spec var, pspv, in general contains some more clauses to
; work on, as well as some clauses tagged 'beingprovedbyinduction.
; In addition, the pspv contains the proper settings for the
; inductionhypterms and inductionconclterms.
; Actually, when we are beginning a forcing round other than the first,
; clauses is really a list of pairs (assumnotes . clause).
; We pour all the clauses over the waterfall. They tumble into the
; pool in pspv. If the pool is then empty, we are done. Otherwise,
; we pick one to induct on, do the induction and repeat.
; We either cause an error or return (as the "value" result in the
; usual error/value/state triple) the final tag tree. That tag
; tree might contain some byes, indicating that the proof has failed.
; WARNING: A nonerroneous return is not equivalent to success!
(mvlet (erp pspv jpplflg state)
(pstk
(waterfall forcinground poollst clauses pspv hints ens wrld
ctx state))
(cond
(erp (mv t nil state))
(t
(mvlet
(signal poollst clauses hintsettings pspv state)
(pstk
(popclause forcinground pspv jpplflg state))
(cond
((eq signal 'win)
(mvlet
(pairs newpspv state)
(pstk
(processassumptions forcinground pspv wrld state))
(cond ((null pairs)
(erlet*
((ttree (accumulatettreeintostate
(access provespecvar newpspv :tagtree)
state)))
(value ttree)))
(t (proveloop1 (1+ forcinground)
nil
pairs
newpspv
hints ens wrld ctx state)))))
; The following case can probably be removed. It is probably left over from
; some earlier implementation of popclause. The earlier code for the case
; below returned (value (access provespecvar pspv :tagtree)), this case, and
; was replaced by the hard error on 5/5/00.
((eq signal 'bye)
(mv
t
(er hard ctx
"Surprising case in proveloop1; please contact the ACL2 ~
implementors!")
state))
((eq signal 'lose)
(silenterror state))
((and (cdr (assoceq :donotinduct hintsettings))
(not (assoceq :induct hintsettings)))
; There is at least one goal left to prove, yet :donotinduct is currently in
; force. How can that be? The user may have supplied :donotinduct t while
; also supplying :otfflg t. In that case, pushclause will return a "hit". We
; believe that the hintsettings current at this time will reflect the
; appropriate action if :donotinduct t is intended here, i.e., the test above
; will put us in this case and we will abort the proof.
(pprogn (donotinductmsg forcinground poollst state)
(silenterror state)))
(t
(mvlet
(signal clauses pspv state)
(pstk
(induct (tilde@poolnamephrase forcinground poollst)
clauses hintsettings pspv wrld ctx state))
; We do not call maybewarnabouttheoryfromrcnsts below, because we already
; made such a call before the goal was pushed for proof by induction.
(cond ((eq signal 'lose)
(silenterror state))
(t (proveloop1 forcinground
poollst
clauses
pspv
hints
ens
wrld
ctx
state)))))))))))
(defun proveloop (clauses pspv hints ens wrld ctx state)
; We either cause an error or return a ttree. If the ttree contains
; :byes, the proof attempt has technically failed, although it has
; succeeded modulo the :byes.
#acl2looponly
(setq *deepgstack* nil) ; in case we never call initialgstack
(prog2$ (clearpstk)
(pprogn
(incrementtimer 'othertime state)
(fputglobal 'bddnotes nil state)
(mvlet (erp ttree state)
(proveloop1 0
nil
clauses
pspv
hints ens wrld ctx state)
(pprogn
(incrementtimer 'provetime state)
(cond
(erp (mv erp nil state))
(t (value ttree))))))))
(defmacro makercnst (ens wrld &rest args)
; (Makercnst w) will make a rewriteconstant that is just
; *emptyrewriteconstant* except that it has the current value of the
; globalenabledstructure as the :currentenabledstructure. More generally,
; you may use args to supply a list of alternating keyword/value pairs to
; override the default settings. E.g.,
; (makercnst w :expandlst lst)
; will make a rewriteconstant that is like the empty one except that it will
; have lst as the :expandlst.
; Note: Wrld and ens are only used in the "default" setting of
; :currentenabledstructure  a setting overridden by any explicit one in
; args. Thus, is irrelevant if you supply :oncepoverride.
`(change rewriteconstant
(change rewriteconstant
*emptyrewriteconstant*
:currentenabledstructure ,ens
:oncepoverride (matchfreeoverride ,wrld)
:nonlinearp (nonlinearp ,wrld))
,@args))
(defmacro makepspv (ens wrld &rest args)
; This macro is similar to makercnst, which is a little easier to understand.
; (makepspv ens w) will make a pspv that is just *emptyprovespecvar* except
; that the rewrite constant is (makercnst ens w). More generally, you may use
; args to supply a list of alternating keyword/value pairs to override the
; default settings. E.g.,
; (makepspv w :rewriteconstant rcnst :displayedgoal dg)
; will make a pspv that is like the empty one except for the two fields
; listed above.
; Note: Ens and wrld are only used in the default setting of the
; :rewriteconstant. If you supply a :rewriteconstant in args, then ens and
; wrld are actually irrelevant.
`(change provespecvar
(change provespecvar *emptyprovespecvar*
:rewriteconstant (makercnst ,ens ,wrld))
,@args))
(defun chkassumptionfreettree (ttree ctx state)
; Let ttree be the ttree about to be returned by prove. We do not
; want this tree to contain any 'assumption tags because that would be
; a sign that an assumption got ignored. For similar reasons, we do
; not want it to contain any 'fcderivation tags  assumptions might
; be buried therein. This function checks these claimed invariants of
; the final ttree and causes an error if they are violated.
; A predicate version of this function is assumptionfreettreep and
; it should be kept in sync with this function.
; While this function causes a hard error, its functionality is that
; of a soft error because it is so like our normal checkers.
(cond ((taggedobject 'assumption ttree)
(mv t
(er hard ctx
"The 'assumption ~x0 was found in the final ttree!"
(taggedobject 'assumption ttree))
state))
((taggedobject 'fcderivation ttree)
(mv t
(er hard ctx
"The 'fcderivation ~x0 was found in the final ttree!"
(taggedobject 'fcderivation ttree))
state))
(t (value nil))))
(defun prove (term pspv hints ens wrld ctx state)
; Term is a translated term. Displayedgoal is any object and is
; irrelevant except for output purposes. Hints is a list of pairs
; as returned by translatehints.
; We try to prove term using the given hints and the rules in wrld.
; Note: Having prove use hints is a break from nqthm, where only
; provelemma used hints.
; This function returns the traditional three values of an error
; producing/output producing function. The first value is a Boolean
; that indicates whether an error occurred. We cause an error if we
; terminate without proving term. Hence, if the first result is nil,
; term was proved. The second is a ttree that describes the proof, if
; term is proved. The third is the final value of state.
; Displayedgoal is relevant only for output purposes. We assume that
; this object was prettyprinted to the user before prove was called
; and is, in the user's mind, what is being proved. For example,
; displayedgoal might be the untranslated  or pretranslated 
; form of term. The only use made of displayedgoal is that if the
; very first transformation we make produces a clause that we would
; prettyprint as displayedgoal, we hide that transformation from the
; user.
; Commemorative Plaque:
; We began the creation of the ACL2 with an empty GNU Emacs buffer on
; August 14, 1989. The first few days were spent writing down the
; axioms for the most primitive functions. We then began writing
; experimental applicative code for macros such as cond and
; casematch. The first weeks were dizzying because of the confusion
; in our minds over what was in the logic and what was in the
; implementation. On November 3, 1989, prove was debugged and
; successfully did the associativity of append. During that 82 days
; we worked our more or less normal 8 hours, plus an hour or two on
; weekday nights. In general we did not work weekends, though there
; might have been two or three where an 8 hour day was put in. We
; worked separately, "contracting" with one another to do the various
; parts and meeting to go over the code. Bill Schelter was extremely
; helpful in tuning akcl for us. Several times we did massive
; rewrites as we changed the subset or discovered new programming
; styles. During that period Moore went to the beach at Rockport one
; weekend, to Carlsbad Caverns for Labor Day, to the University of
; Utah for a 4 day visit, and to MIT for a 4 day visit. Boyer taught
; at UT from September onwards. These details are given primarily to
; provide a measure of how much effort it was to produce this system.
; In all, perhaps we have spent 60 8 hour days each on ACL2, or about
; 1000 man hours. That of course ignores totally the fact that we
; have thought about little else during the past three months, whether
; coding or not.
; The system as it stood November 3, 1989, contained the complete
; nqthm rewriter and simplifier (including metafunctions, compound
; recognizers, linear and a trivial cut at congruence relations that
; did not connect to the userinterface) and induction. It did not
; include destructor elimination, crossfertilization, generalization
; or the elimination of irrelevance. It did not contain any notion of
; hints or disabledp. The system contained full fledged
; implementations of the definitional principle (with guards and
; termination proofs) and defaxiom (which contains all of the code to
; generate and store rules). The system did not contain the
; constraint or functional instantiation events or books. We have not
; yet had a "code walk" in which we jointly look at every line. There
; are known bugs in prove (e.g., induction causes a hard error when no
; candidates are found).
; Matt Kaufmann officially joined the project in August, 1993. He had
; previously generated a large number of comments, engaged in a number of
; design discussions, and written some code.
; Bob Boyer requested that he be removed as a coauthor of ACL2 in April, 1995,
; because, in his view, he has worked so much less on the project in the last
; few years than Kaufmann and Moore.
; End of Commemorative Plaque
; This function increments timers. Upon entry, the accumulated time is
; charged to 'othertime. The time spent in this function is divided
; between both 'provetime and to 'printtime.
(cond
((ldskipproofsp state) (value nil))
(t (stategloballet*
((guardcheckingon nil) ; see the Essay on Guard Checking
(inproveflg t))
(prog2$
(initializebrrstack state)
(erlet* ((ttree1 (proveloop (list (list term))
(change provespecvar pspv
:usersuppliedterm term
:orighints hints)
hints ens wrld ctx state)))
(erprogn
(chkassumptionfreettree ttree1 ctx state)
(cond
((taggedobject :bye ttree1)
(let ((byes (reverse (taggedobjects :bye ttree1 nil))))
(pprogn
; The use of ~*1 below instead of just ~&1 forces each of the defthm forms
; to come out on a new line indented 5 spaces. As is already known with ~&1,
; it can tend to scatter the items randomly  some on the left margin and others
; indented  depending on where each item fits flat on the line first offered.
(io? prove nil state
(wrld byes)
(fms "To complete this proof you should try to ~
admit the following ~
event~#0~[~/s~]~~%~*1~%See the discussion ~
of :by hints in :DOC hints regarding the ~
name~#0~[~/s~] displayed above."
(list (cons #\0 byes)
(cons #\1
(list ""
"~~ ~q*."
"~~ ~q*,~and~"
"~~ ~q*,~~%"
(makedefthmformsforbyes
byes wrld))))
(proofsco state)
state
nil))
(silenterror state))))
(t (value ttree1))))))))))
