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 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 9777 9778 9779 9780 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885

; 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")
;; RAG  I changed this value from 6 to 9 to make room for the
;; positive, negative, and complexirrationals.
(defconst *numberofnumerictypesetbits*
#+:nonstandardanalysis 9
#:nonstandardanalysis 6)
(defconst *typesetbinary+tablelist*
(let ((len (expt 2 *numberofnumerictypesetbits*)))
(cons (list :header
:dimensions (list len len)
:maximumlength (1+ (* len len))
:default *tsacl2number*
:name '*typesetbinary+table*)
(typesetbinary+alist (1 len) (1 len) nil))))
(defconst *typesetbinary+table*
(compress2 'typesetbinary+table
*typesetbinary+tablelist*))
(defconst *typesetbinary*tablelist*
(let ((len (expt 2 *numberofnumerictypesetbits*)))
(cons (list :header
:dimensions (list len len)
:maximumlength (1+ (* len len))
:default *tsacl2number*
:name '*typesetbinary*table*)
(typesetbinary*alist (1 len) (1 len) nil))))
(defconst *typesetbinary*table*
(compress2 'typesetbinary*table
*typesetbinary*tablelist*))
;; RAG  As a consequence of the extra numeric arguments, I had to
;; change this table from 5 to 7, to make room for the positive
;; and negative irrationals.
(defconst *typeset<tablelist*
#+:nonstandardanalysis
(cons (list :header
:dimensions '(128 128)
:maximumlength (1+ (* 128 128))
:name '*typeset<table*)
(typeset<alist 127 127 nil))
#:nonstandardanalysis
(cons (list :header
:dimensions '(32 32)
:maximumlength 1025
:name '*typeset<table*)
(typeset<alist 31 31 nil))
)
(defconst *typeset<table*
(compress2 'typeset<table
*typeset<tablelist*))
; Essay on Enabling, Enabled Structures, and Theories
; The rules used by the system can be "enabled" and "disabled". In a
; break with Nqthm, this is true even of :COMPOUNDRECOGNIZER rules.
; We develop that code now. Some of the fundamental concepts here are
; that of "rule names" or "runes" and their associated numeric
; correspondents, numes. We also explain "mapping pairs," "rule name
; designators", "theories," (both "common theories" and "runic
; theories") and "enabled structures".
(defun assocequalcdr (x alist)
; Like assocequal but compares against the cdr of each pair in alist.
(cond ((null alist) nil)
((equal x (cdar alist)) (car alist))
(t (assocequalcdr x (cdr alist)))))
(defun runep (x wrld)
; This function returns nonnil iff x is a rune, i.e., a "rule name,"
; in wrld. When nonnil, the value of this function is the nume of
; the rune x, i.e., the index allocated to this rule name in the
; enabled array. This function returns nil on fakerunes! See the
; essay on fakerunes below.
; To clear up the confusion wrought by the proliferation of
; nomenclature surrounding rules and the ways by which one might refer
; to them, I have recently adopted more colorful nomenclature than the
; old "rule name," "rule index," "rule id," etc. To wit,
; rune (rule name):
; an object that is syntactically of the form (token symb . x), where
; token is one of the ruleclass tokens, e.g., :REWRITE, :META, etc.,
; symb is a symbolp with a 'runicmappingpairs property, and x is
; either nil or a positive integer that distinguishes this rune from
; others generated from different :ruleclasses that share the same
; token and symb. We say that (token symb . x) is "based" on the
; symbol symb. Formally, rn is a rune iff it is of the form (& symb
; . &), symb is a symbolp with a nonnil runicinfo and rn is in the
; range of the mappingpairs of that runicinfo. This is just another
; way of saying that the range of the mapping pairs of a symbol is a
; complete list of all of the runes based on that symbol. Each rule
; in the system has a unique rune that identifies it. The user may
; thus refer to any rule by its rune. An ordered list of runes is a
; theory (though we also permit some nonrunes in theories presented
; by the user). Each rune has a status, enabled or disabled, as given
; by an enabled structure. I like the name "rune" because its
; etymology (from "rule name") is clear and it connotes an object that
; is at once obscure, atomic, and yet clearly understood by the
; scholar.
; nume (the numeric counterpart of a rune):
; a nonnegative integer uniquely associated with a rune. The nume of
; a rune tells us where in the enabled array we find the status of the
; rune.
; runic mapping pair:
; a pair, (nume . rune), consisting of a rune and its numeric
; counterpart, nume. The 'runicmappingpairs property of a symbol is
; the list of all runic mapping pairs whose runes are based on the
; given symbol. The 'runicmappingpairs value is ordered by
; ascending numes, i.e., the first nume in the list is the least. The
; primary role of runic mapping pairs is to make it more efficient to
; load a theory (ideally a list of runes) into an enabled structure.
; That process requires that we assemble an ACL2 array, i.e., an alist
; mapping array indices (numes) to their values (runes) in the array.
; We do that by collecting the runic mapping pairs of each rune in the
; theory. We also use these pairs to sort theories: theories are kept
; in descending nume order to make intersection and union easier. To
; sort a theory we replace each rune in it by its mapping pair, sort
; the result by descending cars, and then strip out the runes to obtain
; the answer. More on this when we discuss sortbyfnume.
; event name:
; The symbol, symb, in a rune (token symb . x), is an event name.
; Some event names are allowed in theories, namely, those that are the
; base symbols of runes. In such usage, an event name stands for one
; or more runes, depending on what kind of event it names. For
; example, if APP is the name of a defun'd function, then when APP
; appears in a theory it stands for the rune (:DEFINITION APP). If
; ASSOCOFAPP is a lemma name, then when it appears in a theory it
; stands for all the runes based on that name, e.g., if that event
; introduced two rewrite rules and an elim rule, then ASSOCOFAPP
; would stand for (:REWRITE ASSOCOFAPP . 1), (:REWRITE ASSOCOFAPP
; . 2), and (:ELIM ASSOCOFAPP). This use of event names allows them
; to be confused with rule names.
; Historical Footnote: In nqthm, the executable counterpart of the
; function APP actually had a distinct name, *1*APP, and hence we
; established the expectation that one could prevent the use of that
; "rule" while allowing the use of the other. We now use the runes
; (:DEFINITION APP) and (:EXECUTABLECOUNTERPART APP) to identify
; those two rules added by a defun event. In fact, the defun adds a
; third rule, named by the rune (:TYPEPRESCRIPTION APP). In fact, we
; were driven to the invention of runes as unique rule names when we
; added typeprescription lemmas.
(cond ((and (consp x)
(consp (cdr x))
(symbolp (cadr x)))
(car
(assocequalcdr x
(getprop (cadr x) 'runicmappingpairs nil
'currentacl2world wrld))))
(t nil)))
; Essay on FakeRunes
; The system has many built in rules that, for regularity, ought to
; have names and numes but don't because they can never be disabled.
; In addition, we sometimes wish to have a runelike object we can use
; as a mark, without having to worry about the possibility that a
; genuine rune will come along with the same identity. Therefore, we
; have invented the notion of "fakerunes." Fake runes are constants.
; By convention, the constant name is always of the form
; *fakerune...* and the value of every fake rune is always
; (:FAKERUNE... nil). Since no rule class will ever start with the
; words "fake rune" this convention will survive the introduction of
; all conceivable new rule classes. It is important that fake runes
; be based on the symbol nil. This way they are assigned the nume
; nil by fnume (below) and will always be considered enabled. The
; function runep does NOT recognize fake runes. Fake runes cannot be
; used in theories, etc.
; The fake runes are:
; *fakeruneforanonymousenabledrule*
; This fake rune is specially recognized by pushlemma and ignored. Thus, if
; you wish to invent a rule that you don't wish to name or worry will be
; disabled, give the rule this :rune and the :nume nil.
; *fakeruneforlinear*
; This fake rune is a signal that linear arithmetic was used.
; *fakerunefortypeset*
; This fake rune is used by typeset to record that builtin facts about
; primitive functions were used.
; *fakerunefornurewriter*
; This fake rune is used by the nthupdaterewriter to record the fact
; that either nthupdatenth or nthupdatentharray was used. We do
; not want to use either of the actual runes for those two rules
; because one or both might be disabled and it would be disturbing to
; see a rune come into a proof if it is disabled. To turn off the
; nurewriter, the user should use the nurewritermode.
; WARNING: If more fake runes are added, deal with them in tilde*simpphrase1.
(defmacro basesymbol (rune)
; The "base symbol" of the rune (:token symbol . x) is symbol.
; Note: The existence of this function and the next one suggest that
; runes are implemented abstractly. Ooooo... we don't know how runes
; are realy laid out. But this just isn't true. We use car to get
; the token of a rune and we use cddr to get x, above. But for some
; reason we defined and began to use basesymbol to get the base
; symbol. In any case, if the structure of runes is changed, all
; mention of runes will have to be inspected.
`(cadr ,rune))
(defmacro stripbasesymbols (runes)
`(stripcadrs ,runes))
(deflabel executablecounterpart
:doc
":DocSection Miscellaneous
a rule for computing the value of a function~/
~bv[]
Examples:
(:executablecounterpart length)
~ev[]
which may be abbreviated in ~il[theories] as
~bv[]
(length)
~ev[]~/
Every ~ilc[defun] introduces at least two rules used by the theorem
prover. Suppose ~c[fn] is the name of a ~ilc[defun]'d function. Then
~c[(:definition fn)] is the rune (~pl[rune]) naming the rule that
allows the simplifier to replace calls of ~c[fn] by its instantiated
body. ~c[(:executablecounterpart fn)] is the ~il[rune] for the rule for how
to evaluate the function on known constants.
When typing ~il[theories] it is convenient to know that ~c[(fn)] is a runic
designator that denotes ~c[(:executablecounterpart fn)].
~l[theories].
If ~c[(:executablecounterpart fn)] is ~il[enable]d, then when applications
of ~c[fn] to known constants are seen by the simplifier they are
computed out by executing the Common Lisp code for ~c[fn] (with the
appropriate handling of ~il[guard]s). Suppose ~c[fact] is defined as the
factorial function. If the executable counterpart ~il[rune] of ~c[fact],
~c[(:executablecounterpart fact)], is ~il[enable]d when the simplifier
encounters ~c[(fact 12)], then that term will be ``immediately''
expanded to ~c[479001600]. Note that even if subroutines of ~c[fn] have
disabled executable counterparts, ~c[fn] will call their Lisp code
nonetheless: once an executable counterpart function is applied, no
subsidiary enable checks are made.
Such onestep expansions are sometimes counterproductive because
they prevent the anticipated application of certain lemmas about the
subroutines of the expanded function. Such computed expansions can
be prevented by disabling the executable counterpart ~il[rune] of the
relevant function. For example, if ~c[(:executablecounterpart fact)]
is ~il[disable]d, ~c[(fact 12)] will not be expanded by computation. In this
situation, ~c[(fact 12)] may be rewritten to ~c[(* 12 (fact 11))], using the
rule named ~c[(:definition fact)], provided the system's heuristics
permit the introduction of the term ~c[(fact 11)]. Note that lemmas
about multiplication may then be applicable (while such lemmas would
be inapplicable to ~c[479001600]). In many proofs it is desirable to
~il[disable] the executable counterpart ~il[rune]s of certain functions to
prevent their expansion by computation.
~l[executablecounterparttheory].
Finally: What do we do about functions that are ``constrained''
rather than defined, such as the following? (~l[encapsulate].)
~bv[]
(encapsulate (((foo *) => *))
(local (defun foo (x) x)))
~ev[]
Does ~c[foo] have an executable counterpart? Yes: since the vast
majority of functions have sensible executable counterparts, it was
decided that ~st[all] functions, even such ``constrained'' ones, have
executable counterparts. We essentially ``trap'' when such calls
are inappropriate. Thus, consider for example:
~bv[]
(defun bar (x)
(if (rationalp x)
(+ x 1)
(foo x)))
~ev[]
If the term ~c[(bar '3)] is encountered by the ACL2 rewriter during a
proof, and if the ~c[:executablecounterpart] of ~c[bar] is ~il[enable]d, then it
will be invoked to reduce this term to ~c['4]. However, if the term
~c[(bar 'a)] is encountered during a proof, then since ~c['a] is not a
~ilc[rationalp] and since the ~c[:executablecounterpart] of ~c[foo] is only a
``trap,'' then this call of the ~c[:executablecounterpart] of ~c[bar] will
result in a ``trap.'' In that case, the rewriter will return the
term ~c[(hide (bar 'a))] so that it never has to go through this process
again. ~l[hide].~/")
(deflabel world
:doc
":DocSection Miscellaneous
ACL2 property lists and the ACL2 logical data base~/
A ``world'' is a list of triples, each of the form ~c[(sym prop . val)],
implementing the ACL2 notion of property lists. ACL2 permits the
simultaneous existence of many property list worlds. ``The world''
is often used as a shorthand for ``the ACL2 logical world'' which is
the particular property list world used within the ACL2 system to
maintain the data base of rules.~/
Common Lisp provides the notion of ``property lists'' by which one
can attach ``properties'' and their corresponding ``values'' to
symbols. For example, one can arrange for the ~c['color] property of
the symbol ~c['box14] to be ~c['purple] and the ~c['color] property of the
symbol ~c['triangle7] to be ~c['yellow]. Access to property lists is given
via the Common Lisp function ~c[get]. Thus, ~c[(get 'box14 'color)] might
return ~c['purple]. Property lists can be changed via the special form
~c[setf]. Thus, ~c[(setf (get 'box14 'color) 'blue)] changes the Common
Lisp property list configuration so that ~c[(get 'box14 'color)]
returns ~c['blue]. It should be obvious that ACL2 cannot provide this
facility, because Common Lisp's ~c[get] ``function'' is not a function
of its argument, but instead a function of some implicit state
object representing the property list settings for all symbols.
ACL2 provides the functions ~c[getprop] and ~c[putprop] which allow one to
mimic the Common Lisp property list facility. However, ACL2's
~c[getprop] takes as one of its arguments a list that is a direct
encoding of what was above called the ``state object representing
the property list settings for all symbols.'' Because ACL2 already
has a notion of ``~il[state]'' that is quite distinct from that used
here, we call this property list object a ``world.'' A world is
just a true list of triples. Each triple is of the form
~c[(sym prop . val)]. This world can be thought of as a slightly
elaborated form of association list and ~c[getprop] is a slightly
elaborated form of ~ilc[assoc] that takes two keys. When ~c[getprop] is
called on a symbol, ~c[s], property ~c[p], and world, ~c[w], it
scans ~c[w] for the first triple whose ~c[sym] is ~c[s] and ~c[prop] is
~c[p] and returns the corresponding ~c[val]. ~c[Getprop] has two
additional arguments, one of which that controls what it returns if
no such ~c[sym] and ~c[prop] exist in ~c[w], and other other of which
allows an extremely efficient implementation. To set some
property's value for some symbol, ACL2 provides ~c[putprop].
~c[(putprop sym prop val w)] merely returns a new world, ~c[w'], in
which ~c[(sym prop . val)] has been ~ilc[cons]ed onto the front of ~c[w],
thus ``overwriting'' the ~c[prop] value of ~c[sym] in ~c[w] to ~c[val]
and leaving all other properties in ~c[w] unchanged.
One aspect of ACL2's property list arrangment is that it is possible
to have many different property list worlds. For example, ~c['box14]
can have ~c['color] ~c['purple] in one world and can have ~c['color] ~c['yes] in
another, and these two worlds can exist simultaneously because
~c[getprop] is explicitly provided the world from which the property
value is to be extracted.
The efficiency alluded to above stems from the fact that Common Lisp
provides property lists. Using Common Lisp's provisions behind the
scenes, ACL2 can ``install'' the properties of a given world into
the Common Lisp property list state so as to make retrieval via
~c[getprop] very fast in the special case that the world provided to
~c[getprop] has been installed. To permit more than one installed world,
each of which is permitted to be changed via ~c[putprop], ACL2 requires
that worlds be named and these names are used to distinquish
installed versions of the various worlds. At the moment we do not
further document ~c[getprop] and ~c[putprop].
However, the ACL2 system uses a property list world, named
~c['currentacl2world], in which to store the succession of user
~il[command]s and their effects on the logic. This world is often
referred to in our ~il[documentation] as ``the world'' though it should
be stressed that the user is permitted to have worlds and ACL2's is
in no way distinguished except that the user is not permitted to
modify it except via event ~il[command]s. The ACL2 world is part of the
ACL2 ~il[state] and may be obtained via ~c[(w state)].
~st[Warning]: The ACL2 world is very large. Its length as of this
writing (Version 2.5) is over ~c[40,000] and it grows with each release.
Furthermore, some of the values stored in it are pointers to old
versions of itself. Printing ~c[(w state)] is something you should
avoid because you likely will not have the patience to await its
completion. For these practical reasons, the only thing you should
do with ~c[(w state)] is provide it to ~c[getprop], as in the form
~bv[]
(getprop sym prop default 'currentacl2world (w state))
~ev[]
to inspect properties within it, or to pass it to ACL2 primitives,
such as theory functions, where it is expected.
Some ACL2 ~il[command] forms, such as theory expressions
(~pl[theories]) and the values to be stored in tables
(~pl[table]), are permitted to use the variable symbol ~c[world]
freely with the understanding that when these forms are evaluated
that variable is bound to ~c[(w state)]. Theoretically, this gives
those forms complete knowledge of the current logical configuration
of ACL2. However, at the moment, few world scanning functions have
been documented for the ACL2 user. Instead, supposedly convenient
macro forms have been created and documented. For example,
~c[(currenttheory :here)], which is the theory expression which returns
the currently ~il[enable]d theory, actually macroexpands to
~c[(currenttheoryfn :here world)]. When evaluated with ~c[world] bound to
~c[(w state)], ~c[currenttheoryfn] scans the current ACL2 world and
computes the set of ~il[rune]s currently ~il[enable]d in it.")
(deflabel rune
:doc
":DocSection Theories
a rule name~/
~bv[]
Examples:
(:rewrite assocofapp)
(:linear deltaaref . 2)
(:definition length)
(:executablecounterpart length)
~ev[]~/
Background: The theorem prover is driven from a data base of rules. The most
common rules are ~c[:]~ilc[rewrite] rules, which cause the simplifier to
replace one term with another. ~il[Events] introduce rules into the data
base. For example, a ~ilc[defun] event may introduce runes for symbolically
replacing a function call by its instantiated body, for evaluating the
function on constants, for determining the type of a call of the function,
and for the induction scheme introduced upon defining the function.
~ilc[Defthm] may introduce several rules, one for each of the
~c[:]~ilc[ruleclasses] specified (where one rule class is specified if
~c[:]~ilc[ruleclasses] is omitted, namely, ~c[:rewrite]).
Every rule in the system has a name. Each name is a structured
object called a ``rune,'' which is short for ``rule name''. Runes
are always of the form ~c[(:token symbol . x)], where ~c[:token] is some
keyword symbol indicating what kind of rule is named, ~c[symbol] is the
event name that created the rule (and is called the ``base symbol''
of the rune), and ~c[x] is either ~c[nil] or a natural number that makes the
rule name distinct from that of rules generated by other ~il[events] or
by other ~c[:]~ilc[ruleclasses] within the same event.
For example, an event of the form
~bv[]
(defthm name thm
:ruleclasses ((:REWRITE :COROLLARY term1)
(:REWRITE :COROLLARY term2)
(:ELIM :COROLLARY term3)))
~ev[]
typically creates three rules, each with a unique rune. The runes are
~bv[]
(:REWRITE name . 1), (:REWRITE name . 2), and (:ELIM name).
~ev[]
However, a given formula may create more than one rule, and all rules
generated by the same ~c[:corollary] formula will share the same rune.
Consider the following example.
~bv[]
(defthm mythm
(and (equal (foo (bar x)) x)
(equal (bar (foo x)) x)))
~ev[]
This is treated identically to the following.
~bv[]
(defthm mythm
(and (equal (foo (bar x)) x)
(equal (bar (foo x)) x))
:ruleclasses ((:rewrite
:corollary
(and (equal (foo (bar x)) x)
(equal (bar (foo x)) x)))))
~ev[]
In either case, two rules are created: one rewriting ~c[(foo (bar x))] to
~c[x], and one rewriting ~c[(bar (foo x))] to ~c[x]. However, only a single
rune is created, ~c[(:REWRITE MYTHM)], because there is only one rule class.
But now consider the following example.
~bv[]
(defthm mythm2
(and (equal (foo (bar x)) x)
(equal (bar (foo x)) x))
:ruleclasses ((:rewrite
:corollary
(and (equal (foo (bar x)) x)
(equal (bar (foo x)) x)))
(:rewrite
:corollary
(and (equal (foo (bar (foo x))) (foo x))
(equal (bar (foo (bar x))) (bar x))))))
~ev[]
This time there are four rules created. The first two rules are as before,
and are assigned the rune ~c[(:REWRITE MYTHM . 1)]. The other two rules are
similarly generated for the second ~c[:corollary], and are assigned the rune
~c[(:REWRITE MYTHM . 2)].
The function ~ilc[corollary] will return the ~il[corollary] term associated
with a given rune in a given ~il[world]. Example:
~bv[]
(corollary '(:TYPEPRESCRIPTION DIGITTOCHAR) (w state))
~ev[]
However, the preferred way to see the corollary term associated with
a rune or a name is to use ~c[:pf]; ~pl[pf].
The ~ilc[defun] event creates as many as four rules. ~c[(:definition fn)] is
the rune given to the equality axiom defining the function, ~c[fn].
~c[(:executablecounterpart fn)] is the rune given to the rule for computing
~c[fn] on known arguments. A type prescription rule may be created under the
name ~c[(:typeprescription fn)], and an ~il[induction] rule may be created under
the name ~c[(:induction fn)].
Runes may be individually ~il[enable]d and ~il[disable]d, according to whether
they are included in the current theory. ~l[theories]. Thus,
it is permitted to ~il[disable] ~c[(:elim name)], say, while enabling the
other rules derived from name. Similarly, ~c[(:definition fn)] may be
~il[disable]d while ~c[(:executablecounterpart fn)] and the type
prescriptions for ~c[fn] are ~il[enable]d.
Associated with most runes is the formula justifying the rule named. This is
called the ``~il[corollary] formula'' of the rune and may be obtained via the
function ~ilc[corollary], which takes as its argument a rune and a property
list ~il[world]. Also ~pl[pf]. The ~il[corollary] formula for ~c[(:rewrite name . 1)]
after the ~ilc[defthm] event above is ~c[term1]. The corollary formulas for
~c[(:definition fn)] and ~c[(:executablecounterpart fn)] are always
identical: the defining axiom. Some runes, e.g., ~c[(:definition car)], do
not have corollary formulas. ~ilc[Corollary] returns ~c[nil] on such runes.
In any case, the corollary formula of a rune, when it is non~c[nil], is a
theorem and may be used in the ~c[:use] and ~c[:by] ~il[hints].
Note: The system has many built in rules that, for regularity, ought
to have names but don't because they can never be ~il[disable]d. One
such rule is that implemented by the linear arithmetic package.
Because many of our subroutines are required by their calling
conventions to return the justifying rune, we have invented the
notion of ``fake runes.'' Fake runes always have the base symbol
~c[nil], use a keyword token that includes the phrase ``fakerune'', and
are always ~il[enable]d. For example, ~c[(:fakeruneforlinear nil)] is a
fake rune. Occasionally the system will print a fake rune where a
rune is expected. For example, when the linear arithmetic fake rune
is reported among the rules used in a proof, it is an indication
that the linear arithmetic package was used. However, fake runes
are not allowed in ~il[theories], they cannot be ~il[enable]d or ~il[disable]d, and
they do not have associated ~il[corollary] formulas. In short, despite
the fact that the user may sometimes see fake runes printed, they
should never be typed.~/")
(deflabel rulenames
:doc
":DocSection Theories
How rules are named.~/
~bv[]
Examples:
(:rewrite assocofapp)
(:linear deltaaref . 2)
(:definition length)
(:executablecounterpart length)
~ev[]~/
~l[rune].~/")
(defun fnume (rune wrld)
; Rune has the shape of a rune. We return its nume. Actually, this function
; admits every fakerune as a "rune" and returns nil on them (by virtue of the
; fact that the basesymbol of a fake rune is nil and hence there are no
; mapping pairs). This fact may be exploited by functions which have obtained
; a fake rune as the name of some rule and wish to know its nume so they can
; determine if it is enabled. More generally, this function returns nil if
; rune is not a rune in the given world, wrld. Nil is treated as an enabled
; nume by enabledrunep but not by activerunep.
(car
(assocequalcdr rune
(getprop (basesymbol rune) 'runicmappingpairs nil
'currentacl2world wrld))))
(defun frunicmappingpair (rune wrld)
; Rune must be a rune in wrld. We return its mapping pair.
(assocequalcdr rune
(getprop (basesymbol rune) 'runicmappingpairs nil
'currentacl2world wrld)))
(defun fnrunenume (fn nflg xflg wrld)
; Fn must be a function symbol, not a lambda expression. We return
; either the rune (nflg = nil) or nume (nflg = t) associated with
; either (:DEFINITION fn) (xflg = nil) or (:EXECUTABLECOUNTERPART fn)
; (xflg = t). This function knows the layout of the runic mapping
; pairs by DEFUNS  indeed, it knows the layout for all function
; symbols whether DEFUNd or not! See the Essay on the Assignment of
; Runes and Numes by DEFUNS. If fn is a constrained function we
; return nil for all combinations of the flags.
(let* ((runicmappingpairs
(getprop fn 'runicmappingpairs nil 'currentacl2world wrld))
(pair (if xflg (cadr runicmappingpairs) (car runicmappingpairs))))
(if nflg (car pair) (cdr pair))))
(defun definitionrunes (fns xflg wrld)
(cond ((null fns) nil)
(t (cons (fnrunenume (car fns) nil xflg wrld)
(definitionrunes (cdr fns) xflg wrld)))))
(defun getnextnume (lst)
; We return the next available nume in lst, which is a cdr of the
; current world. We scan down lst, looking for the most recently
; stored 'runicmappingpairs entry. Suppose we find it, ((n1 .
; rune1) (n2 . rune2) ... (nk . runek)). Then the next rune will get
; the nume nk+1, which is also just n1+k, where k is the length of the
; list of mapping pairs. Note: If we see (name runicmappingpairs .
; atm) where atm is an atom, then atm is :acl2propertyunbound or
; nil, and we keep going. Such tuples appear in part because in
; redefinition the 'runicmappingpairs property is "nil'd" out.
(cond ((null lst)
#+acl2metering (metermaid 'getnextnume 100)
0)
((and (eq (cadr (car lst)) 'runicmappingpairs)
(consp (cddr (car lst))))
#+acl2metering (metermaid 'getnextnume 100)
(+ (car (car (cddr (car lst))))
(length (cddr (car lst)))))
(t
#+acl2metering (setq metermaidcnt (1+ metermaidcnt))
(getnextnume (cdr lst)))))
; We now formalize the notion of "theory". We actually use two
; different notions of theory here. The first, which is formalized by
; the predicate theoryp, is what the user is accustomed to thinking of
; as a theory. Formally, it is a truelist of rule name designators,
; each of which designates a set of runes. The second is what we
; call a "runic theory" which is an ordered list of runes, where the
; ordering is by descending numes. We sometimes refer to theories as
; "common theories" to distinguish them from runic theories. To every
; common theory there corresponds a runic theory obtained by unioning
; together the runes designated by each element of the common theory.
; We call this the runic theory "corresponding" to the common one.
(defun derefmacroname (macroname macroaliases)
(let ((entry (assoceq macroname macroaliases)))
(if entry
(cdr entry)
macroname)))
(defun rulenamedesignatorp (x macroaliases wrld)
; A rule name designator is an object which denotes a set of runes.
; We call that set of runes the "runic interpretation" of the
; designator. A rune, x, is a rule name designator, denoting {x}. A
; symbol, x, with a 'runicmappingpairs property is a designator and
; denotes either {(:DEFINITION x)} or else the entire list of runes in
; the runicmappingpairs, depending on whether there is a :DEFINITION
; rune. A symbol x that is a theory name is a designator and denotes
; the runic theory value. Finally, a singleton list, (fn), is a
; designator if fn is a function symbol; it designates
; {(:EXECUTABLECOUNTERPART fn)}.
; For example, if APP is a function symbol then its runic
; interpretation is {(:DEFINITION APP)}. If ASSOCOFAPP is a defthm
; event with, say, three rule classes then its runic interpretation is
; a set of three runes, one for each rule generated. The idea here is
; to maintain some consistency with the Nqthm way of disabling names.
; If the user disables APP then only the symbolic definition is
; disabled, not the executable counterpart, while if ASSOCOFAPP is
; disabled, all such rules are disabled.
; Note: We purposely do not define a function "runicinterpretation"
; which returns runic interpretation of a designator. The reason is
; that we would have to cons that set up for every designator except
; theories. The main reason we'd want such a function is to define
; the runic theory corresponding to a common one. We do that below
; (in converttheorytounorderedmappingpairs1) and opencode "runic
; interpretation."
(cond ((symbolp x)
(cond
((getprop (derefmacroname x macroaliases) 'runicmappingpairs nil
'currentacl2world wrld)
t)
(t (not (eq (getprop x 'theory t 'currentacl2world wrld) t)))))
((and (consp x)
(null (cdr x))
(symbolp (car x)))
(let ((fn (derefmacroname (car x) macroaliases)))
(and (functionsymbolp fn wrld)
(runep (list :executablecounterpart fn) wrld))))
(t (runep x wrld))))
(defun theoryp1 (lst macroaliases wrld)
(cond ((atom lst) (null lst))
((rulenamedesignatorp (car lst) macroaliases wrld)
(theoryp1 (cdr lst) macroaliases wrld))
(t nil)))
(defun theoryp (lst wrld)
; A (common) theory is a truelist of rule name designators. It is
; possible to turn a theory into a list of runes (which is, itself, a
; theory). That conversion is done by coercetorunictheory.
(theoryp1 lst (macroaliases wrld) wrld))
(defun theoryp!1 (lst failflg macroaliases wrld)
(cond ((atom lst) (and (not failflg) (null lst)))
((rulenamedesignatorp (car lst) macroaliases wrld)
(theoryp!1 (cdr lst) failflg macroaliases wrld))
((and (symbolp (car lst))
; Do not use the function macroargs below, as it can cause a hard error!
(not (eq (getprop (car lst) 'macroargs
t
'currentacl2world wrld)
t)))
(prog2$ (cw "~~%**NOTE**: The name ~x0 is a macro. See :DOC ~
addmacroalias if you want it to be associated with a ~
function name."
(car lst))
(theoryp!1 (cdr lst) t macroaliases wrld)))
(t (prog2$ (cw "~~%**NOTE**:~%The name ~x0 does not ~
designate a rule or nonempty list of rules."
(car lst))
(theoryp!1 (cdr lst) t macroaliases wrld)))))
(defun theoryp! (lst wrld)
(theoryp!1 lst nil (macroaliases wrld) wrld))
; Now we define what a "runic theory" is.
(defun runictheoryp1 (prevnume lst wrld)
; We check that lst is an ordered true list of runes in wrld, where
; the ordering is by descending numes. Prevnume is the nume of the
; previously seen element of lst (or nil if we are at the toplevel).
(cond ((atom lst) (null lst))
(t
(let ((nume (runep (car lst) wrld)))
(cond ((and nume
(or (null prevnume)
(> prevnume nume)))
(runictheoryp1 nume (cdr lst) wrld))
(t nil))))))
(defun runictheoryp (lst wrld)
; A "runic theory" (wrt wrld) is an ordered truelist of runes (wrt wrld), where
; the ordering is that imposed by the numes of the runes, greatest numes first.
; This function returns t or nil according to whether lst is a runic theory in
; wrld. Common theories are converted into runictheories in order to do such
; operations as union and intersection. Our theory processing functions all
; yield runictheories. We can save some time in those functions by checking
; if an input theory is in fact a runic theory: if so, we need not sort it.
(runictheoryp1 nil lst wrld))
; When we start manipulating theories, e.g., unioning them together,
; we will actually first convert common theories into runic theories.
; We keep runic theories ordered so it is easier to intersect and
; union them. However, this raises a slighly technical question,
; namely the inefficiency of repeatedly going to the property lists of
; the basic symbols of the runes to recover (by a search through the
; mapping pairs) the measures by which we compare runes (i.e., the
; numes). We could order theories lexicographically  there is no
; reason that theories have to be ordered by nume until it is time to
; load the enabled structure. We could also obtain the measure of
; each rune and cons the two together into a mapping pair and sort
; that list on the cars. This would at least save the repeated
; getprops at the cost of copying the list twice (once to pair the
; runes with their numes and once to strip out the final list of
; runes).
; We have compared these three schemes in a slightly simpler setting:
; sorting lists of symbols. The sample list was the list of all event
; names in the initial world, i.e., every symbol in the initial world
; with an 'absoluteeventnumber property. The lexicographic
; comparison was done with string<. The measure (analogous to the
; nume) was the 'absoluteeventnumber. We used exactly the same tail
; recursive merge routine used here, changing only the comparator
; expression. The version that conses the nume to the rune before
; sorting paid the price of the initial and final copying. The times
; to sort the 2585 symbols were:
; lexicographic: 1.29 seconds
; getprops: 1.18 seconds
; cars: 0.68 seconds
; We have decided to go the car route. The argument that it does a
; lot of unnecessary consing is unpersuasive in light of the amount of
; consing done by sorting. For example right off the bat in sort we
; divide the list into its evens and odds, thus effectively copying
; the entire list. The point is that as it has always been coded,
; sort produces a lot of garbaged conses, so it is not as though
; copying the list twice is a gross insult to the garbage collector.
; We exhibit some performance measures of our actual theory manipulation
; functions later. See Essay on Theory Manipulation Performance.
; Consider a runic theory. We want to "augment" it by consing onto
; every rune its nume. Common theories cannot be augmented until they
; are converted into runic ones. Naively, then we want to consider two
; transformations: how to convert a common theory to a runic one, and
; how to augment a runic theory. It turns out that the first
; transformation is messier than you'd think due to the possibility
; that distinct elements of the common theory designate duplicate
; runes. More on this later. But no matter what our final design, we
; need the second capability, since we expect that the theory
; manipulation functions will often be presented with runic theories.
; So we begin by augmentation of runic theories.
; Our goal is simply to replace each rune by its frunicmappingpair.
; But frunicmappingpair has to go to the property list of the basic
; symbol of the rune and then search through the 'runicmappingpairs
; for the pair needed. But in a runic theory, it will often be the
; case that adjacent runes have the same symbol, e.g., (:REWRITE LEMMA
; . 1), (:REWRITE LEMMA . 2), ... Furthermore, the second rune will
; occur downstream of the first in the 'runicmappingpairs of their
; basic symbol. So by keeping track of where we found the last
; mapping pair we may be able to find the next one faster.
(defun findmappingpairstail1 (rune mappingpairs)
; Rune is a rune and mappingpairs is some tail of the
; 'runicmappingpairs property of its basic symbol. Furthermore, we
; know that we have not yet passed the pair for rune in mappingpairs.
; We return the tail of mappingpairs whose car is the pair for rune.
(cond ((null mappingpairs)
(er hard 'findmappingpairstail
"We have exhausted the mappingpairs of the basic symbol ~
of ~x0 and failed to find that rune."
rune))
((equal rune (cdr (car mappingpairs))) mappingpairs)
(t (findmappingpairstail1 rune (cdr mappingpairs)))))
(defun findmappingpairstail (rune mappingpairs wrld)
; Rune is a rune and mappingpairs is some tail of the
; 'runicmappingpairs property of some basic symbol  but not
; necessarily rune's. If it is rune's then rune has not yet been seen
; among those pairs. If it is not rune's, then we get rune's from
; world. In any case, we return a mappingpairs list whose car is the
; mapping pair for rune.
(cond ((and mappingpairs
(eq (basesymbol rune) (cadr (cdr (car mappingpairs)))))
(findmappingpairstail1 rune mappingpairs))
(t (findmappingpairstail1 rune
(getprop (basesymbol rune)
'runicmappingpairs nil
'currentacl2world wrld)))))
(defun augmentrunictheory1 (lst mappingpairs wrld ans)
; Lst is a runic theory. We iteratively accumulate onto ans the
; mapping pair corresponding to each element of lst. Mappingpairs is
; the tail of some 'runicmappingpairs property and is used to speed
; up the retrieval of the pair for the first rune in lst. See
; findmappingpairstail for the requirements on mappingpairs. The
; basic idea is that as we cdr through lst we also sweep through
; mapping pairs (they are ordered the same way). When the rune we get
; from lst is based on the same symbol as the last one, then we find
; its mapping pair in mappingpairs. When it is not, we switch our
; attention to the 'runicmappingpairs of the new basic symbol.
(cond
((null lst) ans)
(t (let ((mappingpairs
(findmappingpairstail (car lst) mappingpairs wrld)))
(augmentrunictheory1 (cdr lst)
(cdr mappingpairs)
wrld
(cons (car mappingpairs) ans))))))
(defun augmentrunictheory (lst wrld)
; We pair each rune in the runic theory lst with its nume, returning an
; augmented runic theory.
(augmentrunictheory1 (reverse lst) nil wrld nil))
; Ok, so now we know how to augment a runic theory. How about
; converting common theories to runic ones? That is harder because of
; the duplication problem. For example, '(APP APP) is a common
; theory, but the result of replacing each designator by its rune,
; '((:DEFINITION app) (:DEFINITION app)), is not a runic theory! It
; gets worse. Two distict designators might designate the same rune.
; For example, LEMMA might designate a collection of :REWRITE rules
; while (:REWRITE LEMMA . 3) designates one of those same rules. To
; remove duplicates we actually convert the common theory first to a
; list of (possibly duplicated and probably unordered) mapping pairs
; and then use a bizarre sort routine which removes duplicates. While
; converting a common theory to a unordered and duplicitous list of
; mapping pairs we simply use frunicmappingpair to map from a rune
; to its mapping pair; that is, we don't engage in the clever use of
; tails of the mapping pairs properties because we don't expect to see
; too many runes in a common theory, much less for two successive
; runes to be ordered properly.
(defconst *badrunicdesignatorstring*
"This symbol was expected to be suitable for theory expressions; see :DOC ~
theories, in particular the discussion of runic designators. One possible ~
source of this problem is an attempt to include an uncertified book with a ~
deftheory event that attempts to use the above symbol in a deftheory event.")
(defun converttheorytounorderedmappingpairs1 (lst macroaliases wrld ans)
; This is the place we give meaning to the "runic interpretation" of a
; rule name designator. Every element of lst is a rule name
; designator.
(cond
((null lst) ans)
((symbolp (car lst))
(let ((temp (getprop (derefmacroname (car lst) macroaliases)
'runicmappingpairs nil
'currentacl2world wrld)))
(cond
((and temp
(eq (car (cdr (car temp))) :DEFINITION)
(eq (car (cdr (cadr temp))) :EXECUTABLECOUNTERPART))
(converttheorytounorderedmappingpairs1
(cdr lst) macroaliases wrld
(if (equal (length temp) 4)
; Then we have an :induction rune. See the Essay on the Assignment of Runes
; and Numes by DEFUNS.
(cons (car temp) (cons (cadddr temp) ans))
(cons (car temp) ans))))
(temp
(converttheorytounorderedmappingpairs1
(cdr lst) macroaliases wrld (revappend temp ans)))
(t
; In this case, we know that (car lst) is a theory name. Its 'theory
; property is the value of the theory name and is a runic theory. We
; must augment it. The twisted use of ans below  passing it into
; the accumulator of the augmenter  is permitted since we don't care
; about order.
(converttheorytounorderedmappingpairs1
(cdr lst) macroaliases wrld
(augmentrunictheory1
(reverse (getprop (car lst) 'theory
`(:error ,*badrunicdesignatorstring*)
'currentacl2world wrld))
nil
wrld
ans))))))
((null (cdr (car lst)))
(converttheorytounorderedmappingpairs1
(cdr lst) macroaliases wrld
(cons (cadr (getprop (derefmacroname (car (car lst)) macroaliases)
'runicmappingpairs
`(:error ,*badrunicdesignatorstring*)
'currentacl2world wrld))
ans)))
(t (converttheorytounorderedmappingpairs1
(cdr lst) macroaliases wrld
(cons (frunicmappingpair (car lst) wrld)
ans)))))
(defun converttheorytounorderedmappingpairs (lst wrld)
; This function maps a common theory into a possibly unordered and/or
; duplicitous list of mapping pairs.
(converttheorytounorderedmappingpairs1
lst (macroaliases wrld) wrld nil))
; Now we develop a merge sort routine that has four interesting
; properties. First, it sorts arbitrary lists of pairs, comparing on
; their cars which are assumed to be rationals. Second, it can be
; told whether to produce an ascending order or a descending order.
; Third, it deletes all but one occurrence of any element with the
; same car as another. Fourth, its merge routine is tail recursive
; and so can handle very long lists. (The sort routine is not tail
; recursive, but it cuts the list in half each time and so can handle
; long lists too.)
(defun duplicitousconscar (x y)
; This is like (cons x y) in that it adds the element x to the list y,
; except that it does not if the car of x is the car of the first element
; of y.
(cond ((equal (car x) (caar y)) y)
(t (cons x y))))
(defun duplicitousrevappendcar (lst ans)
; Like revappend but uses duplicitousconscar rather than cons.
(cond ((null lst) ans)
(t (duplicitousrevappendcar (cdr lst)
(duplicitousconscar (car lst) ans)))))
(defun duplicitousmergecar (parity lst1 lst2 ans)
; Basic Idea: Lst1 and lst2 must be appropriately ordered lists of
; pairs. Comparing on the cars of respective pairs, we merge the two
; lists, deleting all but one occurrence of any element with the same
; car as another.
; Terminology: Suppose x is some list of pairs and that the car of
; each pair is a rational. We say x is a "measured list" because the
; measure of each element is given by the car of the element. We
; consider two orderings of x. The "parity t" ordering is that in
; which the cars of x are ascending. The "parity nil" ordering is
; that in which the cars of x are descending. E.g., in the parity t
; ordering, the first element of x has the least car and the last
; element of x has the greatest.
; Let lst1 and lst2 be two measured lists. This function merges lst1
; and lst2 to produce output in the specified parity. However, it
; assumes that its two main inputs, lst1 and lst2, are ordered in the
; opposite parity. That is, if we are supposed to produce output that
; is ascending (parity = t) then the input must be descending (parity
; = nil). This odd requirement allows us to do the merge in a tail
; recursive way, accumulating the answers onto ans. We do it tail
; recursively because we are often called upon to sort huge lists and
; the naive approach has blown the stack of AKCL.
(cond ((null lst1) (duplicitousrevappendcar lst2 ans))
((null lst2) (duplicitousrevappendcar lst1 ans))
((if parity
(> (car (car lst1)) (car (car lst2)))
(< (car (car lst1)) (car (car lst2))))
(duplicitousmergecar parity (cdr lst1) lst2 (duplicitousconscar (car lst1) ans)))
(t (duplicitousmergecar parity lst1 (cdr lst2) (duplicitousconscar (car lst2) ans)))))
(defun duplicitoussortcar (parity lst)
; Let lst be a list of runes. If parity = t, we sort lst so that the
; numes of the resulting list are ascending; if parity = nil, the
; numes of the resulting list are descending.
; Note: This function is neat primarily because the merge function is
; tail recursive. It is complicated by the entirely extraneous
; requirement that it delete duplicates. The neat thing is that as it
; descends through lst, cutting it in half each time, it recursively
; orders the parts with the opposite sense of ordering. That is, to
; sort into ascending order it recursively sorts the two parts into
; descending order, which it achieves by sorting their parts into
; ascending order, etc.
(cond ((null (cdr lst)) lst)
(t (duplicitousmergecar parity
(duplicitoussortcar (not parity) (evens lst))
(duplicitoussortcar (not parity) (odds lst))
nil))))
(defun augmenttheory (lst wrld)
; Given a (common) theory we convert it into an augmented runic
; theory. That is, we replace each designator in lst by the
; appropriate runes, pair each rune with its nume, sort the result and
; remove duplications. In the special case that lst is in fact a
; runic theory  i.e., is already a properly sorted list of runes 
; we just augment it directly. We expect this case to occur often.
; The various theory manipulation functions take common theories as
; their inputs but produce runic theories as their outputs.
; Internally, they all operate by augmenting the input theory,
; computing with the augmented theory, and then dropping down to the
; corresponding runic theory at the end with stripcdrs. Thus if two
; such functions are nested in a usertyped theory expression, the
; inner one will generally have nonrunic usertyped input but will
; produce runic output as input for the next one. By recognizing
; runic theories as a special case we hope to improve the efficiency
; with which theory expressions are evaluated, by saving the sorting.
(declare (xargs :guard (theoryp lst wrld)))
(cond ((runictheoryp lst wrld)
(augmentrunictheory lst wrld))
(t (duplicitoussortcar
nil
(converttheorytounorderedmappingpairs lst wrld)))))
(defmacro assert$runictheoryp (runictheoryexpr wrld)
; Comment out one of the following two definitions.
;;; Faster, without checking:
(declare (ignore wrld))
runictheoryexpr
;;; Slower, with checking:
; `(let ((thy ,runictheoryexpr))
; (assert$ (runictheoryp thy ,wrld)
; thy))
)
(defun runictheory (lst wrld)
; Lst is a common theory. We convert it to a runic theory.
(cond ((runictheoryp lst wrld) lst)
(t (assert$runictheoryp
(stripcdrs
(duplicitoussortcar
nil
(converttheorytounorderedmappingpairs lst wrld)))
wrld))))
; We now develop the foundations of the concept that a rune is
; "enabled" in the current theory. In ACL2, the user can get "into" a
; theory with the intheory event, which is similar in spirit to
; inpackage but selects a theory as the "current" theory. A rune is
; said to be "enabled" if it is a member of the runic theory
; corresponding to the current (common) theory and is said to be
; "disabled" otherwise.
; Historical Note about Nqthm
; Nqthm had no explicit notion of the current theory. However,
; implicitly, nqthm contained a current theory and the events ENABLE
; and DISABLE allowed the user to add a name to it or delete a name
; from it. The experimental xnqthm, mentioned elsewhere in this
; system, introduced the notion of theories and tied them to enabling
; and disabling, following suggestions and patches implemented by Bill
; Bevier during the Kit proofs (and implemented in PcNqthm, and
; extended in Nqthm1992). The ACL2 notion of theory is much richer
; because it allows one to compute the value of theories using
; functions defined within the logic. (end of note)
; Suppose we have a theory which has been selected as current. This
; may be the globally current theory, as set by the intheory event,
; or it may be a locally current theory, as set by the intheory hint
; to defthm or defun. We must somehow process the current theory so
; that we can quickly answer the question "is rune enabled?" We now
; develop the code for doing that.
; The structure defined below is used as a fast way to represent a
; theory:
(defrec enabledstructure
; WARNING: Keep this in sync with enabledstructurep.
((indexoflastenabling . theoryarray)
(arrayname . arraylength)
arraynameroot . arraynamesuffix)
t)
; The following invariant is maintained in all instances of this
; structure. Theoryarray is an array1p whose array length is
; arraylength. Furthermore arrayname is a symbol of the form rootj,
; root is the arraynameroot (as a list of characters) and j is the
; arraynamesuffix. Thus, if i is a nonnegative integer less than
; arraylength, then (acl2aref1 arrayname theoryarray i) has a
; satisfied guard. Furthermore, important to efficiency but
; irrelevant to correctness, it will always be the case that the von
; Neumann array associated with arrayname is in fact theoryarray.
; Thus the above expression executes quickly. To get a new array
; name, should one ever be needed, it suffices to increment the
; arraynamesuffix and built a name from that new value.
; The theoryarray of an enabledstructure for a given common theory
; is (except for the header entry) just the augmented runic theory
; corresponding to the given common theory. That is, the ACL2 array
; alist we need to construct for a theory maps each array index to a
; nonnil value. The nonnil value we choose is in fact the
; corresponding rune. It would suffice, for purposes of enabling, to
; store T in the array to signify enabledness. By storing the rune
; itself we make it possible to determine what runic theory is in the
; array. (There is no general purpose way to map from a nume to its
; rune (short of looking through the whole world).)
; The global variable 'globalenabledstructure contains an instance
; of the enabledstructure record in which the arrayname is
; ENABLEDARRAY0, arraynameroot is the list of characters in
; "ENABLEDARRAY" and the arraynamesuffix is 0. A rune with
; nume n is (globally) enabled in the current world iff either n is
; greater than the indexoflastenabling or array[n] is nonnil.
; This is just the computation done by enablednumep, below.
; The intheory event loads the 'globalenabledstructure with
; the theoryvalue and sets the indexoflastenabling to the maximum
; nume at that time. This structure is passed into prove and
; thus into rewrite, etc.
; When an intheory hint setting is provided we change the array name
; from ENABLEDARRAYj to ENABLEDARRAYj+1 (changing suffix
; appropriately) and load the local theory into that structure. After
; we have done a few proofs with local intheory hint settings, these
; auxiliary arrays will have been allocated and won't be deallocated.
; Historical Note about Nqthm
; In nqthm we solved this problem by having a list of temporarily
; disabled names which was bound when there were local enabling hint
; settings. That implementation suffered because if hundreds of names
; were enabled locally the time spent searching the list was
; excessive. In xnqthm we solved that problem by storing the enabled
; status on the property list of each name. We could do that here.
; However, that implementation suffered from the fact that if a proof
; attempt was aborted then we had to carefully clean up the property
; list structures so that they once again reflected the current
; (global) theory. The beauty of the ACL2 approach is that local hint
; settings have no affect on the global theory and yet involve no
; overhead.
; A delicacy of the current implementation however concerns the
; relation between the global enabled structure and undoing. If the
; world is backed up to some previous point, the
; 'globalenabledstructure extant there is exposed and we are
; apparently ready to roll. However, the von Neumann array named by
; that structure may be outdated in the sense that it contains a now
; undone theory. Technically there is nothing wrong with this, but if
; we let it persist things would be very slow because the attempt to
; access the applicative array would detect that the von Neumann array
; is out of date and would result in a linear search of the
; applicative array. We must therefore compress the applicative array
; (and hence reload the von Neumann one) whenever we back up.
; Finally, there is one last problem. Eventually the arraysize of
; the array in one of these structures will be too small. This
; manifests itself when the maximum rule index at the time we load the
; structure is equal to or greater than the arraylength. At that
; time we grow the array size by 500.
; Here is how we use an enabled structure, ens, to determine if a nume,
; rune, or function is enabled.
(defun enablednumep (nume ens)
; This function takes a nume (or nil) and determines if it is enabled
; in the enabled structure ens. We treat nil as though it were
; enabled.
(cond ((null nume) t)
((> (thefixnum nume)
(thefixnum
(access enabledstructure ens :indexoflastenabling)))
t)
(t (aref1 (access enabledstructure ens :arrayname)
(access enabledstructure ens :theoryarray)
nume))))
(defun enabledarithnumep (nume ens)
; This function takes a nume (or nil) and determines if it is enabled
; in the enabled structure ens. We treat nil as though it were
; enabled. In current usage, ens is always the global arithmetic
; theory. Any nume created since the most recent inarithmetictheory
; is considered disabled. The normal enablednumep would treat these
; more recent numes as enabled.
(cond ((null nume) t)
((> nume (access enabledstructure ens :indexoflastenabling))
nil)
(t (aref1 (access enabledstructure ens :arrayname)
(access enabledstructure ens :theoryarray)
nume))))
(defun enabledrunep (rune ens wrld)
; This takes a rune and determines if it is enabled in the enabled structure
; ens. Since fnume returns nil on fakerunes, this function answers that a
; fake rune is enabled. See also activerunep.
(enablednumep (fnume rune wrld) ens))
(defmacro activerunep (rune)
; This takes a rune and determines if it is enabled in the enabled structure
; ens. Unlike enabledrunep, this returns nil if the rune is a fakerune or is
; not a runep in the given wrld.
":DocSection Theories
check that a ~il[rune] exists and is ~il[enable]d~/
~bv[]
Example:
(activerunep '(:rewrite lefttoright))~/
General Form:
(activerunep rune)
~ev[]
where ~c[rune] has the shape of a ~il[rune]. This macro expands to an
expression using the variables ~c[ens] and ~c[state], and returns non~c[nil]
when the given rune exists and is ~il[enable]d (according to the given
``enabled structure,'' ~c[ens], and the current logical ~il[world] of the
given ~ilc[state]). ~l[theoryinvariant] for how this macro can be of
use.~/"
`(let* ((rune ,rune)
(nume (and (consp rune)
(consp (cdr rune))
(symbolp (cadr rune))
; The tests above guard the call of fnume just below, the same way that runep
; guards the computation made in its body from the property list.
(fnume rune (w state)))))
(and nume
(enablednumep nume ens))))
(defun enabledxfnp (fn ens wrld)
; Fn must be either a function symbol or lambda expression, i.e., something you
; might get from ffnsymb of a term. If fn is a lambda expression or a
; constrained function symbol, we return t. Otherwise, we consider
; (:EXECUTABLECOUNTERPART fn), and answer whether it is enabled.
; Note: This function exploits the fact that nil is considered enabled by
; enablednumep.
; Note: Suppose you want to determine whether (:DEFINITION fn) is enabled.
; Perhaps you really want to know if the latest definition rule for fn that has
; nonnil :installbody field is enabled; and you may also want to ask other
; questions about the defbody of fn. Then this function is not the one
; to use!
(cond ((flambdap fn) t)
(t (enablednumep (fnrunenume fn t t wrld) ens))))
; Before we develop the code for loading a theory into an enabled
; structure, we put down code for warning when leaving a 0ary
; function disabled while its executable counterpart is enabled.
(defun theorywarningfnsaux (runes1 runes2 maxnume
nume prevrune1 prevrune2 w acc)
; See the comment in theorywarningfns for a general discussion, in particular
; of (1), (2), and (3) below. We apply reverse to the returned accumulator in
; order to return function symbols in the order in which they were defined (a
; minor aesthetic preference).
(declare (type (signedbyte 29) nume))
(cond
((eql nume maxnume)
(reverse acc))
(t
(let* ((found1 (eql (caar runes1) nume))
(found2 (eql (caar runes2) nume))
(currrune1 (and found1 (cdar runes1)))
(currrune2 (and found2 (cdar runes2)))
(restrunes1 (if found1 (cdr runes1) runes1))
(restrunes2 (if found2 (cdr runes2) runes2)))
(theorywarningfnsaux
restrunes1 restrunes2 maxnume (1+f nume) currrune1 currrune2 w
(if (and (eq (car currrune2) :executablecounterpart)
(null prevrune2) ; (1)
(not (and currrune1 (null prevrune1))) ; (2)
(null (formals (cadr currrune2) w))) ; (3)
(cons (cadr currrune2) acc)
acc))))))
(defun theorywarningfns (ens1 ens2 w)
; Here is our strategy for producing warnings when an intheory event or hint
; leaves us with a 0ary function whose :executablecounterpart is enabled but
; :definition is not. We assume that we have our hands on two enabled
; structures: the preexisting one, which we call ens1, and the one created by
; the intheory event or hint, which we call ens2 and is returned by
; loadtheoryintoenabledstructure. Note that the length of ens2 is at least
; as great as the length of ens1. We walk through all indices (numes) of ens1.
; When do we find something worth warning about? We only have a problem when
; we find an enabled :executablecounterpart at the current nume in ens2. By
; the Essay on the Assignment of Runes and Numes by DEFUNS, we know that the
; previous nume represents the corresponding :definition. Three conditions
; must now hold: (1) The preceding (:definition) rune is disabled in ens2; (2)
; The same problem was not already present in ens1; and (3) The function in
; question is 0ary.
; We deal with the arrays as lists ordered by car, rather than using aref1,
; because the two arrays may have the same name in which case the first one is
; probably out of date. We apply cdr to remove the headers.
(theorywarningfnsaux (cdr (access enabledstructure ens1 :theoryarray))
(cdr (access enabledstructure ens2 :theoryarray))
(1+ (access enabledstructure ens2
:indexoflastenabling))
0 nil nil w nil))
(defun maybewarnabouttheory (ens1 forcexnumeen1 immxnumeen1 ens2
ctx wrld state)
; Ens1 is the enabled structure before an intheory event or hint, and ens2 is
; the resulting enabled structure. It is a bit unfortunate that warningoffp
; is checked twice, but that is a trivial inefficiency, certainly overshadowed
; by the savings in calling theorywarningfns needlessly.
; Forcexnumeen1 is the enabled status of forcing (*forcexnume*) in ens1.
; Immxnumeen1 is the status immediate force mode
; (*immediateforcemodepxnume*) in ens1.
(cond
((warningdisabledp "Disable")
state)
(t (pprogn
(let ((fns (theorywarningfns ens1 ens2 wrld)))
(if fns
(warning$ ctx ("Disable")
"The following 0ary function~#0~[~/s~] will now have ~
~#0~[its :definition rune~/their :definition runes~] ~
disabled but ~#0~[its :executablecounterpart ~
rune~/their :executablecounterpart runes~] enabled, ~
which will allow ~#0~[its definition~/their ~
definitions~] to open up after all: ~&0.~See :DOC ~
theories."
fns)
state))
(cond
((and forcexnumeen1
(not (enablednumep *forcexnume* ens2)))
(warning$ ctx ("Disable")
"Forcing has transitioned from enabled to disabled.~~
See :DOC force."))
((and (not forcexnumeen1)
(enablednumep *forcexnume* ens2))
(warning$ ctx ("Disable")
"Forcing has transitioned from disabled to enabled.~~
See :DOC force."))
(t state))
(cond
((and immxnumeen1
(not (enablednumep *immediateforcemodepxnume* ens2)))
(warning$ ctx ("Disable")
"IMMEDIATEFORCEMODEP has transitioned from enabled to ~
disabled.~See :DOC force."))
((and (not immxnumeen1)
(enablednumep *immediateforcemodepxnume* ens2))
(warning$ ctx ("Disable")
"IMMEDIATEFORCEMODEP has transitioned from disabled to ~
enabled.~See :DOC immediateforcemodep."))
(t state))))))
; And now we develop the code for loading a theory into an enabled
; structure.
(defrec theoryinvariantrecord
(tterm error . untransterm)
t)
(defun chktheoryinvariant1 (theoryexpr ens invariantalist errpacc ctx state)
; We check a theory represented in enabled structure ens against the theory
; invariants in invariantalist. If theoryexpr is :fromhint then this theory
; comes from an :intheory hint, and if it is :install then it is from
; installing a world; otherwise, theoryexpr is a theory expression
; corresponding to this theory.
(cond
((null invariantalist)
(mv errpacc nil state))
(t (let* ((tableentry (car invariantalist))
(invname (car tableentry))
(invrec (cdr tableentry))
(theoryinv (access theoryinvariantrecord invrec :tterm)))
(mvlet
(erp okp latches)
(ev theoryinv
(list (cons 'ens ens)
(cons 'state (coercestatetoobject state)))
state
nil
nil)
(declare (ignore latches))
(cond
(erp (let ((msg (msg
"Theory invariant ~x0 could not be evaluated on ~
the theory produced by ~@1. Theory invariant, ~
~P32, produced the error message:~%~@4~@5"
invname
(cond ((eq theoryexpr :fromhint)
"an :intheory hint")
((eq theoryexpr :install)
"the current event")
(t (msg "~X01" theoryexpr nil)))
nil
(access theoryinvariantrecord invrec :untransterm)
okp
(if (access theoryinvariantrecord invrec :error)
"~This theory invariant violation causes an ~
error."
""))))
(mvlet
(errpacc state)
(cond
((access theoryinvariantrecord invrec :error)
(mvlet (erp val state)
(er soft ctx "~@0" msg)
(declare (ignore erp val))
(mv t state)))
(t (pprogn (warning$ ctx "Theory" "~@0" msg)
(mv errpacc state))))
(chktheoryinvariant1 theoryexpr ens (cdr invariantalist)
errpacc ctx state))))
(okp (chktheoryinvariant1 theoryexpr ens (cdr invariantalist)
errpacc ctx state))
(t (let ((msg (msg
"Theory invariant ~x0 failed on the theory produced ~
by ~@1. Theory invariant ~x0 is ~P32.~@4"
invname
(cond ((eq theoryexpr :fromhint)
"an :intheory hint")
((eq theoryexpr :install)
"the current event")
(t (msg "~X01" theoryexpr nil)))
nil
(access theoryinvariantrecord invrec :untransterm)
(if (access theoryinvariantrecord invrec :error)
"~This theory invariant violation causes an ~
error."
""))))
(mvlet
(errpacc state)
(cond
((access theoryinvariantrecord invrec :error)
(mvlet (erp val state)
(er soft ctx "~@0" msg)
(declare (ignore erp val))
(mv t state)))
(t (pprogn (warning$ ctx "Theory" "~@0" msg)
(mv errpacc state))))
(chktheoryinvariant1 theoryexpr ens (cdr invariantalist)
errpacc ctx state))))))))))
(defun chktheoryinvariant (theoryexpr ens ctx state)
; See the comment in chktheoryinvariant1.
(chktheoryinvariant1 theoryexpr
ens
(tablealist 'theoryinvarianttable (w state))
nil
ctx
state))
(defun loadtheoryintoenabledstructure
(theoryexpr theory augmentedp ens incrmtarraynameflg
indexoflastenabling wrld ctx state)
; Note: Theory must be a runic theory if augmentedp is nil and otherwise an
; augmented runic theory, but never a common theory.
; We do exactly what the name of this function says, we load the given theory
; into the enabled structure ens. If incrmtarraynameflg is t we increment
; the array name suffix. Otherwise, we use the same name. Loading consists of
; augmenting the theory (if augmentedp is nil) to convert it into a list of
; pairs, (nume . rune), mapping numes to their runes, and then compressing it
; into the named array. We set the index of last enabling to be the highest
; existing nume in wrld right now unless indexoflastenabling is nonnil, in
; which case we use that (which should be a natp). Thus, any name introduced
; after this is enabled relative to this ens. If the array of the ens is too
; short, we extend it by 500.
; A Refresher Course on ACL2 One Dimensional Arrays:
; Suppose that a is an array with :dimension (d) and :maximumlength
; m. Then you access it via (aref1 'name a i). It must be the case
; that i<d. If every slot of a were filled, the length of a would be
; d, but the maximum index would be d1, since indexing is 0based.
; You set elements with (aset1 'name a i val). That increases the
; length of a by 1. When (length a) > m, a compress is done. If an
; array is never modified, then the mimimum acceptable m is in fact d.
; Note: Every call of this function should be followed by a call of
; maybewarnabouttheory on the enabled structure passed in and the one
; returned.
(let* ((n (or indexoflastenabling (1 (getnextnume wrld))))
(d (access enabledstructure ens :arraylength))
(newd (cond ((< n d) d)
(t (+ d (* 500 (1+ (floor ( n d) 500)))))))
(root (access enabledstructure ens :arraynameroot))
(suffix (cond (incrmtarraynameflg
(1+ (access enabledstructure ens :arraynamesuffix)))
(t (access enabledstructure ens :arraynamesuffix))))
(name (cond (incrmtarraynameflg
(intern (coerce
(append root
(explodenonnegativeinteger suffix
10
nil))
'string)
"ACL2"))
(t (access enabledstructure ens :arrayname))))
(alist (if augmentedp
theory
(augmentrunictheory theory wrld)))
(ens (make enabledstructure
:indexoflastenabling n
:theoryarray
(compress1 name
(cons (list :header
:dimensions (list newd)
:maximumlength (1+ newd)
:default nil
:name name
:order nil)
alist))
:arrayname name
:arraylength newd
:arraynameroot root
:arraynamesuffix suffix)))
(erprogn (if (or (eq theoryexpr :nocheck)
(eq (ldskipproofsp state) 'includebook)
(eq (ldskipproofsp state) 'includebookwithlocals))
(value nil)
(chktheoryinvariant theoryexpr ens ctx state))
(value ens))))
; Here is how we initialize the global enabled structure, from which
; all subsequent structures are built.
(defun initialglobalenabledstructure (rootstring)
; We generate an initial enabledstructure in which everything is enabled.
; The array is empty but of length d (which is the constant 1000 here).
; The array name is formed by adding a "0" to the end of rootstring.
; The arraynameroot is the list of characters in rootstring and the suffix
; is 0.
(let* ((root (coerce rootstring 'list))
(name (intern (coerce (append root '(#\0)) 'string)
"ACL2"))
(d 1000))
(make enabledstructure
:indexoflastenabling 1
:theoryarray (compress1 name
(cons (list :header
:dimensions (list d)
:maximumlength (1+ d)
:default nil
:name name)
nil))
:arrayname name
:arraylength d
:arraynameroot root
:arraynamesuffix 0)))
; And here is the function that must be used when you undo back to a
; previous value of the global enabled structure:
(defun recompressglobalenabledstructure (varname wrld)
; Logically speaking this function is a noop that returns t. It is
; only called from #acl2looponly code. Practically speaking it
; sideeffects the von Neumann array named in the globalenabled
; structure so that it once again contains the current array.
; This function is called when you have reason to believe that the von
; Neumann array associated with the global enabled structure is out of
; date. Suppose that wrld, above, was obtained from the then current
; ACL2 world by rolling back, as with UBT. Then there is possibly a
; new 'globalenabledstructure in wrld. But the array associated
; with it is still the one from the nownolonger current ACL2 world.
; We just compress the new array again. Because the array was already
; compressed, we know compress1 returns an eq object and so we don't
; actually have to store its value back into the globalenabledstructure.
; Indeed, we don't want to do that because it would require us to put a
; new binding of 'globalenabledstructure on wrld and we don't want to
; to do that. (Once upon a time we did, and it was inconvenient because
; it covered up the most recent commandlandmark; indeed, sometimes there
; would be two successive bindings of it.)
(declare (xargs :guard (and (equal varname varname)
(equal wrld wrld))))
; Without the odd guard  some term mentioning all the formals  the formals
; are recognized as irrelevant! This body below always returns t.
(let* ((ges1 (getprop varname 'globalvalue nil
'currentacl2world wrld))
(theoryarray (access enabledstructure ges1 :theoryarray))
(name (access enabledstructure ges1 :arrayname)))
; We would rather not pay the price of making a new array if the proper
; association of array to alist is already set up. Since this function is
; logically a noop (it is just a function that returns t), it is certainly
; legitimate to punt if we like. But it might be nice to abstract what we are
; doing here and make it available to the ACL2 user.
#acl2looponly
(when (let ((oldar (get name 'acl2array)))
(and oldar
(eq (car oldar) theoryarray)))
(returnfrom recompressglobalenabledstructure t))
(let ((toignore
(cond (ges1
(prog2$ (flushcompress name)
(compress1 name theoryarray)))
(t nil))))
(declare (ignore toignore))
t)))
(defun recompressstobjaccessorarrays (stobjnames wrld)
; This function has nothing to do with theories, but we place it here because
; it has a similar function to recompressglobalenabledstructure, defined
; just above. This function should be called when the 'accessornames arrays
; (used for printing nth/updatenth accesses to stobjs) might be out of date.
(if (endp stobjnames)
t
(let* ((st (car stobjnames))
(ar (getprop st 'accessornames nil 'currentacl2world wrld)))
(prog2$ (or (null ar)
(prog2$ (flushcompress st)
(compress1 st ar)))
(recompressstobjaccessorarrays (cdr stobjnames) wrld)))))
; We have defined all the basic concepts having to do with theories
; except the interface to the user, i.e., the "theory manipulation
; functions" with which the user constructs theories, the polite and
; verbose theory checkers that ensure that a theory expression
; produced a theory, and the events for defining theories and setting
; the current one. We do these things later and return now to the
; development of typeset.
; The Typesetxxx Functions
; We are about to embark on a litany of definitions for determining
; the typeset of various function applications, given the typesets
; of certain of their arguments. There is no fixed style of
; definition here; because typeset is so often called, we thought it
; best to pass in only those arguments actually needed, rather than
; adhere to some standard style. All of the functions return a type
; set and a ttree. The ttree is always used as an accumulator in the
; sense that we may extend but may not ignore the incoming ttree.
; This raises a problem: Suppose that the ttree records our work in
; establishing the type set, ts, of an argument but that we ultimately
; ignore ts because it is not strong enough to help. If we return the
; extended ttree, we might cause unnecessary case splits (justifying
; the irrelevant fact that the arg has typeset ts). We adopt the
; convention of passing in two ttrees, named ttree and ttree0. Ttree
; is always an extension of ttree0 and records the work done to get
; the argument type sets. Therefore, we may return ttree (possibly
; extended) if our answer is based on the argument type sets, and may
; return ttree0 otherwise (which merely passes along unknown
; previously done work of any sort, not necessarily only work done on this
; particular term  so do not return nil instead of ttree0!).
; The primitive typeset functions all push the following fake rune into the
; ttree they return, so that we know that primitive typeset knowledge was
; used. Before we invented this fake rune, we attributed this typeset
; reasoning to propositional calculus, i.e., we would report that (implies
; (integerp x) (integerp (1 x))) was proved by trivial observations. But we
; prefer to think of it (and report it) as type reasoning. See the Essay on
; FakeRunes for a discussion of fake runes.
(defconst *fakerunefortypeset*
'(:FAKERUNEFORTYPESET nil))
; To make it convenient to push this rune into a tree we provide:
(defun puffert (ttree)
; Once upon a time this function was called PushFakeRuneforTypeSet. It
; got shortened to pfrts and pronounced "pufferts". The name stuck except that
; the final s was dropped to make it more like a firstperson verb form. You
; know, ``I puffert'', ``you puffert'', ``he pufferts.'' Here, we frequently
; puffert ttrees. Right.
(pushlemma *fakerunefortypeset* ttree))
(defun immediateforcep (fn ens)
; This function must return 'casesplit, t or nil!
(cond ((eq fn 'casesplit) 'casesplit)
((enablednumep *immediateforcemodepxnume* ens) t)
(t nil)))
(defmacro numerictypeset (ts)
; Warning: This is a dangerous macro because it evaluates ts more than once!
; It is best if the argument is a variable symbol.
; This coerces ts into the type *tsacl2number*. That is, if ts contains
; nonnumeric bits then those bits are shut off and *tszero* is turned on.
; Another way to look at it is that if term has type ts then (fix term) has
; type (numerictypeset ts).
; Note: We tried wrapping (thetypeset ...) around the form below, inside the
; backquote, but found that (disassemble 'TYPESETBINARY+) produced identical
; results either way.
`(let ((numerictsusenowhereelse
(tsintersection (checkvarsnotfree
(numerictsusenowhereelse)
,ts)
*tsacl2number*)))
(if (ts= numerictsusenowhereelse ,ts)
,ts
(tsunion numerictsusenowhereelse *tszero*))))
(defmacro rationaltypeset (ts)
; Warning: This is a dangerous macro because it evaluates ts more than once!
; It is best if the argument is a variable symbol.
; This macro is like numerictypeset, but coerces ts to the rationals. Note
; that it reuses the special variable numerictsusenowhereelse even though
; this is a slight misnomer.
`(let ((numerictsusenowhereelse
(tsintersection (checkvarsnotfree
(numerictsusenowhereelse)
,ts)
*tsrational*)))
(if (ts= numerictsusenowhereelse ,ts)
,ts
(tsunion numerictsusenowhereelse *tszero*))))
;; RAG  I added this function analogously to rationaltypeset.
#+:nonstandardanalysis
(defmacro realtypeset (ts)
; Warning: This is a dangerous macro because it evaluates ts more than once!
; It is best if the argument is a variable symbol.
; This macro is like numerictypeset, but coerces ts to the reals. Note
; that it reuses the special variable numerictsusenowhereelse even though
; this is a slight misnomer.
`(let ((numerictsusenowhereelse
(tsintersection (checkvarsnotfree
(numerictsusenowhereelse)
,ts)
*tsreal*)))
(if (ts= numerictsusenowhereelse ,ts)
,ts
(tsunion numerictsusenowhereelse *tszero*))))
; We start with probably the most complicated primitive type set
; function, that for binary+.
(defun typesetbinary+ (term ts1 ts2 ttree ttree0)
; Because 1 (i.e., SUB1) is so common and often is applied to
; strictly positive integers, it is useful to know that, in such
; cases, the result is a nonnegative integer. We therefore test for
; (+ x 1) and its commuted version (+ 1 x). To be predictable, we
; also look for (+ x +1), and its commuted version, when x is strictly
; negative. We specially arrange for the answer typeset to be empty
; if either of the input typesets is empty. This occurs when we are
; guessing type sets. The idea is that some other branch ought to
; give us a nonempty typeset before this one can meaningfully
; contribute to the answer. Before we added the special processing of
; +1 and 1 we did not have to check for the empty case because the
; array referenced by aref2 has the property that if either typeset
; is empty the result is empty.
(let ((arg1 (fargn term 1))
(arg2 (fargn term 2)))
(cond ((or (ts= ts1 *tsempty*)
(ts= ts2 *tsempty*))
(mv *tsempty* ttree))
((and (equal arg2 ''1)
(tssubsetp ts1 *tspositiveinteger*))
(mv *tsnonnegativeinteger* (puffert ttree)))
((and (equal arg1 ''1)
(tssubsetp ts2 *tspositiveinteger*))
(mv *tsnonnegativeinteger* (puffert ttree)))
((and (equal arg2 ''+1)
(tssubsetp ts1 *tsnegativeinteger*))
(mv *tsnonpositiveinteger* (puffert ttree)))
((and (equal arg1 ''+1)
(tssubsetp ts2 *tsnegativeinteger*))
(mv *tsnonpositiveinteger* (puffert ttree)))
(t (let ((ans (aref2 'typesetbinary+table
*typesetbinary+table*
(numerictypeset ts1)
(numerictypeset ts2))))
(mv ans
(puffert (if (ts= ans *tsacl2number*)
ttree0
ttree))))))))
(defun typesetbinary* (ts1 ts2 ttree ttree0)
; See typesetbinary+ for a few comments.
(cond ((or (ts= ts1 *tsempty*)
(ts= ts2 *tsempty*))
(mv *tsempty* ttree))
(t (let ((ans (aref2 'typesetbinary*table
*typesetbinary*table*
(numerictypeset ts1)
(numerictypeset ts2))))
(mv ans
(puffert (if (ts= ans *tsacl2number*)
ttree0
ttree)))))))
(defun typesetnot (ts ttree ttree0)
(cond
((ts= ts *tsnil*)
(mv *tst* (puffert ttree)))
((tssubsetp *tsnil* ts)
(mv *tsboolean* ttree0))
(t (mv *tsnil* (puffert ttree)))))
(defun typeset<1 (r arg2 commutedp typealist)
; We are trying to determine the truth value of an inequality, (< arg1
; arg2) where arg1 is (quote r), a rational constant. Except, in the
; case that commutedp is nonnil the inequality at issue is (< arg2
; (quote r)).
; We scan through the typealist looking for inequalities that imply
; the truth or falsity of the inequality at issue, and return two
; values  the determined type of the inequality, by default
; *tsboolean*, and a governing ttree.
; Here is a trivial example of the problem this code is intended to
; solve.
#
(defstub bar (x) t)
(defaxiom barthm
(implies (and (integerp x)
(< 3 x))
(bar x))
:ruleclasses :typeprescription)
(thm
(implies (and (integerp x)
(< 4 x))
(bar x)))
#
; Robert Krug came up with the original version of this patch when
; playing with arithmetic functions that changed sign at some point
; other than zero. Conceptually, this type of reasoning belongs to
; linear arithmetic rather than typeset, but it provides a modest
; improvement at a very small cost. In a perfect world we might want
; to mix typeset reasoning with the linear arithmetic; the ability to
; call addpoly from within typeset or assumetruefalse could be
; nice (although perhaps too expensive).
(cond ((endp typealist)
(mv *tsboolean* nil))
(t
(let ((typealistentry (car typealist)))
(casematch typealistentry
((typedterm type . ttree)
(mvlet (c leftp x)
; We bind c to nil if we cannot use typealistentry. Otherwise, c is a
; rational that is being compared with < to a term x, and leftp is true if and
; only if c occurs on the left side of the <. We postpone the check that x is
; equal to arg2, which is potentially expensive, until we need to make that
; check (if at all).
(casematch typedterm
(('< ('quote c) x)
(if (rationalp c)
(mv c t x)
(mv nil nil x)))
(('< x ('quote c))
(if (rationalp c)
(mv c nil x)
(mv nil nil nil)))
(& (mv nil nil nil)))
(cond
((null c)
(typeset<1 r arg2 commutedp (cdr typealist)))
(leftp
; So type refers to (c < x).
(cond
((and (<= r c)
(ts= type *tst*)
(equal x arg2))
; (r <= c < arg2) implies (r < arg2), and hence also not (arg2 < r).
(mv (if commutedp *tsnil* *tst*)
(puffert ttree)))
((and (if commutedp (< c r) (<= c r))
(ts= type *tsnil*)
(equal x arg2))
; (arg2 <= c <= r) implies not (r < arg2);
; (arg2 <= c < r) implies (arg2 < r).
(mv (if commutedp *tst* *tsnil*)
(puffert ttree)))
(t
(typeset<1 r arg2 commutedp (cdr typealist)))))
(t ; (not leftp)
; So type refers to (arg2 < c).
(cond
((and (if commutedp (<= r c) (< r c))
(ts= type *tsnil*)
(equal x arg2))
; (r < c <= arg2) implies (r < arg2);
; (r <= c <= arg2) implies not (arg2 < r).
(mv (if commutedp *tsnil* *tst*)
(puffert ttree)))
((and (<= c r)
(ts= type *tst*)
(equal x arg2))
; (arg2 < c <= r) implies not (r < arg2) and also implies (arg2 < r).
(mv (if commutedp *tst* *tsnil*)
(puffert ttree)))
(t
(typeset<1 r arg2 commutedp
(cdr typealist))))))))
(& (typeset<1 r arg2 commutedp (cdr typealist))))))))
;; RAG  I changed complexrational to complex below.
(defun typeset< (arg1 arg2 ts1 ts2 typealist ttree ttree0 potlst pt)
; This function is not cut from the standard mold because instead of
; taking term it takes the two args. This allows us easily to
; implement certain transformations on inequalities: When x is an
; integer,
; (< x 1) is (not (< 0 x)) and
; (< 1 x) is (not (< x 0)).
; Warning: It is important to assumetruefalse that typeset< make
; these transformations. See the comments about typeset< in
; assumetruefalse.
; As of Version_2.6, this function diverged even further from the standard
; mold. We now use the typealist to determine the truth or falsity
; of some simple inequalities which would be missed otherwise.
; See typeset<1 for details.
(let* ((nts1 (numerictypeset ts1))
(nts2 (numerictypeset ts2)))
(cond ((and (equal arg2 *1*)
; Actually we don't have to add 0 back in, as done by numerictypeset, before
; making the following test. But let's keep things simple.
(tssubsetp nts1 *tsinteger*))
(mvlet (ts ttree)
(typeset< *0* arg1 *tszero* ts1
typealist
(puffert ttree)
; Note: Once upon a time in v27, ttree0 was used immediately below
; instead of ttree. Note however that we have depended upon ts1 to
; get here. It might be unsound to do that and then report the
; dependencies of ttree0. However, in v27 this was (probably) sound
; because the ttree0 exits were all reporting *tsboolean* answers.
; But in the new code, below, we use addpolys0 in a way that could
; overwrite ttree with ttree0. Put more intuitively: we think v27
; was sound even with a ttree0 here, but we think v28 would be
; unsound with a ttree0 here because of the addpolys0 below.
ttree
potlst pt)
(typesetnot ts ttree ttree0)))
((and (quotep arg1)
(eql (cadr arg1) 1)
(tssubsetp nts2 *tsinteger*))
(mvlet (ts ttree)
(typeset< arg2 *0* ts2 *tszero*
typealist
(puffert ttree)
; See note above about this ttree versus the old ttree0.
ttree
potlst pt)
(typesetnot ts ttree ttree0)))
; If one of the args is a constant (a quotep) we look in the
; typealist. If we get a useful answer, we are done. Note that if
; we do get a useful answer here, it is sufficient to use ttree0
; rather than ttree since our answer does not depend on the type of
; the args. In particular, typeset<1 returns an accurate answer
; regardless of whether we make the tests above leading to here. See
; the comments following ``The Typesetxxx Functions'' above for an
; explanation of ttree0 vs. ttree.
(t
(mvlet (returnedts returnedttree)
(cond
((and (quotep arg1) (rationalp (cadr arg1)))
(typeset<1 (cadr arg1) arg2 nil typealist))
((and (quotep arg2) (rationalp (cadr arg2)))
(typeset<1 (cadr arg2) arg1 t typealist))
(t
(mv *tsboolean* nil)))
(if (not (ts= returnedts *tsboolean*))
(mv returnedts
(constagtrees returnedttree
ttree0))
; We did not get a useful answer by looking in the typealist. We try
; 'typeset<table if we can.
(let ((tempts
(if (or (tsintersectp ts1
#+:nonstandardanalysis
*tscomplex*
#:nonstandardanalysis
*tscomplexrational*)
(tsintersectp ts2
#+:nonstandardanalysis
*tscomplex*
#:nonstandardanalysis
*tscomplexrational*))
*tsboolean*
(aref2 'typeset<table
*typeset<table* nts1 nts2))))
(cond ((or (ts= tempts *tst*)
(ts= tempts *tsnil*))
(mv tempts (puffert ttree)))
((null potlst)
(mv *tsboolean* ttree0))
; We finally try using linear arithmetic by calling addpolys on, first,
; the negation of the original inequality. If this returns a contradictionp,
; the original inequality must be true. If this does not return a
; contradictionp, we try linear arithmetic with the original inequality.
; These final two tries are new to v28.
(t
; Note: Below there are two calls of basepoly, each of which has the
; ttree ttree0. The argument that we're not dependent on ts1 and ts2
; here is as follows. The setting of tempts, above, which appears to
; rely on ts1 and ts2, is irrelevant here because if we get here,
; tempts is *tsboolean*, which is correct regardless of the ttrees.
; Reader further above, the only uses of ts1 and ts2 are heuristic:
; the methods by which we compute an answer is correct even if the
; preceding tests were not made.
(mvlet (contradictionp newpotlst)
(addpolys0
(list (normalizepoly
(addlinearterms
:lhs arg2
:rhs arg1
(basepoly ttree0
'<=
; The following nil is the rationalpolyp flag and we could supply a
; more accurate value by looking at ts1 and ts2. But then it would
; appear that we were depending on them. Actually, we're not: the
; rationalpolyp flag is irrelevant to addpolys0 and could only come
; into play if the poly here created eventually found its way into a
; nonlinear setting. But that won't happen because the poly is
; thrown away. However, since the flag is indeed irrelevant we just
; supply nil to avoid the appearance of dependence.
nil
nil))))
potlst pt nil 2)
(declare (ignore newpotlst))
(if contradictionp
(mv *tst* (access poly contradictionp :ttree))
(mvlet (contradictionp newpotlst)
(addpolys0
(list (normalizepoly
(addlinearterms
:lhs arg1
:rhs arg2
(basepoly ttree0
'<
nil
nil))))
potlst pt nil 2)
(declare (ignore newpotlst))
(if contradictionp
(mv *tsnil*
(access poly contradictionp :ttree))
(mv *tsboolean* ttree0))))))))))))))
;; RAG  I added entries for real and complex irrationals.
(defun typesetunary (ts ttree ttree0)
(let ((ts1 (numerictypeset ts)))
(cond
((ts= ts1 *tsacl2number*)
(mv *tsacl2number* ttree0))
(t
(mv (tsbuilder ts1
(*tszero* *tszero*)
(*tspositiveinteger* *tsnegativeinteger*)
(*tspositiveratio* *tsnegativeratio*)
#+:nonstandardanalysis
(*tspositivenonratio* *tsnegativenonratio*)
(*tsnegativeinteger* *tspositiveinteger*)
(*tsnegativeratio* *tspositiveratio*)
#+:nonstandardanalysis
(*tsnegativenonratio* *tspositivenonratio*)
(*tscomplexrational* *tscomplexrational*)
#+:nonstandardanalysis
(*tscomplexnonrational* *tscomplexnonrational*))
(puffert ttree))))))
;; RAG  I added entries for real and complex irrationals.
(defun typesetunary/ (ts ttree ttree0)
(let* ((ts1 (numerictypeset ts))
(ans (tsbuilder ts1
(*tszero* *tszero*)
(*tspositiverational* *tspositiverational*)
(*tsnegativerational* *tsnegativerational*)
#+:nonstandardanalysis
(*tspositivenonratio* *tspositivenonratio*)
#+:nonstandardanalysis
(*tsnegativenonratio* *tsnegativenonratio*)
(*tscomplexrational* *tscomplexrational*)
#+:nonstandardanalysis
(*tscomplexnonrational* *tscomplexnonrational*))))
(cond
((ts= ans *tsacl2number*)
(mv *tsacl2number* (puffert ttree0)))
(t
(mv ans (puffert ttree))))))
(defun typesetnumerator (ts ttree ttree0)
(let* ((ts1 (rationaltypeset ts))
(ans (tsbuilder ts1
(*tszero* *tszero*)
(*tspositiverational* *tspositiveinteger*)
(*tsnegativerational* *tsnegativeinteger*))))
(cond ((ts= ans *tsinteger*)
(mv *tsinteger* (puffert ttree0)))
(t (mv ans (puffert ttree))))))
;; RAG  I added an entry for *tscomplexnonrational*. Note that
;; since we don't know whether the type in nonrational because of an
;; irrational real or imaginary part, all we can say is that the
;; result is real, not necessarily irrational.
(defun typesetrealpart (ts ttree ttree0)
(cond #+:nonstandardanalysis
((tsintersectp ts *tscomplexnonrational*)
(mv *tsreal* (puffert ttree0)))
((tsintersectp ts *tscomplexrational*)
(mv *tsrational* (puffert ttree0)))
(t
(mv (numerictypeset ts) (puffert ttree)))))
;; RAG  I added an entry for *tscomplexnonrational*.
(defun typesetimagpart (ts ttree ttree0)
(cond #+:nonstandardanalysis
((tssubsetp ts *tscomplexnonrational*)
(mv (tsunion *tspositivereal*
*tsnegativereal*)
(puffert ttree)))
#+:nonstandardanalysis
((tsintersectp ts *tscomplexnonrational*)
(mv *tsreal* (puffert ttree0)))
((tssubsetp ts *tscomplexrational*)
(mv (tsunion *tspositiverational*
*tsnegativerational*)
(puffert ttree)))
((tsintersectp ts *tscomplexrational*)
(mv *tsrational* (puffert ttree0)))
(t
(mv *tszero* (puffert ttree)))))
;; RAG  I allowed reals as well as rationals below for the type of
;; ts1 and ts2.
(defun typesetcomplex (ts1 ts2 ttree ttree0)
(let ((ts1 #+:nonstandardanalysis
(realtypeset ts1)
#:nonstandardanalysis
(rationaltypeset ts1))
(ts2 #+:nonstandardanalysis
(realtypeset ts2)
#:nonstandardanalysis
(rationaltypeset ts2)))
(cond ((ts= ts2 *tszero*)
(mv ts1 (puffert ttree)))
((ts= (tsintersection ts2 *tszero*)
*tsempty*)
#+:nonstandardanalysis
(cond ((and (tssubsetp ts1 *tsrational*)
(tssubsetp ts2 *tsrational*))
(mv *tscomplexrational* (puffert ttree)))
((or (tssubsetp ts1 *tsnonratio*)
(tssubsetp ts2 *tsnonratio*))
(mv *tscomplexnonrational* (puffert ttree)))
(t (mv *tscomplex* (puffert ttree))))
#:nonstandardanalysis
(mv *tscomplexrational* (puffert ttree)))
#+:nonstandardanalysis
((ts= ts1 *tsreal*)
(mv *tsacl2number* (puffert ttree0)))
#:nonstandardanalysis
((ts= ts1 *tsrational*)
(mv *tsacl2number* (puffert ttree0)))
(t
(mv (tsunion ts1
#+:nonstandardanalysis
(cond ((and (tssubsetp ts1 *tsrational*)
(tssubsetp ts2 *tsrational*))
*tscomplexrational*)
(t *tscomplex*))
#:nonstandardanalysis
*tscomplexrational*)
(puffert ttree))))))
;; RAG  I added this function to account for the new builtin floor1.
#+:nonstandardanalysis
(defun typesetfloor1 (ts ttree ttree0)
(let* ((ts1 (realtypeset ts))
(ans (tsbuilder ts1
(*tszero* *tszero*)
(*tspositiveinteger* *tspositiveinteger*)
(*tspositiveratio* *tsnonnegativeinteger*)
(*tspositivenonratio* *tsnonnegativeinteger*)
(*tsnegativereal* *tsnegativeinteger*))))
(cond ((ts= ans *tsinteger*)
(mv *tsinteger* (puffert ttree0)))
(t (mv ans (puffert ttree))))))
;; RAG  I added this function to account for the new builtin standardpart.
#+:nonstandardanalysis
(defun typesetstandardpart (ts ttree ttree0)
(let* ((ts1 (numerictypeset ts))
(ans (tsbuilder ts1
(*tszero* *tszero*)
(*tspositivereal* *tsnonnegativereal*)
(*tsnegativereal* *tsnonpositivereal*)
(*tscomplex* *tsacl2number*))))
(cond ((ts= ans *tsacl2number*)
(mv *tsacl2number* (puffert ttree0)))
(t (mv ans (puffert ttree))))))
;; RAG  I added this function to account for the new builtin standardnumberp.
#+:nonstandardanalysis
(defun typesetstandardnumberp (ts ttree ttree0)
(cond ((ts= ts *tszero*)
(mv *tst* (puffert ttree)))
((tssubsetp ts (tscomplement *tsacl2number*))
(mv *tsnil* (puffert ttree)))
(t (mv *tsboolean* (puffert ttree0)))))
; Essay on the RecognizerAlist and RecognizerTuples
; The "recognizer alist" of ACL2 is a combination of Nqthm's
; RECOGNIZERALIST and its two COMPOUNDRECOGNIZERALISTs. The
; recognizeralist is stored as a global variable in the world w and
; accessed via
; (globalval 'recognizeralist w).
; The recognizer alist contains records of the following form:
(defrec recognizertuple
(fn (nume . truets)
(falsets . strongp)
. rune)
t)
; The initial value of the recognizer alist is shown after we discuss the
; meaning of these records.
; In a recognizertuple, fn is the name of some Booleanvalued
; function of one argument. Truets and and falsets are type sets.
; If such a record is on the recognizeralist then it is the case that
; (fn x) implies that the type set of x is a subset of truets and
; (not (fn x)) implies that the type set of x is a subset of falsets.
; Furthermore, if strongp is t, then truets is the complement of
; falsets; i.e., (fn x) recognizes exactly the subset identified by
; truets. Rune is either a rune or
; *fakeruneforanonymousenabledrule*. Nume is the nume of rune
; (possibly nil).
; For example, if we prove that
; (BOOLEANP X) > (OR (EQUAL X T) (EQUAL X NIL))
; then we can add the following tuple
; (make recognizertuple
; :fn BOOLEANP
; :truets *tsboolean*
; :falsets *tsunknown*
; :strongp nil
; :nume nil
; :rune *fakeruneforanonymousenabledrule*)
; to the list. Observe that the falsets for this pair does not tell us
; much. But if we proved the above AND
; (NOT (BOOLEANP X)) > (NOT (OR (EQUAL X T) (EQUAL X NIL)))
; we could add the tuple:
; (make recognizertuple
; :fn BOOLEANP
; :truets *tsboolean*
; :falsets (tscomplement *tsboolean*)
; :strongp t)
; And we would know as much about BOOLEANP as we know about integerp.
; Consider the function PRIMEP. It implies its argument is a positive
; integer. Its negation tells us nothing about the type of its argument.
; (make recognizertuple
; :fn PRIMEP
; :truets *tspositiveinteger*
; :falsets *tsunknown*
; :strongp nil)
; Suppose now x is a term whose type set we know. What is the type
; set of (PRIMEP x)? If the type set for x includes the positive
; integer bit, the type set for (PRIMEP x) may include *tst* so we
; will throw that in. If the type set for x includes any of
; *tsunknown*'s bits (of course it does) we will throw in *tsnil*.
; The interesting thing about this is that if the type set of x does
; not include the positive integers, we'll know (PRIME x) is nil.
; If we assume (PRIME x) true, we will restrict the type of x to the
; positive integers. If we assume (PRIME x) false, we won't restrict
; x at all.
; Consider the function RATTREEP that recognizes constrees of
; rational numbers. We can prove that (RATTREEP x) implies the type
; set of x is in *tscons* union *tsrational*. We can prove that
; (NOT (RATTREEP x)) implies that the type set of x is not
; *tsrational*. That means the falsets for RATTREEP is the
; complement of the rationals. If we were asked to get the type set
; of (RATTREEP x) where x is rational, we'd throw in a *tst* because
; the type of x intersects the truets and we'd not throw in anythine
; else (because the type of x does not interesect the false ts). If
; we were asked to assume (RATTREEP x) then on the true branch x's
; type would be interesected with the conses and the rationals. On
; the false branch, the rationals would be deleted.
; Historical Note: In an earlier version of this code we did not allow
; compound recognizer rules to be enabled or disabled and hence did
; not store the runes and numes. We were much cleverer then
; about allowing newly proved rules to strengthen existing recognizer
; tuples. That is, you could prove a rule about the truets and then
; a second about the falsets, and then perhaps a third tightening up
; the truets fact a little, etc. This had the problem that it was
; not possible to identify a single rule name with the known facts
; about the type of fn. Thus, when we decided to track use of all
; rules it was impossible to give a sensible meaning to disabled
; compound recognizer rules in some cases. (E.g., the fact stored
; might be derived from both enabled and disabled rules.) So an
; important aspect of the new design is that there is a 1:1
; correspondence between what we know and the rule that told us. If
; you have proved a sequence of three rules about fn we will use the
; most recently proved, stillenabled one. If you disable that one,
; we'll naturally fall back on the next most recently stillenabled
; one.
;; RAG  I added recognizers for realp and complexp.
(defconst *initialrecognizeralist*
(list (make recognizertuple
:fn 'integerp
:truets *tsinteger*
:falsets (tscomplement *tsinteger*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'rationalp
:truets *tsrational*
:falsets (tscomplement *tsrational*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
#+:nonstandardanalysis
(make recognizertuple
:fn 'realp
:truets *tsreal*
:falsets (tscomplement *tsreal*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'complexrationalp
:truets *tscomplexrational*
:falsets (tscomplement *tscomplexrational*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
#+:nonstandardanalysis
(make recognizertuple
:fn 'complexp
:truets *tscomplex*
:falsets (tscomplement *tscomplex*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'acl2numberp
:truets *tsacl2number*
:falsets (tscomplement *tsacl2number*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'consp
:truets *tscons*
:falsets (tscomplement *tscons*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'atom
:truets (tscomplement *tscons*)
:falsets *tscons*
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'listp
:truets (tsunion *tscons* *tsnil*)
:falsets (tscomplement (tsunion *tscons* *tsnil*))
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'truelistp
:truets *tstruelist*
:falsets (tscomplement *tstruelist*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'characterp
:truets *tscharacter*
:falsets (tscomplement *tscharacter*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'stringp
:truets *tsstring*
:falsets (tscomplement *tsstring*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'null
:truets *tsnil*
:falsets (tscomplement *tsnil*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)
(make recognizertuple
:fn 'symbolp
:truets *tssymbol*
:falsets (tscomplement *tssymbol*)
:strongp t
:nume nil
:rune *fakeruneforanonymousenabledrule*)))
(defun mostrecentenabledrecogtuple (fn alist ens)
; This function finds the first recognizertuple on alist whose :fn is
; fn and whose :nume is enablednumep. Thus, primitive recognizer
; tuples, like that for rationalp, are always "enabled."
(cond ((null alist) nil)
((and (eq fn (access recognizertuple (car alist) :fn))
(enablednumep (access recognizertuple (car alist) :nume) ens))
(car alist))
(t (mostrecentenabledrecogtuple fn (cdr alist) ens))))
(defun typesetrecognizer (recogtuple argts ttree ttree0)
; Recogtuple is a recognizertuple. Then we know that (fn x) implies
; that the type set of x, argts, is a subset of truets.
; Furthermore, we know that ~(fn x) implies that argts is a subset of
; falsets. In addition, we know that fn is a Boolean valued fn.
; This function is supposed to determine the type set of (fn x) where
; argts is the type set of x. Observe that if argts intersects with
; truets then (fn x) might be true, so we should throw in *tst*.
; Conversely, if argts does not intersect with truets then (fn x)
; cannot possibly be true. Exactly analogous statements can be made
; about falsets.
; We return two results, the type set of (fn x) and an extension of
; ttree (or ttree0) obtained by adding the named rule, tagged 'lemma. We
; initially considered adding the rule name to the tree only if the
; typeset returned was stronger than just Boolean. But it could be
; that this rule is the rule that established that fn was Boolean and
; so we can't be sure that even that weak response isn't an
; interesting use of this rule.
(let ((ts (tsbuilder
argts
((access recognizertuple recogtuple :truets) *tst*)
((access recognizertuple recogtuple :falsets) *tsnil*))))
(cond
((ts= ts *tsboolean*)
(mv *tsboolean*
(pushlemma (access recognizertuple recogtuple :rune) ttree0)))
(t (mv ts
(pushlemma (access recognizertuple recogtuple :rune) ttree))))))
(defun typesetcar (ts ttree ttree0)
(cond ((tsintersectp ts *tscons*) (mv *tsunknown* ttree0))
(t (mv *tsnil* ttree))))
(defun typesetcdr (ts ttree ttree0)
(let ((cdrts
(tsbuilder ts
(*tspropercons* *tstruelist*)
(*tsimpropercons* (tscomplement *tstruelist*))
(otherwise *tsnil*))))
(mv cdrts
(if (ts= cdrts *tsunknown*)
ttree0
(puffert ttree)))))
(defun typesetcoerce (term ts1 ts2 ttree1 ttree2 ttree0)
(cond ((equal (fargn term 2) ''list)
; If the first argument is of type *tsstring* then the result could
; be either nil or a proper cons. But if the first argument isn't
; possibly a string, the result is NIL.
(cond ((tsintersectp *tsstring* ts1)
; We are not really using ts1 here because (coerce x 'list) is always
; a true list. So we report ttree0, not ttree1.
(mv *tstruelist* (puffert ttree0)))
(t (mv *tsnil* (puffert ttree1)))))
((quotep (fargn term 2))
(mv *tsstring* (puffert ttree0)))
((not (tsintersectp *tsnontnonnilsymbol* ts2))
; Observe that the first argument (and its ttree1) don't matter here.
(mv *tsstring* (puffert ttree2)))
(t (mv (tsunion *tstruelist* *tsstring*) (puffert ttree0)))))
(defun typesetinterninpackageofsymbol (ts1 ts2 ttree1 ttree2 ttree0)
(cond ((not (tsintersectp ts1 *tsstring*))
(mv *tsnil* (puffert ttree1)))
((not (tsintersectp ts2 *tssymbol*))
(mv *tsnil* (puffert ttree2)))
(t (mv *tssymbol* (puffert ttree0)))))
(defun typesetlength (ts ttree ttree0)
(let ((ans (tsbuilder ts
(*tsstring* *tsnonnegativeinteger*)
(*tscons* *tspositiveinteger*)
(otherwise *tszero*))))
(cond
((ts= ans *tsinteger*)
(mv *tsinteger* (puffert ttree0)))
(t
(mv ans (puffert ttree))))))
(defun typesetcons (ts2 ttree ttree0)
; Ts2 is the type set of the second argument of the cons.
(let ((ts (tsbuilder ts2
(*tstruelist* *tspropercons*)
(otherwise *tsimpropercons*))))
(cond ((ts= ts *tscons*)
(mv ts (puffert ttree0)))
(t (mv ts (puffert ttree))))))
(defconst *singletontypesets*
(list *tst* *tsnil* *tszero*))
(defun typesetequal (ts1 ts2 ttree ttree0)
(cond ((member ts1 *singletontypesets*)
(cond ((ts= ts1 ts2) (mv *tst* (puffert ttree)))
((tsintersectp ts1 ts2)
(mv *tsboolean* (puffert ttree0)))
(t (mv *tsnil* (puffert ttree)))))
((tsintersectp ts1 ts2)
(mv *tsboolean* (puffert ttree0)))
(t (mv *tsnil* (puffert ttree)))))
;; RAG  I added entries here for realp evg. This is probably not
;; needed, since we can't construct realp numbers!
(defun typesetquote (evg)
; Most typesetxxx functions return a pair consisting of a ts and a ttree.
; But the ttree is irrelevant here and so we don't waste the time passing
; it around. We return the ts of the evg.
(cond ((atom evg)
(cond ((rationalp evg)
(cond ((integerp evg)
(cond ((int= evg 0) *tszero*)
((> evg 0) *tspositiveinteger*)
(t *tsnegativeinteger*)))
((> evg 0) *tspositiveratio*)
(t *tsnegativeratio*)))
#+:nonstandardanalysis
((realp evg)
(cond ((> evg 0) *tspositivenonratio*)
(t *tsnegativenonratio*)))
((complexrationalp evg)
*tscomplexrational*)
#+:nonstandardanalysis
((complexp evg)
*tscomplexnonrational*)
((symbolp evg)
(cond ((eq evg t) *tst*)
((eq evg nil) *tsnil*)
(t *tsnontnonnilsymbol*)))
((stringp evg) *tsstring*)
(t *tscharacter*)))
((truelistp evg)
*tspropercons*)
(t *tsimpropercons*)))
(defun typesetcharcode (ts ttree ttree0)
; (charcode x) is always a nonnegative integer. If x is not a
; characterp, then its code is 0. If x is a character, its code
; might be 0 or positive.
(cond ((not (tsintersectp ts *tscharacter*))
(mv *tszero* (puffert ttree)))
(t (mv *tsnonnegativeinteger* (puffert ttree0)))))
(mutualrecursion
(defun varfncount (term)
; We return a triple  the variable count, the function count,
; and the pseudofunction count  derived from term.
; The fn count of a term is the number of function symbols in the
; unabbreviated term. Thus, the fn count of (+ (f x) y) is 2.
; The primitives of ACL2, however, do not give very natural expression
; of the constants of the logic in pure first order form, i.e., as a
; variablefree nest of function applications. What, for
; example, is 2? It can be written (+ 1 (+ 1 0)), where 1 and 0 are
; considered primitive constants, i.e., 1 is (one) and 0 is (zero).
; That would make the fn count of 2 be 5. However, one cannot even
; write a pure first order term for NIL or any other symbol or string
; unless one adopts NIL and 'STRING as primitives too. It is probably
; fair to say that the primitives of CLTL were not designed for the
; inductive construction of the objects in an orderly way. But we would
; like for our accounting for a constant to somehow reflect the structure
; of the constant rather than the structure of the rather arbitrary CLTL
; term for constructing it. 'A seems to have relatively little to do
; with (intern (coerce (cons #\A 'NIL) 'STRING)) and it is odd that
; the fn count of 'A should be larger than that of 'STRING, and odder
; still that the fn count of "STRING" be larger than that of 'STRING
; since the latter is built from the former with intern.
; We therefore adopt a story for how the constants of ACL2 are
; actually constructed inductively and the pseudofn count is the number
; of symbols in that construction. The story is as follows. (z), zero,
; is the only primitive integer. Positive integers are constructed
; from it by the successor function s. Negative integers are
; constructed from positive integers by unary minus. Ratios are
; constructed by the dyadic function quo on an integer and a natural.
; For example, 2/3 is inductively built as (quo ( (s(s(z))))
; (s(s(s(z))))). Complex rationals are similarly constructed from
; pairs of rationals. All characters are primitive and are constructed by
; the function of the same name. Strings are built from the empty
; string, (o), by "stringcons", cs, which adds a character to a
; string. Thus "AB" is formally (cs (#\A) (cs (#\B) (o))). Symbols
; are constructed by "packing" a string with p. Conses are conses, as
; usual. Again, this story is nowhere else relevant to ACL2; it just
; provides a consistent model for answering the question "how big is a
; constant?"
; Previously we had made no distinction between the fncount and the
; pseudofncount, but Jun Sawada ran into difficulty because
; (termorder (f) '2). Note also that before we had
; (termorder (a (b (c (d (e (f (g (h (i x))))))))) (foo y '2/3))
; but
; (termorder (foo y '1/2) (a (b (c (d (e (f (g (h (i x)))))))))).
(declare (xargs :guard (pseudotermp term)))
(cond ((variablep term)
(mv 1 0 0))
((fquotep term)
(mv 0
0
(fncountevg (cadr term))))
(t (mvlet (v f pf)
(varfncountlst (fargs term))
(mv v (+ 1 f) pf)))))
(defun varfncountlst (lst)
(declare (xargs :guard (pseudotermlistp lst)))
(cond ((null lst)
(mv 0 0 0))
(t (mvlet (v1 f1 pf1)
(varfncount (car lst))
(mvlet (v2 f2 pf2)
(varfncountlst (cdr lst))
(mv (+ v1 v2) (+ f1 f2) (+ pf1 pf2)))))))
)
(defun fncount1 (flg x fncountacc pfncountacc)
; Keep this in sync with the varfncount/varfncountlst nest.
; This definition is derived from the varfncount nest, except that it counts
; only fns and pseudofns, not vars, and it uses tail recursion. It was
; introduced when a check of fncounts was added to ancestorscheck1, in order
; to improve efficiency a bit. A 2.6% decrease in user time (using Allegro
; 5.0.1) was observed when that check was added, yet that test was found to be
; critical in certain cases (see the comment in ancestorscheck1). So, here we
; attempt to improve the efficiency of computing the fncount.
; We discovered that the Allegro compiler does not do as good a job at tail
; recursion elimination for mutual recursion nests as for single recursion. So
; we code this as a singly recursive function with a flag, flg: When flg is
; nil then x is a term, and otherwise x is a list of terms.
(declare (xargs :guard (and (if flg
(pseudotermlistp x)
(pseudotermp x))
(integerp fncountacc)
(integerp pfncountacc))))
(cond (flg
(cond ((null x)
(mv fncountacc pfncountacc))
(t
(mvlet (fncnt pfncnt)
(fncount1 nil (car x) fncountacc pfncountacc)
(fncount1 t (cdr x) fncnt pfncnt)))))
((variablep x)
(mv fncountacc pfncountacc))
((fquotep x)
(mv fncountacc
(+ pfncountacc (fncountevg (cadr x)))))
(t (fncount1 t (fargs x) (1+ fncountacc) pfncountacc))))
(defmacro fncount (term)
`(fncount1 nil ,term 0 0))
(defun termorder (term1 term2)
; A simple  or complete or total  ordering is a relation satisfying:
; "antisymmetric" XrY & YrX > X=Y, "transitive" XrY & Y&Z > XrZ, and
; "trichotomy" XrY v YrX. A partial order weakens trichotomy to "reflexive"
; XrX.
; Termorder is a simple ordering on terms. (termorder term1 term2) if and
; only if (a) the number of occurrences of variables in term1 is strictly
; less than the number in term2, or (b) the numbers of variable occurrences
; are equal and the fncount of term1 is strictly less than that of term2,
; or (c) the numbers of variable occurrences are equal, the fncounts are
; equal, and the pseudofncount of term1 is strictly less than that of
; term2, or (d) the numbers of variable occurrences are equal, the fncounts
; are equal, the pseudofncounts are equal, and (lexorder term1 term2).
; Let (STRICTTERMORDER X Y) be the LISP function defined as (AND
; (TERMORDER X Y) (NOT (EQUAL X Y))). For a fixed, finite set of function
; symbols and variable symbols STRICTTERMORDER is well founded, as can be
; proved with the following lemma.
; Lemma. Suppose that M is a function whose range is well ordered
; by r and such that the inverse image of any member of the range is
; finite. Suppose that L is a total order. Define (LESSP x y) =
; (OR (r (M x) (M y)) (AND (EQUAL (M x) (M y)) (L x y) (NOT (EQUAL x
; y)))). < is a wellordering. Proof. Suppose ... < t3 < t2 < t1
; is an infinite descending sequence. ..., (M t3), (M t2), (M t1) is
; weakly descending but not infinitely descending and so has a least
; element. WLOG assume ... = (M t3) = (M t2) = (M t1). By the
; finiteness of the inverse image of (M t1), { ..., t3, t2, t1} is a
; finite set, which has a least element under L, WLOG t27. But t28
; L t27 and t28 /= t27 by t28 < t27, contradicting the minimality of
; t27. QED
; If (TERMORDER x y) and t2 results from replacing one occurrence of
; y with x in t1, then (TERMORDER t2 t1). Cases on why x is less
; than y. 1. If the number of occurrences of variables in x is
; strictly smaller than in y, then the number in t2 is strictly
; smaller than in t1. 2. If the number of occurrences of variables in
; x is equal to the number in y but the fncount of x is smaller than
; the fncount of y, then the number of variable occurrences in t1 is
; equal to the number in t2 but the fncount of t1 is less than the
; fncount of t2. 3. A similar argument to the above applies if the
; number of variable occurrences and fncounts are the same but the
; pseudofncount of x is smaller than that of y. 4. If the number of
; variable occurrences and parenthesis occurrences in x and y are the
; same, then (LEXORDER x y). (TERMORDER t2 t1) reduces to (LEXORDER
; t2 t1) because the number of variable and parenthesis occurrences in
; t2 and t1 are the same. The lexicographic scan of t1 and t2 will be
; all equals until x and y are hit.
":DocSection Miscellaneous
the ordering relation on terms used by ACL2~/
ACL2 must occasionally choose which of two terms is syntactically
smaller. The need for such a choice arises, for example, when using
equality hypotheses in conjectures (the smaller term is substituted
for the larger elsewhere in the formula), in stopping loops in
permutative rewrite rules (~pl[loopstopper]), and in choosing
the order in which to try to cancel the addends in linear arithmetic
inequalities. When this notion of syntactic size is needed, ACL2
uses ``term order.'' Popularly speaking, term order is just a
lexicographic ordering on terms. But the situation is actually more
complicated.~/
We define term order only with respect to terms in translated form.
~l[trans]. Constants are viewed as built up by ~em[pseudofunction]
applications, as described at the end of this documentation.
~c[Term1] comes before ~c[term2] in the term order iff~bq[]
(a) the number of variable occurrences in ~c[term1] is less than that in
~c[term2], or
(b) the numbers of variable occurrences in the two terms are equal
but the number of function applications in ~c[term1] is less than that
in ~c[term2], or
(c) the numbers of variable occurrences in the two terms are equal,
the numbers of functions applications in the two terms are equal,
but the number of pseudofunction applications in ~c[term1] is less
than that in ~c[term2], or
(d) the numbers of variable occurrences in the two terms are equal,
the numbers of functions applications in the two terms are equal,
the numbers of pseudofunction applications in the two terms are equal,
and ~c[term1] comes before ~c[term2] in a lexicographic ordering, ~ilc[lexorder],
based their structure as Lisp objects: ~pl[lexorder].
~eq[]The function ~c[termorder], when applied to the translations of two
ACL2 terms, returns ~c[t] iff the first is ``less than or equal'' to the
second in the term order.
By ``number of variable occurrences'' we do not mean ``number of
distinct variables'' but ``number of times a variable symbol is
mentioned.'' ~c[(cons x x)] has two variable occurrences, not one.
Thus, perhaps counterintuitively, a large term that contains only
one variable occurrence, e.g., ~c[(standardcharp (car (reverse x)))]
comes before ~c[(cons x x)] in the term order.
Since constants contain no variable occurrences and nonconstant
expressions must contain at least one variable occurrence, constants
come before nonconstants in the term order, no matter how large the
constants. For example, the list constant
~bv[]
'(monday tuesday wednesday thursday friday)
~ev[]
comes before ~c[x] in the term order. Because term order is involved
in the control of permutative rewrite rules and used to shift
smaller terms to the left, a set of permutative rules designed to
allow the permutation of any two tips in a tree representing the
nested application of some function will always move the constants
into the leftmost tips. Thus,
~bv[]
(+ x 3 (car (reverse klst)) (dx i j)) ,
~ev[]
which in translated form is
~bv[]
(binary+ x
(binary+ '3
(binary+ (dx i j)
(car (reverse klst))))),
~ev[]
will be permuted under the builtin commutativity rules to
~bv[]
(binary+ '3
(binary+ x
(binary+ (car (reverse klst))
(dx i j))))
~ev[]
or
~bv[]
(+ 3 x (car (reverse klst)) (dx i j)).
~ev[]
Two terms with the same numbers of variable occurrences, function
applications, and pseudofunction applications are ordered by
lexicographic means, based on their structures. ~l[lexorder].
Thus, if two terms ~c[(member ...)] and ~c[(reverse ...)] contain the same
numbers of variable occurrences and function applications, then the
~ilc[member] term is first in the term order because ~ilc[member] comes before
~ilc[reverse] in the term order (which is here reduced to alphabetic
ordering).
It remains to discuss the notion of ~em[pseudofunction] applications.
Clearly, two constants are ordered using cases (c) and (d) of term
order, since they each contain 0 variable occurrences and no
function calls. This raises the question ``How many function
applications are in a constant?'' Because we regard the number of
function applications as a more fundamental measure of the size of a
constant than lexicographic considerations, we decided that for the
purposes of term order, constants would be seen as being built by
primitive constructor functions. These constructor functions are
not actually defined in ACL2 but merely imagined for the purposes of
term order. We here use suggestive names for these imagined
functions, ignoring entirely the prior use of these names within
ACL2. The imagined applications of these functions are what we
refer to as ~em[pseudofunction] applications.
The constant function ~c[z] constructs ~c[0]. Positive integers are
constructed from ~c[(z)] by the successor function, ~c[s]. Thus ~c[2] is
~c[(s (s (z)))] and contains three function applications. ~c[100]
contains one hundred and one applications. Negative integers are
constructed from their positive counterparts by ~ilc[]. Thus, ~c[2]
is ~c[( (s (s (z))))] and has four applications. Ratios are
constructed by the dyadic function ~ilc[/]. Thus, ~c[1/2] is
~bv[]
(/ ( (s (z))) (s (s (z))))
~ev[]
and contains seven applications. Complex rationals are similarly
constructed from rationals. All character objects are considered
primitive and are constructed by constant functions of the same
name. Thus ~c[#\\a] and ~c[#\\b] both contain one application.
Strings are built from the empty string, ~c[(o)] by the
``stringcons'' function written ~c[cs]. Thus ~c[\"AB\"] is
~c[(cs (#\\a) (cs (#\\b) (o)))] and contains five applications.
Symbols are obtained from strings by ``packing'' the ~ilc[symbolname]
with the unary function ~c[p]. Thus ~c['ab] is
~bv[]
(p (cs (#\\a) (cs (#\\b) (o))))
~ev[]
and has six applications. Note that packages are here ignored and
thus ~c['acl2::ab] and ~c['mypackage::ab] each contain just six
applications. Finally, ~il[cons]es are built with ~ilc[cons], as usual.
So ~c['(1 . 2)] is ~c[(cons '1 '2)] and contains six applications,
since ~c['1] contains two and ~c['2] contains three. This, for better
or worse, answers the question ``How many function applications are
in a constant?''"
(mvlet (varcount1 fncount1 pfncount1)
(varfncount term1)
(mvlet (varcount2 fncount2 pfncount2)
(varfncount term2)
(cond ((< varcount1 varcount2) t)
((> varcount1 varcount2) nil)
((< fncount1 fncount2) t)
((> fncount1 fncount2) nil)
((< pfncount1 pfncount2) t)
((> pfncount1 pfncount2) nil)
(t (lexorder term1 term2))))))
; Type Prescriptions
; A typeprescription is a structure, below, that describes how to
; compute the type of a term. They are stored on the property list of
; the top function symbol of the term, under the property
; 'typeprescriptions. Unlike Nqthm's "typeprescriptionlst" ANY
; enabled typeprescription in 'typeprescriptions may contribute to
; the typeset of the associated function symbol.
(defrec typeprescription
(basicts (nume . term)
hyps
(vars . rune)
. corollary)
t)
; Term is a term, hyps is a list of terms, basicts is a typeset, and vars is
; a list of variables that occur in term. Let term' be some instance of term
; under the substitution sigma. Then, provided the sigma instance of hyps is
; true, the typeset of term' is the union of basicts with the typesets of
; the sigma images of the vars. Corollary is the theorem (translated term)
; from which this typeprescription was derived. For systemgenerated
; typeprescriptions it is a term created by converttypeprescriptiontoterm.
; (Note: Why do we store the corollary when we could apparently
; recompute it with converttypeprescriptiontoterm? The reason is
; that the computation is sensitive to the ens in use and we do not
; wish the corollary for a typeprescription rule to change as the
; user changes the global enabled structure.)
; For example, for APP we might have the typeprescription:
; (make typeprescription :rune ... :nume ...
; :term (app x y)
; :hyps ((truelistp x))
; :basicts *tscons*
; :vars '(y)
; :corollary (implies (truelistp x)
; (if (consp (app x y))
; 't
; (equal (app x y) y))))
; The above example corresponds to what we'd get from the lemma:
; (implies (truelistp x)
; (or (consp (app x y))
; (equal (app x y) y)))
; When typeset uses :TYPEPRESCRIPTION rules it will intersect all
; the known typesets for term.
(defun findrunedtypeprescription (rune lst)
; Lst must be a list of typeprescription rules. We find the first
; one with :rune rune.
(cond ((null lst) nil)
((equal rune
(access typeprescription (car lst) :rune))
(car lst))
(t (findrunedtypeprescription rune (cdr lst)))))
(defconst *expandablebootstrapnonrecfns*
'(not
implies eq atom eql = /= null endp zerop
; If we ever make 1+ and 1 functions again, they should go back on this list.
synp plusp minusp listp prog2$ mustbeequal time$ withprovertimelimit
force casesplit doublerewrite))
; Warning: All functions listed above must be defun'd nonrecursively
; in axioms.lisp!
; There has been some thought about whether we should put IFF on this
; list. We have decided not, because typeset knows a lot about it by
; virtue of its being an equivalence relation. But this position has
; never been seriously scrutinized.
; In a break with nqthm, we have decided to let typeset expand some
; function applications to get better typesets for them. The
; functions in question are those listed above.
; In an even more pervasive break, we have decided to make typeset
; keep track of the dependencies between literals of the goal clause
; and the typesets computed. The ttree argument to typeset below is
; a running accumulator that is returned as the second value of
; typeset. Among the tags in the ttree are 'pt tags. The value of
; the tag is a "parent tree" indicating the set of literals of the
; currentclause upon which the type deduction depends. See the Essay
; on Parent Trees. The typealist in general contains entries of the
; form (term ts . ttree), where ttree is the tag tree encoding all of
; the 'PTs upon which depend the assertion that term has typeset ts.
; Note on Performance:
; An early time trial detected no measurable difference between the
; old typeset and the new when the ttree is t. This was on a
; collection of simple defuns and thms (flatten, mcflatten, their
; relation, and a guarded defun of (assoceq2 x y alist) where alist
; is a true list of triples of the form (sym1 sym2 . val)) that
; required a total of 15 seconds runtime in both versions. However,
; because the only available "old" ACL2 is the first release, which
; does not have all of the proof techniques in place, and the new
; system does have them in place, it is difficult to make meaningful
; tests. To make matters worse, we are about to go implement forward
; chaining. The bottom line is whether ACL2 is fast enough. We'll
; see...
; We now continue with the development of typeset.
(defun mvatf (notflg mbt mbf tta fta ttree1 ttree2)
; Every exit of assumetruefalse is via this function. See assume
; truefalse for details. It is convenient, and only mildly wrong, to
; think of this function as equivalent to:
; (mv mbt mbf tta fta (constagtrees ttree1 ttree2)).
; This is incorrect on two counts. First, if notflg is true, we swap
; the roles of mbt/mbf and tta/fta. Second, since the ttree result of
; assumetruefalse is irrelevant unless mbt or mbf is t, we sometimes
; produce a nil ttree.
; The reason this function takes two ttrees is that many (but not all)
; paths through assumetruefalse have two ttrees in hand at the end.
; One is the ``xttree'' arg of assumetruefalse, which was to be
; included in all the ttrees generated by the function. The other is
; some local ttree that describes the derivation of facts during
; assumetruefalse. We could combine these two trees before calling
; mvatf but that would, possibly, waste a cons since the ttrees are
; sometimes ignored.
; Finally, because we know that the ttrees are ignored when mbt and
; mbf are both nil, we sometimes pass in nil for the two ttrees in
; calls of mvatf where we know they will be ignored. Such a call
; should be taken (by the reader) as a clear signal that the ttrees
; are irrelevant.
(if notflg
(mv mbf mbt fta tta
(if (or mbt mbf)
(constagtrees ttree1 ttree2)
nil))
(mv mbt mbf tta fta
(if (or mbt mbf)
(constagtrees ttree1 ttree2)
nil))))
(defun assumetruefalseerror (typealist x temptemp)
(er
hard 'assumetruefalseerror
"It was thought impossible for an equivalence relation, e.g., ~x0, ~
to have anything besides a nonempty proper subset of ~
*tsboolean* on the typealist! But in the typealist ~x1 the ~
term ~x2 has type set ~x3."
(ffnsymb x) typealist x temptemp))
(defun nonconscdr (term)
(cond ((variablep term) term)
((fquotep term) term)
((eq (ffnsymb term) 'cons)
(nonconscdr (fargn term 2)))
(t term)))
; Because typeset now uses typeprescription rules with general
; patterns in them (rather than Nqthmstyle rules for function
; symbols), we need oneway unification or pattern matching.
; Onewayunify1 can "see" (binary+ 1 x) in 7, by letting x be 6. Thus, we
; say that binary+ is an "implicit" symbol to onewayunify1. Here is the
; current list of implicit symbols. This list is used for heuristic reasons.
; Basically, a quick necessary condition for pat to onewayunify with term is
; for the function symbols of pat (except for the implicit ones) to be a subset
; of the function smbols of term.
(defconst *onewayunify1implicitfns*
'(binary+
binary*
unary
unary/
interninpackageofsymbol
coerce
cons))
(mutualrecursion
(defun onewayunify1 (pat term alist)
; This function is a "NoChange Loser" meaning that if it fails and returns nil
; as its first result, it returns the unmodified alist as its second.
(declare (xargs :guard (and (pseudotermp pat)
(pseudotermp term)
(alistp alist))))
(cond ((variablep pat)
(let ((pair (assoceq pat alist)))
(cond (pair (cond ((equal (cdr pair) term)
(mv t alist))
(t (mv nil alist))))
(t (mv t (cons (cons pat term) alist))))))
((fquotep pat)
(cond ((equal pat term) (mv t alist))
(t (mv nil alist))))
((variablep term) (mv nil alist))
((fquotep term)
; Caution: If you change the code below, update *onewayunify1implicitfns*.
; We have historically attempted to unify ``constructor'' terms with explicit
; values, and we try to simulate that here, treating the primitive arithmetic
; operators, interninpackageofsymbol, coerce (to a very limited extent),
; and, of course, cons, as constructors.
; In order to prevent loops, we insist that onewayunification does not
; present the rewriter with evermorecomplex goals. Robert Krug has sent the
; following examples, which motivated the controls in the code for binary+ and
; binary* below.
#
(defstub foo (x) t)
(defaxiom fooaxiom
(equal (foo (* 2 x))
(foo x)))
(thm
(foo 4))
:u
(defaxiom fooaxiom
(equal (foo (+ 1 x))
(foo x)))
(thm
(foo 4))
#
; Another interesting example is (thm (foo 4)) after replacing the second
; fooaxiom with (equal (foo (+ 1 x)) (foo x)).
(cond ((acl2numberp (cadr term))
(let ((ffnsymb (ffnsymb pat)))
(case ffnsymb
(binary+
(cond ((quotep (fargn pat 1))
(let ((newevg
( (cadr term)
(fix (cadr (fargn pat 1))))))
(cond
((<= (acl2count newevg)
(acl2count (cadr term)))
(onewayunify1
(fargn pat 2)
(kwote newevg)
alist))
(t (mv nil alist)))))
((quotep (fargn pat 2))
(let ((newevg
( (cadr term)
(fix (cadr (fargn pat 2))))))
(cond ((<= (acl2count newevg)
(acl2count (cadr term)))
(onewayunify1
(fargn pat 1)
(kwote newevg)
alist))
(t (mv nil alist)))))
(t (mv nil alist))))
(binary*
(cond ((or (not (integerp (cadr term)))
(int= (cadr term) 0))
(mv nil alist))
((and (quotep (fargn pat 1))
(integerp (cadr (fargn pat 1)))
(> (abs (cadr (fargn pat 1))) 1))
(let ((newtermevg (/ (cadr term)
(cadr (fargn pat 1)))))
(cond ((integerp newtermevg)
(onewayunify1
(fargn pat 2)
(kwote newtermevg)
alist))
(t (mv nil alist)))))
((and (quotep (fargn pat 2))
(integerp (cadr (fargn pat 2)))
(> (abs (cadr (fargn pat 2))) 1))
(let ((newtermevg (/ (cadr term)
(cadr (fargn pat 2)))))
(cond ((integerp newtermevg)
(onewayunify1
(fargn pat 1)
(kwote newtermevg)
alist))
(t (mv nil alist)))))
(t (mv nil alist))))
; We once were willing to unify ( x) with 3 by binding x to 3. John Cowles'
; experience with developing ACL2 arithmetic led him to suggest that we not
; unify ( x) with any constant other than negative ones. Similarly, we do not
; unify (/ x) with any constant other than those between 1 and 1. The code
; below reflects these suggestions.
(unary (cond ((>= (+ (realpart (cadr term))
(imagpart (cadr term)))
0)
(mv nil alist))
(t (onewayunify1 (fargn pat 1)
(kwote ( (cadr term)))
alist))))
(unary/ (cond ((or (>= (* (cadr term)
(conjugate (cadr term)))
1)
(eql 0 (cadr term)))
(mv nil alist))
(t (onewayunify1 (fargn pat 1)
(kwote
(/ (cadr term)))
alist))))
(otherwise (mv nil alist)))))
((symbolp (cadr term))
(cond
((eq (ffnsymb pat) 'interninpackageofsymbol)
(let ((pkg (symbolpackagename (cadr term)))
(name (symbolname (cadr term))))
(mvlet
(ans alist1)
; We are careful with alist to keep this a no change loser.
(onewayunify1 (fargn pat 1) (kwote name) alist)
(cond
(ans
; We are unifying 'pkg::name with (interninpackageofsymbol x y) where x is
; now unified with "name". So when is (interninpackageofsymbol "name" y)
; equal to pkg::name? It would suffice to unify y with any symbol in pkg. It
; might be that y is already such a quoted symbol. Or perhaps we could unify y
; with pkg::name, which is one symbol we know is in pkg. But note that it is
; not necessary that y unify with a symbol in pkg. It would suffice, for
; example, if y could be unified with a symbol in some other package, say gkp,
; with the property that pkg::name was imported into gkp, for then gkp::name
; would be pkg::name. Thus, as is to be expected by all failed unifications,
; failure does not mean there is no instance that is equal to the term.
; Suppose that y is not a quoted symbol and is not a variable (which could
; therefore be unified with pkg::name). What else might unify with "any symbol
; in pkg?" At first sight one might think that if y were
; (interninpackageofsymbol z 'pkg::name2) then the result is a symbol in
; pkg no matter what z is. (The idea is that one might think that
; (interninpackageofsymbol z 'pkg::name2) is "the" generic expression of
; "any symbol in pkg.") But that is not true because for certain z it is
; possible that the result isn't in pkg. Consider, for example, the
; possibility that gkp::zzz is imported into pkg so that if z is "ZZZ" the
; result is a symbol in gkp not pkg.
(cond
((and (nvariablep (fargn pat 2))
(fquotep (fargn pat 2)))
(cond
((not (symbolp (cadr (fargn pat 2))))
; (interninpackageofsymbol x y) is NIL if y is not a symbol. So we win if
; term is 'nil and lose otherwise. If we win, note that x is unified
; (unnecessarily) with "NIL" in alist1 and so we report the win with alist! If
; we lose, we have to report alist to be a no change loser. So its alist
; either way.
(mv (if (equal term *nil*) ans nil)
alist))
(t (if (equal pkg
(symbolpackagename
(cadr (fargn pat 2))))
(mv ans alist1)
(mv nil alist)))))
(t
(mvlet (ans alist2)
(onewayunify1 (fargn pat 2) term
alist1)
(cond (ans (mv ans alist2))
(t (mv nil alist)))))))
(t (mv nil alist))))))
(t (mv nil alist))))
((stringp (cadr term))
(cond ((and (eq (ffnsymb pat) 'coerce)
(equal (fargn pat 2) ''string))
(onewayunify1 (fargn pat 1)
(kwote (coerce (cadr term) 'list))
alist))
(t (mv nil alist))))
((consp (cadr term))
(cond ((eq (ffnsymb pat) 'cons)
; We have to be careful with alist below so we are a no change loser.
(mvlet (ans alist1)
(onewayunify1 (fargn pat 1)
(kwote (car (cadr term)))
alist)
(cond
(ans
(mvlet (ans alist2)
(onewayunify1 (fargn pat 2)
(kwote
(cdr (cadr term)))
alist1)
(cond (ans (mv ans alist2))
(t (mv nil alist)))))
(t (mv nil alist)))))
(t (mv nil alist))))
(t (mv nil alist))))
((cond ((flambdaapplicationp pat)
(equal (ffnsymb pat) (ffnsymb term)))
(t
(eq (ffnsymb pat) (ffnsymb term))))
(cond ((eq (ffnsymb pat) 'equal)
(onewayunify1equal (fargn pat 1) (fargn pat 2)
(fargn term 1) (fargn term 2)
alist))
(t (mvlet (ans alist1)
(onewayunify1lst (fargs pat) (fargs term) alist)
(cond (ans (mv ans alist1))
(t (mv nil alist)))))))
(t (mv nil alist))))
(defun onewayunify1lst (pl tl alist)
; This function is NOT a No Change Loser. That is, it may return nil
; as its first result, indicating that no substitution exists, but
; return as its second result an alist different from its input alist.
(declare (xargs :guard (and (pseudotermlistp pl)
(pseudotermlistp tl)
(alistp alist))))
(cond ((null pl) (mv t alist))
(t (mvlet (ans alist)
(onewayunify1 (car pl) (car tl) alist)
(cond
(ans
(onewayunify1lst (cdr pl) (cdr tl) alist))
(t (mv nil alist)))))))
(defun onewayunify1equal1 (pat1 pat2 term1 term2 alist)
; At first glance, the following code looks more elaborate than
; necessary. But this function is supposed to be a No Change Loser.
; The first time we coded this we failed to ensure that property. The
; bug is the result of fuzzy thinking in the vicinity of conjunctive
; subgoals. Suppose success requires success on x and success on y.
; The naive way to code it is (mvlet (ans nochanger) x (if ans y (mv
; nil nochanger))), i.e., to solve the x problem and if you win,
; return your solution to the y problem. But if x wins it will have
; changed nochanger. If y then loses, it returns the changed
; nochanger produced by x. Clearly, if x might win and change things
; but ultimate success also depends on y, you must preserve the
; original inputs and explicitly revert to them if y loses.
(mvlet (ans alist1)
(onewayunify1 pat1 term1 alist)
(cond (ans
(mvlet (ans alist2)
(onewayunify1 pat2 term2 alist1)
(cond (ans (mv ans alist2))
(t (mv nil alist)))))
(t (mv nil alist)))))
(defun onewayunify1equal (pat1 pat2 term1 term2 alist)
(mvlet (ans alist)
(onewayunify1equal1 pat1 pat2 term1 term2 alist)
(cond
(ans (mv ans alist))
(t (onewayunify1equal1 pat2 pat1 term1 term2 alist)))))
)
(defun onewayunify (pat term)
(declare (xargs :guard (and (pseudotermp pat)
(pseudotermp term))))
; This function returns two values. The first is T or NIL, according to
; whether unification succeeded. The second value returned is a symbol alist
; that when substituted into pat will produce term, when the unification
; succeeded.
; The use of the phrase ``unify'' here is somewhat opaque but is
; historically justified by its usage in nqthm. Really, all we are
; doing is matching because we do not treat the ``variable symbols''
; in term as instantiable.
; Note that the fact that this function returns nil should not be
; taken as a sign that no substition makes pat equal to term in the
; current theory. For example, we fail to unify (+ x x) with '2 even
; though '((x . 1)) does the job.
(onewayunify1 pat term nil))
; Essay on the Invariants on Typealists, and Canonicality
; There are four invariants on typealists.
; First invariant on typealists: No quotep is bound in a typealist.
; Second invariant on typealists: when (equiv x y) is bound in a typealist,
; it is bound to a type of *tst* or *tsnil*.
; Unlike the first two invariants, we will not depend on the third and fourth
; for soundness. We'll present them in a moment. We will maintain them both
; by insisting that the only operations allowed for extending typealists are
; extendtypealistsimple, extendtypealist, extendtypealist1, and
; extendtypealistwithbindings, and zipvariabletypealist, called in
; accordance with their guards.
; Definition. We say that a term u is "canonical" for an equivalence relation
; equiv of the current ACL2 world and a typealist if no entry in typealist is
; of the form ((equiv u z) *tst* . ttree). When equiv and typealist are
; understood, we may say simply that u is canonical.
; Third invariant on typealists: For every element ((equiv x y) ts . ttree) of
; a typealist for which equiv is an equivalence relation in the current ACL2
; world, y is canonical. Moreover, if ts is *tsnil*, then x is also
; canonical; and, if ts is *tst*, then (termorder y x) and x is not y.
; Finally, for each x there is at most one entry in typealist of the form
; ((equiv x y) *tst* . ttree); in this case, or when x = y and there is no
; entry of the form ((equiv y y') *tst* . ttree), we say that y is the
; canonical form of x.
; Although we have decided to maintain the third invariant, if later we decide
; not to be insistent on that, we may obtain some speedup by replacing some
; calls of extendtypealist by extendtypealistsimple. Look for the string
; ";;*** simple" to see some places where that might be especially
; appropriate. Note that even extendtypealistsimple is careful to preserve
; the first two invariants.
; The fourth invariant on typealists: No term is ever bound to *tsunknown*.
(defun canonicalrepresentative (equiv term typealist)
; This function returns a tuple (mv occursp canonicalp termcanon ttree)
; satifying the following description.
; Occursp holds iff, for some x, (equiv term x) or (equiv x term) is bound in
; typealist.
; Canonicalp is t or nil, and it is t iff term is canonical (see Essay above).
; Termcanon is the canonical form of term, i.e., is term if canonicalp is t
; and otherwise is the unique x such that ((equiv term x) *tst* . tt) belongs
; to typealist for some tt.
; Ttree is a tag tree justifying the equality of term to termcanon.
; We will use the following easytoprove theorem:
; (occursp = nil)
; implies
; (canonicalp = t)
; which implies
; (termcanon = term)
; We will also use the fact that if canonicalp is t then ttree is nil.
(declare (xargs :guard (symbolp equiv)))
(cond
((null typealist)
(mv nil t term nil))
(t (let ((firstterm (caar typealist))
(ts (cadar typealist)))
(cond ((or (variablep firstterm)
; Recall the first invariant on typealists: typealists do not bind quoteps.
(not (eq (ffnsymb firstterm) equiv)))
(canonicalrepresentative equiv term (cdr typealist)))
((equal term (fargn firstterm 1))
(cond ((ts= ts *tst*)
(mv t nil (fargn firstterm 2) (cddar typealist)))
(t (mv t t term nil))))
((equal term (fargn firstterm 2))
(mv t t term nil))
(t (canonicalrepresentative equiv term (cdr typealist))))))))
(defun substtypealist1check (old equiv typealist)
(cond
((null typealist)
nil)
(t (or (let ((term (caar typealist)))
(and (nvariablep term)
(eq (ffnsymb term) equiv)
(or (equal old (fargn term 1))
(equal old (fargn term 2)))))
(substtypealist1check old equiv (cdr typealist))))))
(defun substtypealist1 (new old equiv ttree typealist acc)
; This subsidiary function of substtypealist is coded so that we do not do
; any more consing than necessary. Moreover, we expect it to be extremely rare
; that old and new are already related (and hence negatively so) by equiv in
; typealist; someone is calling this function to create such a relationship.
; See also the comment in substtypealist.
(cond
((null typealist)
(reverse acc))
(t
(substtypealist1
new old equiv ttree (cdr typealist)
(cons (let ((term (caar typealist)))
(cond
((and (nvariablep term)
(eq (ffnsymb term) equiv)
(or (equal old (fargn term 1))
(equal old (fargn term 2))))
; Note that since substtypealist1 is only called by substtypealist, and
; substtypealist assumes that new and old are canonical in typealist and
; distinct, we know that the third invariant on typealists is being preserved:
; we are not creating an entry binding (equiv new new) to *tst*.
(list* (if (equal old (fargn term 1))
(consterm* equiv new (fargn term 2))
(consterm* equiv (fargn term 1) new))
(cadar typealist)
; Note on Tracking Equivalence Runes: If we ever give runic names to the
; theorems establishing equivalence relationhood and track those names
; through geneqvs, then we ought to push the appropriate rune here, rather than
; use puffert, which was intended for primitives and is thus here somewhat
; misused unless perhaps equiv is 'equal. There are many other places where
; this comment applies. You should inspect every use of puffert below and ask
; the question: is equivalential reasoning happening here or is it really
; primitive type reasoning? We added a function equivalencerune to record
; commutativity in bdd processing, and this function may be of use here.
(puffert
(constagtrees (cddar typealist) ttree))))
(t (car typealist))))
acc)))))
(defun substtypealist (new old equiv ttree typealist)
; This function creates a new typealist by replacing each term of the form
; (equiv old x) bound in typealist by (equiv new x), and each remaining term
; of the form (equiv x old) bound in typealist by (equiv x new), respectively.
; Each time it makes such a replacement it records ttree as the reason why that
; step is valid.
; We assume that new and old are canonical in typealist and distinct.
(cond
((substtypealist1check old equiv typealist)
(substtypealist1 new old equiv ttree typealist nil))
(t typealist)))
(defun infecttypealistentry (entry ttree)
; Entry is of the form (term ts . ttree1) and we add ttree to ttree1.
(cons (car entry)
(cons (cadr entry)
(constagtrees (cddr entry) ttree))))
(defun infectnewtypealistentries2 (newtypealist oldtypealist ttree)
; We infect the newly modified entries in newtypealist. See
; infectnewtypealistentries.
(cond ((null newtypealist)
nil)
((equal (caar newtypealist)
(caar oldtypealist))
(cons (car newtypealist)
(infectnewtypealistentries2 (cdr newtypealist)
(cdr oldtypealist)
ttree)))
(t
(cons (infecttypealistentry (car newtypealist) ttree)
(infectnewtypealistentries2 (cdr newtypealist)
(cdr oldtypealist)
ttree)))))
(defun infectnewtypealistentries1 (newtypealist oldtypealist ttree n)
; We infect the newly created entries in newtypealist. See
; infectnewtypealistentries.
(if (zp n)
(infectnewtypealistentries2 newtypealist oldtypealist
ttree)
(cons (infecttypealistentry (car newtypealist) ttree)
(infectnewtypealistentries1 (cdr newtypealist)
oldtypealist
ttree (1 n)))))
(defun infectnewtypealistentries (newtypealist oldtypealist ttree)
; New typealist is an extension of oldtypealist, and ttree
; contains any assumptions made while deriving the extension. We
; need to infect the new entries with these assumptions. This is
; made slightly more complex by the fact that newtypealist may
; actually be an extension of a modification of oldtypealist
; due to equality facts being added. (See extendtypealist1.)
; However, that modification is still in 1:1 correspondence with the
; original, i.e., there are no new entries, just modified entries.
(if (null ttree)
newtypealist
(infectnewtypealistentries1 newtypealist
oldtypealist
ttree
( (length newtypealist)
(length oldtypealist)))))
(defun extendtypealistsimple (term ts ttree typealist)
; This function extends typealist, essentially by adding the entry (term ts .
; ttree). However, this function preserves the first two invariants on
; typealists; see the "Essay on the Invariants on Typealists, and
; Canonicality." See also extendtypealist, which is similar but also
; preserves the third invariant on typealists.
; This function should never be called on a term that is a call of an
; equivalence relation. When viewed that way, it trivially preserves the third
; invariant on typealists as well.
(cond
((ts= ts *tsunknown*) typealist)
((variablep term)
(cons (list* term ts ttree) typealist))
((fquotep term) typealist)
(t (cons (list* term ts ttree) typealist))))
(defun extendtypealist1 (equiv occursp1 occursp2 bothcanonicalp arg1canon
arg2canon swapflg term ts ttree typealist)
; This function creates a typealist in which, intuitively, we bind the term
; (equiv arg1canon arg2canon) to ts unless the order is "wrong", in which
; case we use (equiv arg2canon arg1canon) instead.
; More precisely, it returns a typealist that is implied by the current
; typealist together with the assertion that (equiv arg1canon arg2canon) has
; typeset ts, under the following assumptions:
; equiv is an equivalence relation in the current ACL2 world;
; (equiv arg1canon arg2canon) is the same as term when (and (not swapflg)
; bothcanonicalp) is nonnil;
; swapflg is nonnil iff (termorder arg1canon arg2canon);
; occurs1p and arg1canon are returned by some single call of the function
; canonicalrepresentative;
; occurs2p and arg2canon are returned by some single call of the function
; canonicalrepresentative;
; arg1canon and arg2canon are canonical in typealist (by the two preceding
; assumptions) and distinct. This is important for the correctness of the
; calls of substtypealist; and
; ts is either *tst* or *tsnil*.
(cons (cond ((and (not swapflg) bothcanonicalp)
; Then term is the term to push on typealist; no need to cons up a new term.
(list* term ts ttree))
(swapflg (list* (consterm* equiv arg2canon arg1canon)
ts (puffert ttree)))
(t (list* (consterm* equiv arg1canon arg2canon)
ts (puffert ttree))))
(cond ((ts= ts *tsnil*) typealist)
(swapflg (cond
(occursp2
; It's easy to see that occursp2 holds if arg2canon is an argument of an equiv
; term bound in typealist, even without assuming that typealist satisfies the
; third invariant on typealists. Hence if occurs2p fails, there is no
; substituting to be done.
(substtypealist arg1canon arg2canon equiv ttree
typealist))
(t typealist)))
(t (cond
(occursp1
; See comment above for the entirely analogous situation when swapflg = t.
(substtypealist arg2canon arg1canon equiv ttree
typealist))
(t typealist))))))
; Regarding the maintenance of the second invariant on type alists:
; In the case that
; (and (not (ts= ts *tst*))
; (not (ts= ts *tsnil*))
; (equivalencerelationp (ffnsymb term) wrld))
; we used to return an unchanged typealist when extending a typealist.
; However, we already implicitly use (I think) the fact that equivalence
; relations are booleanvalued. So, we will do just a bit better in the new
; code.
; Certain violations of the Second invariant on typealists  when (equiv x y)
; is bound in a typealist, it is bound to a type of *tst* or *tsnil*  is
; reported in assumetruefalse by the error function assumetruefalseerror,
; which has caught an error in the past. See the "Essay on the Invariants on
; Typealists, and Canonicality."
(defun extendtypealist (term ts ttree typealist wrld)
; This function extends typealist so that term gets typeset ts with the
; indicated ttree. Unlike extendtypealistsimple, it pays careful attention
; to equivalence relations in an attempt to maintain the third invariant on
; typealists; see the "Essay on the Invariants on Typealists, and
; Canonicality."
(declare (xargs :guard (and (pseudotermp term)
(not (quotep term)))))
(cond
((and (nvariablep term)
(not (fquotep term))
(equivalencerelationp (ffnsymb term) wrld))
(cond
((equal (fargn term 1) (fargn term 2))
; It's bizarre to imagine (ts= ts *tst*) being false here, so we'll ignore the
; information we could obtain if it were false.
typealist)
((not (or (ts= ts *tst*)
(ts= ts *tsnil*)))
(cond ((tsintersectp ts *tsnil*)
typealist)
(t (extendtypealist
term *tst* (puffert ttree) typealist wrld))))
(t (let ((equiv (ffnsymb term))
(arg1 (fargn term 1))
(arg2 (fargn term 2)))
(mvlet (occursp1 canonicalp1 arg1canon ttree1)
(canonicalrepresentative equiv arg1 typealist)
(mvlet (occursp2 canonicalp2 arg2canon ttree2)
(canonicalrepresentative equiv arg2 typealist)
(cond
((equal arg1canon arg2canon)
typealist)
(t
(let ((swapflg (termorder arg1canon
arg2canon)))
(extendtypealist1
equiv occursp1 occursp2
(and canonicalp1 canonicalp2)
arg1canon arg2canon
swapflg
term ts
(constagtrees ttree1
(constagtrees ttree2 ttree))
typealist))))))))))
(t (extendtypealistsimple term ts ttree typealist))))
(defun zipvariabletypealist (vars pairs)
; Vars must be a list of distinct variables. Pairs must be a list of the
; same length as vars, pairing typesets to ttrees. This function is
; like (pairlis$ vars pairs) except that it deletes any binding to *tsunknown*.
; Under the guards stated, we guarantee the result is a typealist satisfying
; our invariants.
(cond ((null vars) nil)
((ts= (caar pairs) *tsunknown*)
(zipvariabletypealist (cdr vars) (cdr pairs)))
(t (cons (cons (car vars) (car pairs))
(zipvariabletypealist (cdr vars) (cdr pairs))))))
(defun assocequiv (fn arg1 arg2 alist)
; This function is equivalent to
; (or (assocequal (list fn arg1 arg2) alist)
; (assocequal (list fn arg2 arg1) alist))
; except that it looks for both at the same time and returns whichever
; one it finds first. We assume that the car of each pair in
; alist is a nonquote term.
(cond ((eq alist nil) nil)
((and (not (variablep (caar alist)))
(eq (ffnsymb (caar alist)) fn)
(if (equal (fargn (caar alist) 2) arg2)
(equal (fargn (caar alist) 1) arg1)
(and (equal (fargn (caar alist) 1) arg2)
(equal (fargn (caar alist) 2) arg1))))
(car alist))
(t (assocequiv fn arg1 arg2 (cdr alist)))))
(defun assocequiv+ (equiv arg1 arg2 typealist)
; This function body closely parallels code in the 'equal and
; equivalencerelationp cases of assumetruefalse.
(cond
((equal arg1 arg2)
(mv *tst* (puffert nil)))
((and (eq equiv 'equal) (quotep arg1) (quotep arg2))
(mv *tsnil* (pushlemma '(:executablecounterpart equal) nil)))
(t
(mvlet
(occursp1 canonicalp1 arg1canon ttree1)
(canonicalrepresentative equiv arg1 typealist)
(declare (ignore canonicalp1))
(cond
((and occursp1 (equal arg1canon arg2))
(mv *tst* (puffert ttree1)))
((and occursp1 (eq equiv 'equal) (quotep arg1canon) (quotep arg2))
(mv *tsnil* (pushlemma '(:executablecounterpart equal) ttree1)))
(t
(mvlet
(occursp2 canonicalp2 arg2canon ttree2)
(canonicalrepresentative equiv arg2 typealist)
(declare (ignore canonicalp2))
(cond
((and occursp2 (equal arg1canon arg2canon))
(mv *tst* (puffert (constagtrees ttree1 ttree2))))
((and (eq equiv 'equal) occursp2 (quotep arg1canon) (quotep arg2canon))
(mv *tsnil* (pushlemma '(:executablecounterpart equal)
(constagtrees ttree1 ttree2))))
(t
(let ((temptemp
(assocequiv equiv arg1canon arg2canon typealist)))
(cond
(temptemp
(cond ((ts= (cadr temptemp) *tst*)
; See comment in corresponding place in the 'equal case of assumetruefalse.
(mv (er hard 'assocequiv+
"Please send the authors of ACL2 a replayable ~
transcript of this problem if possible, so that ~
they can see what went wrong in the function ~
assocequiv+. The offending call was ~x0. The ~
surprising typeset arose from a call of ~x1."
(list 'assocequiv+
(kwote equiv) (kwote arg1) (kwote arg2)
typealist)
(list 'assocequiv
(kwote equiv)
(kwote arg1canon) (kwote arg2canon)
'<same_typealist>))
nil))
((ts= (cadr temptemp) *tsnil*)
(mv *tsnil* (constagtrees
(cddr temptemp)
(constagtrees ttree1 ttree2))))
(t
(let ((erp (assumetruefalseerror
typealist
(mconsterm* equiv arg1canon arg2canon)
(cadr temptemp))))
(mv erp nil)))))
(t (mv nil nil)))))))))))))
(defun assoctypealist (term typealist wrld)
(cond ((variablep term)
(let ((temp (assoceq term typealist)))
(if temp
(mv (cadr temp) (cddr temp))
(mv nil nil))))
((fquotep term) (mv nil nil))
((equivalencerelationp (ffnsymb term) wrld)
(assocequiv+ (ffnsymb term)
(fargn term 1)
(fargn term 2)
typealist))
(t (let ((temp (assocequal term typealist)))
(if temp
(mv (cadr temp) (cddr temp))
(mv nil nil))))))
(defun lookintypealist (term typealist wrld)
(mvlet (ts ttree)
(assoctypealist term typealist wrld)
(mv (if ts ts *tsunknown*) ttree)))
(defun membercharstringp (chr str i)
(cond ((< i 0) nil)
(t (or (eql chr (char str i))
(membercharstringp chr str (1 i))))))
(defun terminalsubstringp1 (str1 str2 max1 max2)
(declare (xargs :guard (and (integerp max1)
(integerp max2)
(<= max1 max2))))
(cond ((< max1 0) t)
((eql (char str1 max1) (char str2 max2))
(terminalsubstringp1 str1 str2 (1 max1) (1 max2)))
(t nil)))
(defun terminalsubstringp (str1 str2 max1 max2)
(cond ((< max2 max1) nil)
(t (terminalsubstringp1 str1 str2 max1 max2))))
(defun evgoccur (x y)
; Consider the idealized inductive construction of the ACL2 objects x
; and y as described in the comment for varfncount. Imagine that x
; and y are so represented. Then this function answers the question:
; "Does x occur in y?"
; Christ, I guess we have to look into symbolpackagenames too???
; Is this just heuristic?
(cond ((atom y)
(cond ((characterp y) (and (characterp x) (eql x y)))
((stringp y)
(cond ((characterp x)
(membercharstringp x y (1 (length y))))
((stringp x)
(terminalsubstringp x y
(1 (length x))
(1 (length y))))
(t nil)))
((symbolp y)
(cond ((characterp x)
(let ((sny (symbolname y)))
(membercharstringp x sny (1 (length sny)))))
((stringp x)
(let ((sny (symbolname y)))
(terminalsubstringp x sny
(1 (length x))
(1 (length sny)))))
((symbolp x) (eq x y))
(t nil)))
((integerp y)
(and (integerp x)
(or (int= x y)
(and (<= 0 x)
(<= x (if (< y 0) ( y) y))))))
((rationalp y)
; We know y is a noninteger rational. X occurs in it either because
; x is the same noninteger rational or x is an integer that occurs in
; the numerator or denominator.
(cond ((integerp x)
(or (evgoccur x (numerator y))
(evgoccur x (denominator y))))
((rationalp x) (= x y))
(t nil)))
(t
; We know y is a complex rational. X occurs in it either because
; x is the same complex rational or x is a rational that occurs in
; the real or imaginary part.
(cond ((rationalp x)
(or (evgoccur x (realpart y))
(evgoccur x (imagpart y))))
((complexrationalp x) (= x y))
(t nil)))))
(t (or (evgoccur x (car y))
(evgoccur x (cdr y))))))
(mutualrecursion
(defun occur (term1 term2)
(cond ((variablep term2)
(eq term1 term2))
((fquotep term2)
(cond ((quotep term1)
(evgoccur (cadr term1) (cadr term2)))
(t nil)))
((equal term1 term2) t)
(t (occurlst term1 (fargs term2)))))
(defun occurlst (term1 args2)
(cond ((null args2) nil)
(t (or (occur term1 (car args2))
(occurlst term1 (cdr args2))))))
)
; Rockwell Addition: I found an exponential explosion in worsethan
; and it is fixed here.
; Up through Version 2.5 worsethan was defined as shown below:
; (defun worsethan (term1 term2)
; (cond ((quickworsethan term1 term2) t)
; ((variablep term1) nil)
; ((fquotep term1) nil)
; (t (worsethanlst (fargs term1) term2))))
; But we discovered via Rockwell examples that this performs terribly
; if term1 and term2 are variants of each other, i.e., the same up to
; the variables used. So we have implemented a short circuit.
(mutualrecursion
(defun pseudovariantp (term1 term2)
; We determine whether term1 and term2 are identical up to the
; variables used, down to the variables in term1.
; If (pseudovariantp term1 term2) is true then we know that
; (worsethan term1 term2) is nil.
; Note: In the theorem proving literature, the word ``variant'' is
; used to mean that the two terms are identical up to a renaming of
; variables. That is checked by our function variantp. This function
; is different and of little logical use. It does not insist that a
; consistent renaming of variable occur, just that the two terms are
; isomorphic down to the variable symbols. It is here to avoid a very
; bad case in the worsethan check.
(cond ((variablep term1)
; Suppose that term1 is a variable. The only thing that it can be
; worse than is a quote. That is, if we return t, then we must ensure
; that either term2 is term1 or (worsethan term1 term2) is nil. The
; worsethan will be nil unless term2 is a quote. See the exponential
; sequences below.
(not (quotep term2)))
((fquotep term1) (equal term1 term2))
((or (variablep term2)
(fquotep term2))
nil)
(t (and (equal (ffnsymb term1) (ffnsymb term2))
(pseudovariantplist (fargs term1) (fargs term2))))))
(defun pseudovariantplist (args1 args2)
(cond ((endp args1) t)
(t (and (pseudovariantp (car args1) (car args2))
(pseudovariantplist (cdr args1) (cdr args2)))))))
; It turns out that without the use of pseudovariantp in the
; definition of worsethan, below, worsethan's cost grows
; exponentially on pseudovariant terms. Consider the sequence of
; terms (f a a), (f a (f a a)), ..., and the corresponding sequence
; with variable symbol b used in place of a. Call these terms a1, a2,
; ..., and b1, b2, ... Then if pseudovariantp were redefined to
; return nil, here are the real times taken to do (worsethan a1 b1),
; (worsethan a2 b2), ... 0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
; 0.000, 0.020, 0.080, 0.300, 1.110, 4.230, 16.390. This was measured
; on a 330 MHz Pentium II.
#
(progn
(time
(newworsethan
'(f a a)
'(f b b)))
(time
(newworsethan
'(f a (f a a))
'(f b (f b b))))
(time
(newworsethan
'(f a (f a (f a a)))
'(f b (f b (f b b)))))
(time
(newworsethan
'(f a (f a (f a (f a a))))
'(f b (f b (f b (f b b))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a a)))))
'(f b (f b (f b (f b (f b b)))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a a))))))
'(f b (f b (f b (f b (f b (f b b))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a a)))))))
'(f b (f b (f b (f b (f b (f b (f b b)))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a a))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b b))))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a (f a a))))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))
(time
(newworsethan
'(f a
(f a (f a (f a (f a (f a (f a (f a (f a (f a (f a (f a a))))))))))))
'(f b
(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))))
(time
(newworsethan
'(f a
(f a
(f a
(f a (f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))))))
'(f b
(f b
(f b
(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))
))
)
#
; If pseudovariantp is defined so that instead of (not (quotep
; term2)) it insists of (variablep term2) when (variablep term1), then
; the following sequence goes exponential even though the preceding
; one does not.
#
(progn
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))
))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))
))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))))
))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))))
))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))))))
))
(time
(newworsethan
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))))))
))
)
#
; with times of 0.000, 0.120, 0.250, 0.430, etc. But with the current
; definition of pseudovariantp, the sequence above is flat.
; However, the sequence with the terms commuted grows exponentially,
; still.
#
(progn
(time
(newworsethan
'(f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))))
(time
(newworsethan
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))))
(time
(newworsethan
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))))
(time
(newworsethan
'(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
))
(time
(newworsethan
'(f b
(f b
(f b
(f b (f b (f b (f b (f b (f b (f b (f b (f b (f b b)))))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
))
(time
(newworsethan
'(f b
(f b
(f b
(f b
(f b
(f b
(f b (f b (f b (f b (f b (f b (f b (f b b))))))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
))
(time
(newworsethan
'(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b (f b (f b (f b (f b (f b b)))))))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
))
(time
(newworsethan
'(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b (f b (f b (f b b))))))))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
))
(time
(newworsethan
'(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b
(f b b)))))))))))))))))
'(f a (f a (f a (f a (f a (f a (f a (f a (f a a)))))))))
))
)
#
; Real times: 0.000, 0.000, 0.010, 0.000, 0.010, 0.020, 0.040, 0.100,
; 0.210, ...
(mutualrecursion
(defun worsethan (term1 term2)
; Term1 is worsethan term2 if it is basicworsethan term2 or some
; proper subterm of it is worsethan or equal to term2. However, we
; know that if two terms are pseudovariants of eachother, then the
; worsethan relation does not hold.
(cond ((basicworsethan term1 term2) t)
((pseudovariantp term1 term2) nil)
((variablep term1)
; If term1 is a variable and not basicworsethan term2, what do we know
; about term2? Term2 might be a variable. Term2 cannot be quote.
; Term2 might be a function application. So is X worsethan X or Y or
; (F X Y)? No.
nil)
((fquotep term1)
; If term1 is a quote and not basicworsethan term2, what do we know
; about term2? Term2 might be a variable. Also, term2 might be a
; quote, but if it is, term2 is bigger than term1. Term2 might be a
; function application. So is term1 worsethan a bigger quote? No.
; Is term1 worsethan a variable or function application? No.
nil)
(t (worsethanlst (fargs term1) term2))))
(defun worsethanorequal (term1 term2)
; This function is not really mutually recursive and could be removed
; from this nest. It determines whether term1 is term2 or worse than
; term2. This nest defines worsethan and does not use this function
; despite the use of similarly named functions.
; Note: This function is supposed to be equivalent to
; (or (equal term1 term2) (worsethan term1 term2)).
; Clearly, that is equivalent to
; (if (pseudovariantp term1 term2)
; (or (equal term1 term2) (worsethan term1 term2))
; (or (equal term1 term2) (worsethan term1 term2)))
; But if pseudovariantp is true, then worsethan must return nil.
; And if pseudovariantp is nil, then the equal returns nil. So we
; can simplify the if above to:
(if (pseudovariantp term1 term2)
(equal term1 term2)
(worsethan term1 term2)))
(defun basicworsethanlst1 (args1 args2)
; Is some element of args2 ``uglier'' than the corresponding element
; of args1. Technically, a2 is uglier than a1 if a1 is atomic (a
; variable or constant) and a2 is not or a2 is worsethan a1.
(cond ((null args1) nil)
((or (and (or (variablep (car args1))
(fquotep (car args1)))
(not (or (variablep (car args2))
(fquotep (car args2)))))
(worsethan (car args2) (car args1)))
t)
(t (basicworsethanlst1 (cdr args1) (cdr args2)))))
(defun basicworsethanlst2 (args1 args2)
; Is some element of arg1 worsethan the corresponding element of args2?
(cond ((null args1) nil)
((worsethan (car args1) (car args2)) t)
(t (basicworsethanlst2 (cdr args1) (cdr args2)))))
(defun basicworsethan (term1 term2)
; We say that term1 is basicworsethan term2 if
; * term2 is a variable and term1 properly contains it, e.g., (F A B)
; is basicworsethan A;
; * term2 is a quote and term1 is either not a quote or is a bigger
; quote, e.g., both X and '124 are basicworsethan '17 and '(A B C D
; E) is worse than 'X; or
; * term1 and term2 are applications of the same function and
; no argument of term2 is uglier than the corresponding arg of term1, and
; some argument of term1 is worsethan the corresponding arg of term2.
; The last case is illustrated by the fact that (F A B) is
; basicworsethan (F A '17), because B is worse than '17, but (F '17
; B) is not basicworsethan (F A '17) because A is worse than '17.
; Think of term2 as the old goal and term1 as the new goal. Do we
; want to cut off backchaining? Yes, if term1 is basicworsethan
; term2. So would we backchain from (F A '17) to (F '17 B)? Yes,
; because even though one argument (the second) got worse (it went
; from 17 to B) another argument (the first) got better (it went from
; A to 17).
(cond ((variablep term2)
(cond ((eq term1 term2) nil)
(t (occur term2 term1))))
((fquotep term2)
(cond ((variablep term1) t)
((fquotep term1)
(> (fncountevg (cadr term1))
(fncountevg (cadr term2))))
(t t)))
((variablep term1) nil)
((fquotep term1) nil)
((cond ((flambdaapplicationp term1)
(equal (ffnsymb term1) (ffnsymb term2)))
(t (eq (ffnsymb term1) (ffnsymb term2))))
(cond ((pseudovariantp term1 term2) nil)
((basicworsethanlst1 (fargs term1) (fargs term2)) nil)
(t (basicworsethanlst2 (fargs term1) (fargs term2)))))
(t nil)))
(defun somesubtermworsethanorequal (term1 term2)
; Returns t if some subterm of term1 is worsethan or equal to term2.
(cond ((variablep term1) (eq term1 term2))
((if (pseudovariantp term1 term2) ; see worsethanorequal
(equal term1 term2)
(basicworsethan term1 term2))
t)
((fquotep term1) nil)
(t (somesubtermworsethanorequallst (fargs term1) term2))))
(defun somesubtermworsethanorequallst (args term2)
(cond ((null args) nil)
(t (or (somesubtermworsethanorequal (car args) term2)
(somesubtermworsethanorequallst (cdr args) term2)))))
(defun worsethanlst (args term2)
; We determine whether some element of args contains a subterm that is
; worsethan or equal to term2. The subterm in question may be the
; element of args itself. That is, we use ``subterm'' in the ``not
; necessarily proper subterm'' sense.
(cond ((null args) nil)
(t (or (somesubtermworsethanorequal (car args) term2)
(worsethanlst (cdr args) term2)))))
)
; Here is how we add a frame to the ancestors stack.
(defun pushancestor (lit tokens ancestors)
; This function is used to push a new pair onto ancestors. Lit is a
; term to be assumed true. Tokens is a list of arbitrary objects.
; Generally, tokens is a singleton list containing the rune of a rule
; through which we are backchaining. But when we rewrite forced
; assumptions we use the ``runes'' from the assumnotes (see defrec
; assumnote) as the tokens. These ``runes'' are not always runes but
; may be symbols.
; Note: It is important that the literal, lit, be in the car of the
; frame constructed below.
(let* ((alit lit)
(alitatm (mvlet (notflg atm)
(stripnot alit)
(declare (ignore notflg))
atm)))
(mvlet (fncntalitatm pfncntalitatm)
(fncount alitatm)
(cons (list alit ; the literal being assumed true
; (negation of hyp!)
alitatm ; the atom of that literal
fncntalitatm ; the fncount of that atom
pfncntalitatm ; the pseudofncount of that atom
tokens) ; the runes involved in this backchain
ancestors))))
(defun earlierancestorbiggerp (fncnt pfncnt tokens ancestors)
; We return t if some ancestor on ancestors has a bigger fncount than
; fncnt and intersects with tokens.
(cond ((null ancestors) nil)
(t (let (; (alit (car (car ancestors)))
; (alitatm (cadr (car ancestors)))
(fncntalitatm (caddr (car ancestors)))
(pfncntalitatm (cadddr (car ancestors)))
(atokens (car (cddddr (car ancestors)))))
(cond
((and (intersectpequal tokens atokens)
(or (< fncnt fncntalitatm)
(and (eql fncnt fncntalitatm)
(< pfncnt pfncntalitatm))))
t)
(t (earlierancestorbiggerp fncnt pfncnt tokens
(cdr ancestors))))))))
(defun ancestorscheck1 (litatm lit fncnt pfncnt ancestors tokens)
; Roughly speaking, ancestors is a list of all the things we can
; assume by virtue of our trying to prove their negations. That is,
; when we backchain from B to A by applying (implies A B), we try to
; prove A and so we put (NOT A) on ancestors and can legitimately
; assume it (i.e., (NOT A)) true. Roughly speaking, if lit is a
; memberequal of ancestors, we return (mv t t) and if the complement
; of lit is a memberequal we return (mv t nil). If neither case
; obtains, we return (mv nil nil).
; We implement the complement check as follows. litatm is the atom
; of the literal lit. Consider a literal of ancestors, alit, and its
; atom, alitatm. If litatm is alitatm and lit is not equal to alit,
; then lit and alit are complementary. The following table supports
; this observation. It shows all the combinations by considering that
; lit is either a positive or negative p, and alit is a p of either
; sign or some other literal of either sign. The entries labeled =
; mark those when lit is alit. The entries labeled comp mark those
; when lit and alit are complementary.
; lit \ alit: p (not p) q (not q)
; p = comp x x
; (not p) comp = x x
(cond
((null ancestors)
(mv nil nil))
((eq (caar ancestors) :bindinghyp)
(ancestorscheck1 litatm lit fncnt pfncnt (cdr ancestors) tokens))
(t
(let ((alit (car (car ancestors)))
(alitatm (cadr (car ancestors)))
(fncntalitatm (caddr (car ancestors)))
(pfncntalitatm (cadddr (car ancestors)))
(atokens (car (cddddr (car ancestors)))))
(cond
((equal alit lit)
(mv t t))
((equal litatm alitatm) (mv t nil))
; In Version_2.5, this function did not have the tokens argument.
; Instead we simply asked whether there was a frame on the ancestors
; stack such that fncnt was greater than or equal to the fncount of
; the atom in the frame and litatm was worsethanorequal to the
; atom in the frame. If so, we aborted with (mv t nil). (The fncnt
; test is just an optimization because that inequality is implied by
; the worsethanorequal test.) But Carlos Pacheco's TLA work
; exposed a situation in which the litatm was worsethanorequal to
; a completely unrelated atom on the ancestors stack. So we added
; tokens and insisted that the ancestor so dominated by litatm was
; related to litatm by having a nonempty intersection with tokens.
; This was added in the final polishing of Version_2.6. But we learned
; that it slowed us down about 10% because it allowed so much more
; backchaining. We finally adopted a very conservative change
; targeted almost exactly to allow Carlos' example while preserving
; the rest of the old behavior.
((intersectpequal tokens atokens)
; We get here if the current litatm is related to that in the current
; frame. We next ask whether the function symbols are the same and
; litatm is bigger. If so, we abort. Otherwise, we look for others.
(cond ((and (nvariablep alitatm)
(not (fquotep alitatm))
(nvariablep alitatm)
(not (fquotep litatm))
(equal (ffnsymb litatm) (ffnsymb alitatm))
(or (> fncnt fncntalitatm)
(and (eql fncnt fncntalitatm)
(>= pfncnt pfncntalitatm))))
(mv t nil))
(t (ancestorscheck1 litatm lit fncnt pfncnt
(cdr ancestors) tokens))))
((and (or (> fncnt fncntalitatm)
(and (eql fncnt fncntalitatm)
(>= pfncnt pfncntalitatm)))
(worsethanorequal litatm alitatm))
; The clause above is the old Version_2.5 test, but now it is tried
; only if the atms are unrelated by their tokens. Most of the time we
; want to abort backchaining if we pass the check above. But we want
; to allow continued backchaining in Carlos' example. In that
; example:
; litatm = (S::MEM (S::APPLY S::DISKSWRITTEN S::P)
; (S::POWERSET (S::DISK)))
; fncnt = 4
; alitatm = (S::MEM S::D (S::DISK))
; fncntalitatm = 2
; with no token intersection. Once upon a time we simply allowed all
; these, i.e., just coded a recursive call here. But that really
; slowed us down by enabling a lot of backchaining. So now we
; basically want to ask: "Is there a really good reason to allow this
; backchain?" We've decided to allow the backchain if there is an
; earlier ancestor, related by tokens, to the ancestor that is trying
; to veto this one, that is bigger than this one. In Carlos' example
; there is such a larger ancestor; but we suspect most of the time
; there isn't. For example, at the very least it means that the
; vetoing ancestor must be the SECOND (or subsequent) time we've
; applied some rule on this backchaining path! The first time we
; coded this heuristic we named the test ``randomcoinflip'' instead
; of earlierancestorbiggerp; the point: this is a pretty arbitrary
; decision heuristic mainly to make Carlos' example work.
(cond ((earlierancestorbiggerp fncnt
pfncnt
atokens
(cdr ancestors))
(ancestorscheck1 litatm lit fncnt pfncnt
(cdr ancestors) tokens))
(t (mv t nil))))
(t (ancestorscheck1 litatm lit fncnt pfncnt
(cdr ancestors) tokens)))))))
; Note: In the typeset clique, and nowhere else, ancestors might be
; t. The socalled tancestors hack is explained below. But this
; function and pushancestor above DO NOT implement the tancestors
; hack. That is because they are used by the rewrite clique where
; there is no such hack, and we didn't want to slow that clique down.
(defun ancestorscheck (lit ancestors tokens)
; We return two values. The first is whether we should abort trying
; to establish lit on behalf of the given tokens. The second is
; whether lit is (assumed) true in ancestors.
; We abort iff either lit is assumed true or else it is worse than or
; equal to some other literal we're trying to establish on behalf of
; some token in tokens. (Actually, we compare the atoms of the two
; literals in the worsethan check.)
; A reminder about ancestors: Ancestors is a list of pairs. Each pair
; is (term . tokens'). Term is something we can assume true (because
; we are currently trying to prove it false). Tokens' is a list of
; tokens. A token is a rune or a function symbol (or anything else,
; for all we care). Generally speaking, tokens' is a singleton list
; containing a single rune, the one naming the lemma through which we
; are backchaining. For example, if R is the lemma (IMPLIES p (EQUAL
; lhs rhs)) and we are trying to rewrite some target matching lhs, we
; backchain to establish p and we will add (NOT p) and the singleton
; list containing R to ancestors.
; Historical Note: In nqthm, this function was named relievehypsnotok.
(mvlet (notflg litatm)
(stripnot lit)
(declare (ignore notflg))
(mvlet (fncnt pfncnt)
(fncount litatm)
(ancestorscheck1 litatm lit fncnt pfncnt
ancestors tokens))))
(defun typesetfinish (ts0 ttree0 ts1 ttree1)
; We have obtained two typeset answers for some term. Ts0 and ttree0
; were obtained by looking the term up in the typealist; if ts0 is
; nil, then no binding was found in the typealist. Ts1 and ttree1
; were obtained by computing the typeset of the term "directly."
; Both are valid, provided ts0 is nonnil. We intersect them.
; Note: Our answer must include ttree1 because that is the accumulated
; dependencies of the typeset computation to date!
(cond ((null ts0)
(mv ts1 ttree1))
((tssubsetp ts1 ts0)
; This is an optimization. We are about to intersect the typesets and union
; the tag trees. But if ts1 is a subset of ts0, the intersection is just ts1.
; We need not return ttree0 in this case; note that we must always return ttree1.
(mv ts1 ttree1))
(t (mv (tsintersection ts0 ts1)
(constagtrees ttree0 ttree1)))))
(defun searchtypealistrec (term altterm typ typealist unifysubst ttree)
(cond ((null typealist)
(mv nil unifysubst ttree nil))
((tssubsetp (cadr (car typealist)) typ)
(mvlet (ans unifysubst)
(onewayunify1 term (car (car typealist)) unifysubst)
(cond (ans
(mv t
unifysubst
(constagtrees (cddr (car typealist)) ttree)
(cdr typealist)))
(altterm
(mvlet (ans unifysubst)
(onewayunify1 altterm (car (car typealist))
unifysubst)
(cond (ans
(mv t
unifysubst
(constagtrees (cddr (car typealist)) ttree)
(cdr typealist)))
(t (searchtypealistrec term altterm
typ
(cdr typealist)
unifysubst
ttree)))))
(t (searchtypealistrec term altterm
typ
(cdr typealist)
unifysubst
ttree)))))
(t (searchtypealistrec term altterm
typ
(cdr typealist)
unifysubst
ttree))))
(mutualrecursion
(defun freevarsp (term alist)
(cond ((variablep term) (not (assoceq term alist)))
((fquotep term) nil)
(t (freevarsplst (fargs term) alist))))
(defun freevarsplst (args alist)
(cond ((null args) nil)
(t (or (freevarsp (car args) alist)
(freevarsplst (cdr args) alist)))))
)
(defun searchtypealist (term typ typealist unifysubst ttree wrld)
; We search typealist for an instance of term bound to a typeset
; that is a subset of typ. Keep this in sync with searchtypealist+.
; For example, if typ is *tsrational* then we seek an instance of
; term that is known to be a subset of the rationals. Most commonly,
; typ is *tsnonnil*. In that case, we seek an instance of term
; that is nonnil. Thus, this function can be thought of as trying to
; "make term true." To use this function to "make term false," use
; the tscomplement of the desired type. I.e., if you wish to find a
; false instance of term use *tsnil*.
; By "instance" here we always mean an instance under an extension of
; unifysubst. The extension is returned when we are successful.
; We return three values. The first indicates whether we succeeded.
; The second is the final unifysubst. The third is a modified ttree
; recording the literals used. If we did not succeed, the second
; and third values are our input unifysubst and ttree. I.e., we are
; a NoChange Loser.
; The NoChange Policy: Many multivalued functions here return a
; flag that indicates whether they "won" or "lost" and, in the case
; that they won, return "new values" for certain of their arguments.
; Here for example, we return a new value for unifysubst. In early
; coding we adopted the policy that when they "lost" the additional
; values were irrelevant and were often nil. This policy prevented
; the use of such forms as:
; (mvlet (wonp unifysubst)
; (searchtypealist ... unifysubst ...)
; (cond (wonp ...)
; (t otherwise...)))
; because at otherwise... unifysubst was no longer what it had been before
; the searchtypealist. Instead we had to think of a new name for
; it in the mvlet and use the appropriate one below.
; We then adopted what we now call the "NoChange Policy". If a
; function returns a won/lost flag and some altered arguments, the
; NoChange Policy is that it returns its input arguments in case it
; loses. We will note explicitly when a function is a NoChange
; Loser.
(mvlet (term altterm)
(cond ((or (variablep term)
(fquotep term)
(not (equivalencerelationp (ffnsymb term) wrld)))
(mv term nil))
; Otherwise, term is of the form (equiv term1 term2). If term1 precedes term2
; in termorder, then term would be stored on a typealist as (equiv term2
; term1); see the Essay on the Invariants on Typealists, and Canonicality
; (specifically, the third invariant described there). In such a case we may
; wish to search for the commuted version instead of term. However, if there
; are free variables in term with respect to unifysubst then we need to search
; both for term and its commuted version, because the more specific term on
; typealist can have its arguments in either termorder (unless we engage in a
; relatively expensive check; see e.g. maximalterms).
((freevarsp term unifysubst)
(mv term
(fconsterm* (ffnsymb term) (fargn term 2) (fargn term 1))))
(t (let ((arg1 (fargn term 1))
(arg2 (fargn term 2)))
(cond ((termorder arg1 arg2)
(mv (fconsterm* (ffnsymb term)
(fargn term 2)
(fargn term 1))
nil))
(t (mv term nil))))))
(mvlet (ans unifysubst ttree resttypealist)
(searchtypealistrec term altterm typ typealist unifysubst ttree)
(declare (ignore resttypealist))
(mv ans unifysubst ttree))))
(defun termandtyptolookup (hyp wrld)
(mvlet
(notflg term)
(stripnot hyp)
(let* ((recogtuple (and (nvariablep term)
(not (fquotep term))
(not (flambdaapplicationp term))
(assoceq (ffnsymb term)
(globalval 'recognizeralist wrld))))
(typ (if (and recogtuple
(access recognizertuple recogtuple :strongp))
(if notflg
(access recognizertuple recogtuple :falsets)
(access recognizertuple recogtuple :truets))
(if notflg *tsnil* *tsnonnil*)))
(term (if (and recogtuple
(access recognizertuple recogtuple :strongp))
(fargn term 1)
term)))
(mv term typ))))
(defun lookuphyp (hyp typealist wrld unifysubst ttree)
; See if hyp is true by typealist or simpclause considerations 
; possibly extending the unifysubst. If successful we return t, a
; new unifysubst and a new ttree. NoChange Loser.
(mvlet (term typ)
(termandtyptolookup hyp wrld)
(searchtypealist term typ typealist unifysubst ttree wrld)))
(mutualrecursion
(defun sublisvarandmarkfree (alist form)
; This function is rather odd: it is equivalent to (sublisvar alist'
; form) where alist' is derived from alist by adding a pair (var .
; ???var) for each variable var in form that is not assigned a value
; by alist. Thus it creates an instance of form. However, the free
; vars of form are assigned essentially arbitrary variable values and
; while no two free vars are identified by this process, there is no
; guarantee that the variables introduced in their stead are "new."
; For example, ???var may come into the instantiated term via alist.
; The only reason for this function is to highlight the free vars in a
; term upon which we will split, in the halfhearted hope that the
; user will spot it.
(cond ((variablep form)
(let ((a (assoceq form alist)))
(cond (a (cdr a))
(t (packn (list "???" form))))))
((fquotep form)
form)
(t (consterm (ffnsymb form)
(sublisvarandmarkfreelst alist (fargs form))))))
(defun sublisvarandmarkfreelst (alist l)
(if (null l)
nil
(cons (sublisvarandmarkfree alist (car l))
(sublisvarandmarkfreelst alist (cdr l)))))
)
; The Accumulated Persistence Essay
; We now develop the code needed to track accumulatedpersistence.
; To activate accumulatedpersistence, you must first call
; >(accumulatedpersistence t) ; activate and initialize
; > ... ; do proofs
; >(showaccumulatedpersistence :frames) ; to display stats ordered by
; ; frame count
; >(accumulatedpersistence nil) ; deactivate
; A macro form is available for use in system code to support the tracking of
; accumulated persistence. The specialform
; (withaccumulatedpersistence rune (v1 ... vk) body)
; should be used in our source code whenever body is code that attempts to
; apply rune. The list of variables, (v1 ... vk), tell us the multiplicity
; of body. This form is logically equivalent to
; (mvlet (v1 ... vk) body (mv v1 ... vk))
; which is to say, it is logically equivalent to body itself. (In the case
; where k is 1, we naturally use a let instead of an mvlet.) However, we
; insert some additional code to accumulate the persistence of rune.
; The implementation of accumulatedpersistence is as follows. First, the
; necessary global data structures are maintained inside a wormhole called
; 'accumulatedpersistence, so they can be accessed and changed anytime. The
; data is maintained as the value of (fglobalval 'wormholeoutput state) in
; that wormhole. Recall that the 'wormholeoutput of a wormhole named
; 'accumulatedpersistence is restored upon entrance to the wormhole to the
; value it had upon the most recent exit of that wormhole.
; Our wormholeoutput is a triple of the form (cnt stack . totals), where cnt
; is the total number of lemmas tried so far, stack is a list of old values of
; cnt, and totals is the accumulated totals. Each element of stack corresponds
; to an attempt to apply a certain rune and the element is the value of cnt at
; the time the attempt started. When the attempt is done, we subtract the then
; current value of cnt with the old value to find out how many lemmas were
; tried under that rune and we accumulate that increment into the totals. The
; accumulated totals is an alist and each pair is of the form (rune n . ap),
; where n is the number of times rune was pushed onto the stack and ap is the
; accumulated persistence of that rune: the number of frames built while that
; rune was on the stack.
; Performance:
; A :miniproveall that takes 66 seconds with accumulatedpersistence
; disabled, takes 251 seconds (3.8 times longer) with accumulatedpersistence
; on.
(defun addaccumulatedpersistence (rune delta alist)
; Each element of alist is of the form (rune n . ap). We
; increment n by 1 and ap by delta.
(let ((pair (assocequal rune alist)))
(cond ((null pair) (cons (cons rune (cons 1 delta)) alist))
(t (cons (cons rune (cons (1+ (cadr pair)) (+ delta (cddr pair))))
(remove1equal pair alist))))))
(defmacro accumulatedpersistence (flg)
":DocSection Miscellaneous
to get statistics on which ~il[rune]s are being tried~/
~bv[]
Useful Forms:
(accumulatedpersistence t) ; activate statistics gathering
(showaccumulatedpersistence :frames) ; display statistics ordered by
(showaccumulatedpersistence :tries) ; frames built, times tried,
(showaccumulatedpersistence :ratio) ; or their ratio
(accumulatedpersistence nil) ; deactivate
~ev[]~/
Generally speaking, the more ACL2 knows, the slower it runs. That
is because the search space grows with the number of alternative
rules. Often, the system tries to apply rules that you have
forgotten were even there, if you knew about them in the first
place! ``Accumulatedpersistence'' is a statistic (originally
developed for Nqthm) that helps you identify the rules that are
causing ACL2's search space to explode.
Accumulated persistence tracking can be turned on or off. It is
generally off. When on, the system runs about two times slower than
otherwise! But some useful numbers are collected. When it is
turned on, by
~bv[]
ACL2 !>(accumulatedpersistence t)
~ev[]
an accumulation site is initialized and henceforth data about
which rules are being tried is accumulated into that site. That
accumulated data can be displayed with ~c[showaccumulatedpersistence],
as described in detail below. When accumulated persistence is
turned off, with ~c[(accumulatedpersistence nil)], the accumulation
site is wiped out and the data in it is lost.
The ``accumulated persistence'' of a ~il[rune] is the number of ~il[rune]s the
system has attempted to apply (since accumulated persistence was
last activated) while the given ~il[rune] was being tried.
Consider a ~c[:]~ilc[rewrite] rule named ~ilc[rune]. For simplicity, let us imagine
that ~ilc[rune] is tried only once in the period during which accumulated
persistence is being ~il[monitor]ed. Recall that to apply a rewrite rule
we must match the lefthand side of the conclusion to some term we
are trying to rewrite, establish the hypotheses of ~ilc[rune] by
rewriting, and, if successful, then rewrite the righthand side of
the conclusion. We say ~ilc[rune] is ``being tried'' from the time we
have matched its lefthand side to the time we have either abandoned
the attempt or finished rewriting its righthand side. (By
``match'' we mean to include any loopstopper requirement;
~pl[loopstopper].) During that period of time other rules
might be tried, e.g., to establish the hypotheses. The rules tried
while ~ilc[rune] is being tried are ``billed'' to ~ilc[rune] in the sense
that they are being considered here only because of the demands of
~ilc[rune]. Thus, if no other rules are tried during that period,
the accumulated persistence of ~ilc[rune] is ~c[1] ~[] we ``bill'' ~ilc[rune]
once for its own application attempt. If, on the other hand, we
tried ~c[10] rules on behalf of that application of ~ilc[rune], then
~ilc[rune]'s accumulated persistence would be ~c[11].
One way to envision accumulated persistence is to imagine that every
time a ~il[rune] is tried it is pushed onto a stack. The rules tried on
behalf of a given application of a ~il[rune] are thus pushed and popped
on the stack above that ~il[rune]. A lot of work might be done on its
behalf ~[] the stack above the ~il[rune] grows and shrinks repeatedly as
the search continues for a way to use the ~il[rune]. All the while, the
~il[rune] itself ``persists'' in the stack, until we finish with the
attempt to apply it, at which time we pop it off. The accumulated
persistence of a ~il[rune] is thus the number of stack frames built while
the given ~il[rune] was on the stack.
Note that accumulated persistence is not concerned with whether the
attempt to apply a ~il[rune] is successful. Each of the rules tried on
its behalf might have failed and the attempt to apply the ~il[rune] might
have also failed. The ACL2 proof script would make no mention of
the ~il[rune] or the rules tried on its behalf because they did not
contribute to the proof. But time was spent pursuing the possible
application of the ~il[rune] and accumulated persistence is a measure of
that time.
A high accumulated persistence might come about in two extreme ways.
One is that the rule causes a great deal of work every time it is
tried. The other is that the rule is ``cheap'' but is tried very
often. We therefore keep track of the number of times each rule is
tried as well as its persistence. The ratio between the two is the
average amount of work done on behalf of the rule each time it is
tried.
When the accumulated persistence totals are displayed by the
function ~c[showaccumulatedpersistence] we sort them so that the most
expensive ~il[rune]s are shown first. We can sort according to one of
three keys:
~bv[]
:frames  the number of frames built on behalf of the rune
:tries  the number of times the rune was tried
:ratio  frames built per try
~ev[]
The key simply determines the order in which the information is
presented. If no argument is supplied to
~c[showaccumulatedpersistence], ~c[:frames] is used.
Note that a ~il[rune] with high accumulated persistence may not actually
be the ``culprit.'' For example, suppose ~c[rune1] is reported to have
a ~c[:ratio] of ~c[101], meaning that on the average a hundred and one
frames were built each time ~c[rune1] was tried. Suppose ~c[rune2] has a
~c[:ratio] of ~c[100]. It could be that the attempt to apply ~c[rune1] resulted
in the attempted application of ~c[rune2] and no other ~il[rune]. Thus, in
some sense, ~c[rune1] is ``cheap'' and ~c[rune2] is the ``culprit'' even
though it costs less than ~c[rune1].
Users are encouraged to think about other meters we could install in
ACL2 to help diagnose performance problems."
`(wormhole t 'accumulatedpersistence
nil
'(pprogn (fputglobal 'wormholeoutput
(if ,flg '(0 nil . nil) nil)
state)
(value :q))
:ldprompt nil
:ldpreevalfilter :all
:ldpreevalprint nil
:ldpostevalprint :commandconventions
:ldevisctuple nil
:lderrortriples t
:lderroraction :error
:ldquerycontrolalist nil
:ldverbose nil))
(defun mergecar> (l1 l2)
(cond ((null l1) l2)
((null l2) l1)
((> (car (car l1)) (car (car l2)))
(cons (car l1) (mergecar> (cdr l1) l2)))
(t (cons (car l2) (mergecar> l1 (cdr l2))))))
(defun mergesortcar> (l)
(cond ((null (cdr l)) l)
(t (mergecar> (mergesortcar> (evens l))
(mergesortcar> (odds l))))))
(defun showaccumulatedpersistencephrase1 (alist)
; Alist has element of the form (x . (rune n . ap)), where x is
; the key upon which we sorted.
(cond ((null alist) nil)
(t (let* ((trip (cdr (car alist)))
(rune (car trip))
(n (cadr trip))
(ap (cddr trip)))
(cons (msg "~c0 ~c1 (~c2.~f3~f4) ~y5"
(cons ap 10)
(cons n 8)
(cons (floor ap n) 5)
(mod (floor (* 10 ap) n) 10)
(mod (floor (* 100 ap) n) 10)
rune)
(showaccumulatedpersistencephrase1 (cdr alist)))))))
(defun showaccumulatedpersistencephrase2 (key alist)
(cond ((null alist) nil)
(t (cons (cons (case key
(:frames (cddr (car alist)))
(:tries (cadr (car alist)))
(otherwise (/ (cddr (car alist)) (cadr (car alist)))))
(car alist))
(showaccumulatedpersistencephrase2 key (cdr alist))))))
(defun showaccumulatedpersistencephrase (key alist)
; Alist is the accumulated totals alist from the wormholeoutput of the
; 'accumulatedpersistence wormhole. Each element is of the form (rune n . ap)
; and we sort them into descending order on the specified key. Key should be
; one of
; :frames  sort on the number of frames built on behalf of the rune
; :tries  sort on the number of times the rune was tried
; :ratio  sort on frames/calls
(list "" "~@*" "~@*" "~@*"
(showaccumulatedpersistencephrase1
(mergesortcar>
(showaccumulatedpersistencephrase2 key alist)))))
(defmacro showaccumulatedpersistence (&optional (sortkey ':frames))
`(wormhole t 'accumulatedpersistence
,sortkey
'(pprogn
(io? temporary nil state
nil
(fms "Accumulated Persistence~% :frames :tries :ratio ~
rune~%~*0"
(list (cons #\0
(showaccumulatedpersistencephrase
(fgetglobal 'wormholeinput state)
(cddr (fgetglobal 'wormholeoutput state)))))
*standardco*
state nil))
(value :q))
:ldprompt nil
:ldpreevalfilter :all
:ldpreevalprint nil
:ldpostevalprint :commandconventions
:ldevisctuple nil
:lderrortriples t
:lderroraction :error
:ldquerycontrolalist nil
:ldverbose nil))
(defun pushaccp ()
(assignwormholeoutput
wormholeoutput
'accumulatedpersistence
nil
'(let ((trip (fgetglobal 'wormholeoutput state)))
(list* (1+ (car trip)) ;;; new cnt
(cons (car trip) ;;; new stack
(cadr trip))
(cddr trip))))) ;;; old totals
(defun popaccp (rune)
(assignwormholeoutput
wormholeoutput
'accumulatedpersistence
rune
'(let ((rune (fgetglobal 'wormholeinput state))
(trip (fgetglobal 'wormholeoutput state)))
(list* (car trip) ;;; old cnt
(cdr (cadr trip)) ;;; new stack
(addaccumulatedpersistence ;;; new totals
rune
( (car trip)
(car (cadr trip)))
(cddr trip))))))
(defmacro withaccumulatedpersistence (rune vars body)
`(let ((withaccumulatedpersistencerune ,rune))
(prog2$
(pushaccp)
,(cond ((and (truelistp vars)
(= (length vars) 1))
`(let ((,(car vars)
(checkvarsnotfree
(withaccumulatedpersistencerune)
,body)))
(prog2$
(popaccp withaccumulatedpersistencerune)
,(car vars))))
(t `(mvlet ,vars
(checkvarsnotfree
(withaccumulatedpersistencerune)
,body)
(prog2$
(popaccp withaccumulatedpersistencerune)
(mv ,@vars))))))))
;; RAG  Changed the assumptions based on rational to realp.
(defun assumetruefalse<
(notflg arg1 arg2 ts1 ts2 typealist ttree xttree w)
; This function returns an extended typealist by assuming (< ts1 ts2) true if
; notflg is nil, but assuming (< ts1 ts2) false if notflg is not nil. It
; assumes that typeset (and hence typeset<) was not able to decide the truth
; or falsity of (< ts1 ts2). We could put this code inline in
; assumetruefalse, but the `truetypealist' and `falsetypealist' are dealt
; with symmetrically, so it's convenient to share code via this function.
; Here are the cases we handle. In this sketch we are glib about the
; possibility that arg1 or arg2 is nonnumeric or complex, but our code handles
; the more general situation.
; When we assume (< arg1 arg2) true,
; * if arg1 is positive then arg2 is positive
; * if arg1 is in the nonnegatives then arg2 is strictly positive
; * if arg2 is in the nonpositives then arg1 is strictly negative
; When we say "arg1 is in the nonnegatives" we mean to include the
; case where arg1 is strictly positive. Note also that if arg1 may be
; negative, then arg2 could be anything (given that we've made the
; normalization for integers above). Thus, the above two cases are as
; strong as we can be.
; When we assume (< arg1 arg2) false we find it easier to think about
; assuming (<= arg2 arg1) true:
; * if arg1 is negative, then arg2 is negative
; * if arg1 is nonpositive, then arg2 is nonpositive
; * if arg2 is nonnegative, then arg1 is nonnegative
; Note that if arg1 may be positive then arg2 could be anything, so
; there are no other cases we can express.
(cond
((and
(not notflg)
(tssubsetp ts1
(tsunion #+:nonstandardanalysis
*tsnonnegativereal*
#:nonstandardanalysis
*tsnonnegativerational*
(tscomplement *tsacl2number*)))
(tsintersectp
ts2
(tscomplement
#+:nonstandardanalysis
(tsunion *tspositivereal* *tscomplex*)
#:nonstandardanalysis
(tsunion *tspositiverational* *tscomplexrational*))))
; The test says: We are dealing with (< arg1 arg2) where arg1 is nonnegative
; or a nonnumber. We are thus allowed to deduce that arg2 is strictly
; positive or complex. That is, we may delete the nonpositive reals
; and nonnumbers from its existing typeset. If that doesn't change
; anything, we don't want to do it, so we have the third conjunct above that
; says arg2 contains some nonpositive reals or some nonnumbers.
; A worry is that the intersection below is empty. Can that happen? If it
; did, then we would have that arg1 is a nonnegative real or a nonnumber,
; and arg2 is a nonpositive real or a nonnumber. Supposedly typeset<
; would have then reported that (< arg1 arg2) must be false and mbf would be t.
; So the empty intersection cannot arise.
(extendtypealist
;;*** simple
arg2
(tsintersection ts2
#+:nonstandardanalysis
(tsunion *tspositivereal* *tscomplex*)
#:nonstandardanalysis
(tsunion *tspositiverational* *tscomplexrational*))
(constagtrees ttree xttree)
typealist w))
; The remaining cases are analogous to that above.
((and (not notflg)
(tssubsetp ts2
(tsunion #+:nonstandardanalysis
*tsnonpositivereal*
#:nonstandardanalysis
*tsnonpositiverational*
(tscomplement *tsacl2number*)))
(tsintersectp
ts1
(tscomplement
#+:nonstandardanalysis
(tsunion *tsnegativereal* *tscomplex*)
#:nonstandardanalysis
(tsunion *tsnegativerational* *tscomplexrational*))))
(extendtypealist
;;*** simple
arg1
(tsintersection ts1
#+:nonstandardanalysis
(tsunion *tsnegativereal* *tscomplex*)
#:nonstandardanalysis
(tsunion *tsnegativerational*
*tscomplexrational*))
(constagtrees ttree xttree)
typealist w))
((and notflg
(tssubsetp ts1
#+:nonstandardanalysis
*tsnegativereal*
#:nonstandardanalysis
*tsnegativerational*)
(tsintersectp ts2
#+:nonstandardanalysis
(tscomplement (tsunion *tscomplex*
*tsnegativereal*))
#:nonstandardanalysis
(tscomplement (tsunion *tscomplexrational*
*tsnegativerational*))))
; We are dealing with (not (< arg1 arg2)) which is (<= arg2 arg1) and we here
; know that arg1 is negative. Thus, arg2 must be negative or complex. See the
; case below for more details.
(extendtypealist
;;*** simple
arg2
(tsintersection ts2
#+:nonstandardanalysis
(tsunion *tscomplex*
*tsnegativereal*)
#:nonstandardanalysis
(tsunion *tscomplexrational*
*tsnegativerational*))
(constagtrees ttree xttree)
typealist w))
((and notflg
(tssubsetp ts1
(tsunion #+:nonstandardanalysis
*tsnonpositivereal*
#:nonstandardanalysis
*tsnonpositiverational*
(tscomplement *tsacl2number*)))
(tsintersectp ts2
#+:nonstandardanalysis
*tspositivereal*
#:nonstandardanalysis
*tspositiverational*))
; Here we are dealing with (not (< arg1 arg2)) which is (<= arg2 arg1). We
; know arg1 is <= 0. We will thus deduce that arg2 is <= 0, and hence not a
; positive real, if we don't already know it. But the worry again arises
; that the intersection of arg2's known type and the complement of the
; positivereals is empty. Suppose it were. Then arg2 is a strictly
; positive real. But if arg1 is a nonpositive real or a nonnumber
; and arg2 is a positive real, then typeset< knows that (< arg1 arg2) is
; true. Thus, this worry is again baseless.
(extendtypealist
;;*** simple
arg2
(tsintersection
ts2
(tscomplement #+:nonstandardanalysis *tspositivereal*
#:nonstandardanalysis *tspositiverational*))
(constagtrees ttree xttree)
typealist w))
((and notflg
(tssubsetp ts2
#+:nonstandardanalysis *tspositivereal*
#:nonstandardanalysis *tspositiverational*)
(tsintersectp ts1
(tscomplement
#+:nonstandardanalysis
(tsunion *tscomplex* *tspositivereal*)
#:nonstandardanalysis
(tsunion *tscomplexrational*
*tspositiverational*))))
(extendtypealist
;;*** simple
arg1
(tsintersection
ts1
#+:nonstandardanalysis
(tsunion *tscomplex* *tspositivereal*)
#:nonstandardanalysis
(tsunion *tscomplexrational*
*tspositiverational*))
(constagtrees ttree xttree)
typealist w))
((and notflg
(tssubsetp
ts2
(tscomplement
#+:nonstandardanalysis
(tsunion *tscomplex* *tsnegativereal*)
#:nonstandardanalysis
(tsunion *tscomplexrational*
*tsnegativerational*)))
(tsintersectp ts1
#+:nonstandardanalysis *tsnegativereal*
#:nonstandardanalysis *tsnegativerational*))
(extendtypealist
;;*** simple
arg1
(tsintersection
ts1
(tscomplement #+:nonstandardanalysis *tsnegativereal*
#:nonstandardanalysis *tsnegativerational*))
(constagtrees ttree xttree)
typealist w))
(t typealist)))
(defun mvatf2 (notflg truetypealist falsetypealist
newterm xnotflg x sharedttree xttree ignore)
; This function is a variation of mvatf in which mbt, mbf, ttree1,
; and ttree2 are all known to be nil. The scenario is that there is
; an implicit term that we want to assume true or false, and we have
; generated two other terms x and newterm to assume true or false
; instead, each with its own parity (xnotflg and notflg,
; respectively). We want to avoid putting redundant information on
; the typealist, which would happen if we are not careful in the case
; that x and newterm are the same term modulo their respective
; parities.
; The tag tree sharedttree justifies truth or falsity of newterm
; while xttree justifies truth or falsity of x.
; We assume that newterm is not a call of NOT.
; Ignore is :tta or :fta if we do not care about the value of truetypealist
; or falsetypealist that is passed in (and may get passed out in the opposite
; position, due to notflg).
(let ((tta0 (and (not (eq ignore :tta))
(extendtypealistsimple
newterm
*tst*
sharedttree
truetypealist)))
(fta0 (and (not (eq ignore :fta))
(extendtypealistsimple
newterm
*tsnil*
sharedttree
falsetypealist)))
(sameparity (eq notflg xnotflg)))
(cond
((equal newterm ; newterm is not a call of NOT, so we negate x
(cond (sameparity x)
(t (dumbnegatelit x))))
(mvatf notflg nil nil tta0 fta0 nil nil))
(t
(let ((tta1 (extendtypealistsimple
x
(if sameparity *tst* *tsnil*)
xttree
tta0))
(fta1 (extendtypealistsimple
x
(if sameparity *tsnil* *tst*)
xttree
fta0)))
(mvatf notflg nil nil tta1 fta1 nil nil))))))
(defun bindinghypp (hyp alist wrld)
; Returns (mv forcep flg), where forcep is true if we have a call of force or
; casesplit, in which case we consider the argument of that call for flg. Flg
; indicates whether we have a call (equiv var term), where var is a free
; variable with respect to alist (typically a unifying substitution, but we
; only look at the cars) that we want to bind. Starting with Version_2.9.4, we
; allow equiv to be an equivalence relation other than equal; however, to
; preserve existing proofs (in other words, to continue to allow kinds of
; equivalential reasoning done in the past), we only allow binding in the
; nonequal case when the righthand side is a call of doublerewrite, which
; may well be what is desired anyhow.
; Starting with Version_2.7, we try all bindings of free variables. Moreover,
; in the case that there are free variables, we formerly first looked in the
; typealist before considering the special case of (equal v term) where v is
; free and term has no free variables. Starting with Version_2.7 we avoid
; considerations of free variables when this special case arises, by handling
; it first.
(let* ((forcep (and (nvariablep hyp)
(not (fquotep hyp))
(or (eq (ffnsymb hyp) 'force)
(eq (ffnsymb hyp) 'casesplit))))
(hyp (if forcep (fargn hyp 1) hyp))
(eqp (equalityp hyp)))
(mv forcep
(cond (eqp (and (variablep (fargn hyp 1))
(not (assoceq (fargn hyp 1) alist))
(not (freevarsp (fargn hyp 2) alist))))
(t
; We want to minimize the cost of the checks below. In particular, we do the
; variablep check before the more expensive equivalencerelationp check (which
; can call getprop).
(and (nvariablep hyp)
(not (fquotep hyp))
(fargs hyp)
(variablep (fargn hyp 1))
(equivalencerelationp (ffnsymb hyp) wrld)
(let ((arg2 (fargn hyp 2)))
(and (not (assoceq (fargn hyp 1) alist))
(nvariablep arg2)
(not (fquotep arg2))
(eq (ffnsymb arg2) 'doublerewrite)
(not (freevarsp arg2 alist))))))))))
(defmacro adjustignoreforatf (notflg ignore)
; Here, we rebind ignore to indicate which typealist (tta or fta) is
; irrelevant for passing into a function that will swap them if and only if
; notflg is true.
`(cond ((and ,notflg (eq ,ignore :fta)) :tta)
((and ,notflg (eq ,ignore :tta)) :fta)
(t ,ignore)))
(mutualrecursion
(defun typeset (x forceflg dwp typealist ancestors ens w ttree
potlst pt)
":DocSection Miscellaneous
how type information is encoded in ACL2~/
To help you experiment with typesets we briefly note the following
utility functions.
~c[(typesetquote x)] will return the typeset of the object ~c[x]. For
example, ~c[(typesetquote \"test\")] is ~c[2048] and
~c[(typesetquote '(a b c))] is ~c[512].
~c[(typeset 'term nil nil nil nil (ens state) (w state) nil nil nil)] will
return the typeset of ~c[term]. For example,
~bv[]
(typeset '(integerp x) nil nil nil nil (ens state) (w state) nil nil nil)
~ev[]
will return (mv 192 nil). 192, otherwise known as ~c[*tsboolean*],
is the typeset containing ~c[t] and ~c[nil]. The second result may
be ignored in these experiments. ~c[Term] must be in the
~c[translated], internal form shown by ~c[:]~ilc[trans]. ~l[trans]
and ~pl[term].
~c[(typesetimpliedbyterm 'x nil 'term (ens state)(w state) nil)]
will return the typeset deduced for the variable symbol ~c[x] assuming
the ~c[translated] term, ~c[term], true. The second result may be ignored
in these experiments. For example,
~bv[]
(typesetimpliedbyterm 'v nil '(integerp v)
(ens state) (w state) nil)
~ev[]
returns ~c[11].
~c[(converttypesettoterm 'x ts (ens state) (w state) nil)] will
return a term whose truth is equivalent to the assertion that the
term ~c[x] has typeset ~c[ts]. The second result may be ignored in these
experiments. For example
~bv[]
(converttypesettoterm 'v 523 (ens state) (w state) nil)
~ev[]
returns a term expressing the claim that ~c[v] is either an integer
or a non~c[nil] truelist. ~c[523] is the ~c[logicalor] of ~c[11] (which
denotes the integers) with ~c[512] (which denotes the non~c[nil]
truelists).~/
The ``actual primitive types'' of ACL2 are listed in
~c[*actualprimitivetypes*], whose elements are shown below. Each
actual primitive type denotes a set ~[] sometimes finite and
sometimes not ~[] of ACL2 objects and these sets are pairwise
disjoint. For example, ~c[*tszero*] denotes the set containing 0 while
~c[*tspositiveinteger*] denotes the set containing all of the positive
integers.
~bv[]
*TSZERO* ;;; {0}
*TSPOSITIVEINTEGER* ;;; positive integers
*TSPOSITIVERATIO* ;;; positive noninteger rationals
*TSNEGATIVEINTEGER* ;;; negative integers
*TSNEGATIVERATIO* ;;; negative noninteger rationals
*TSCOMPLEXRATIONAL* ;;; complex rationals
*TSNIL* ;;; {nil}
*TST* ;;; {t}
*TSNONTNONNILSYMBOL* ;;; symbols other than nil, t
*TSPROPERCONS* ;;; nullterminated nonempty lists
*TSIMPROPERCONS* ;;; conses that are not proper
*TSSTRING* ;;; strings
*TSCHARACTER* ;;; characters
~ev[]
The actual primitive types were chosen by us to make theorem proving
convenient. Thus, for example, the actual primitive type ~c[*tsnil*]
contains just ~c[nil] so that we can encode the hypothesis ``~c[x] is ~c[nil]''
by saying ``~c[x] has type ~c[*tsnil*]'' and the hypothesis ``~c[x] is
non~c[nil]'' by saying ``~c[x] has type complement of ~c[*tsnil*].'' We
similarly devote a primitive type to ~c[t], ~c[*tst*], and to a third type,
~c[*tsnontnonnilsymbol*], to contain all the other ACL2 symbols.
Let ~c[*tsother*] denote the set of all Common Lisp objects other than
those in the actual primitive types. Thus, ~c[*tsother*] includes such
things as floating point numbers and CLTL array objects. The actual
primitive types together with ~c[*tsother*] constitute what we call
~c[*universe*]. Note that ~c[*universe*] is a finite set containing one
more object than there are actual primitive types; that is, here we
are using ~c[*universe*] to mean the finite set of primitive types, not
the infinite set of all objects in all of those primitive types.
~c[*Universe*] is a partitioning of the set of all Common Lisp objects:
every object belongs to exactly one of the sets in ~c[*universe*].
Abstractly, a ``typeset'' is a subset of ~c[*universe*]. To say that a
term, ~c[x], ``has typeset ~c[ts]'' means that under all possible
assignments to the variables in ~c[x], the value of ~c[x] is a member of
some member of ~c[ts]. Thus, ~c[(cons x y)] has typeset
~c[{*tspropercons* *tsimpropercons*}]. A term can have more than
one typeset. For example, ~c[(cons x y)] also has the typeset
~c[{*tspropercons* *tsimpropercons* *tsnil*}]. Extraneous types
can be added to a typeset without invalidating the claim that a
term ``has'' that typeset. Generally we are interested in the
smallest typeset a term has, but because the entire theoremproving
problem for ACL2 can be encoded as a typeset question, namely,
``Does ~c[p] have typeset complement of ~c[*tsnil*]?,'' finding the
smallest typeset for a term is an undecidable problem. When we
speak informally of ``the'' typeset we generally mean ``the
typeset found by our heuristics'' or ``the typeset assumed in the
current context.''
Note that if a typeset, ~c[ts], does not contain ~c[*tsother*] as an
element then it is just a subset of the actual primitive types. If
it does contain ~c[*tsother*] it can be obtained by subtracting from
~c[*universe*] the complement of ~c[ts]. Thus, every typeset can be
written as a (possibly complemented) subset of the actual primitive
types.
By assigning a unique bit position to each actual primitive type we
can encode every subset, ~c[s], of the actual primitive types by the
nonnegative integer whose ith bit is on precisely if ~c[s] contains the
ith actual primitive type. The typesets written as the complement
of ~c[s] are encoded as the ~c[twoscomplement] of the encoding of ~c[s]. Those
typesets are thus negative integers. The bit positions assigned to
the actual primitive types are enumerated from ~c[0] in the same order
as the types are listed in ~c[*actualprimitivetypes*]. At the
concrete level, a typeset is an integer between ~c[*mintypeset*] and
~c[*maxtypeset*], inclusive.
For example, ~c[*tsnil*] has bit position ~c[6]. The typeset containing
just ~c[*tsnil*] is thus represented by ~c[64]. If a term has typeset ~c[64]
then the term is always equal to ~c[nil]. The typeset containing
everything but ~c[*tsnil*] is the twoscomplement of ~c[64], which is ~c[65].
If a term has typeset ~c[65], it is never equal to ~c[nil]. By ``always''
and ``never'' we mean under all, or under no, assignments to the
variables, respectively.
Here is a more complicated example. Let ~c[s] be the typeset
containing all of the symbols and the natural numbers. The relevant
actual primitive types, their bit positions and their encodings are:
~bv[]
actual primitive type bit value
*tszero* 0 1
*tspositiveinteger* 1 2
*tsnil* 6 64
*tst* 7 128
*tsnontnonnilsymbol* 8 256
~ev[]
Thus, the typeset ~c[s] is represented by ~c[(+ 1 2 64 128 256)] = ~c[451].
The complement of ~c[s], i.e., the set of all objects other than the
natural numbers and the symbols, is ~c[452]."
; X is a term and typealist is a type alist mapping terms to their typesets
; (and some ttrees) and thus encoding the current assumptions. In a break with
; nqthm, the ACL2 typeset function tracks dependencies among the entries on
; the typealist. In particular, the typealist here contains pairs of the
; form (term ts . ttree), where ttree is a tag tree generally containing 'PT
; tags. (There may be other tags, e.g., 'LEMMA and maybe even 'FCDERIVATION
; during forward chaining.) In nqthm, the typealist contained pairs of the
; form (term . ts). The ttree argument to typeset is an accumulator onto
; which we add all of the ttrees attached to the facts we use from the
; typealist and the wrld. We return two results, the final type set of term
; and a ttree.
; Note: If ancestors is t it means: don't backchain. Act as though
; the literal we're backchaining on is worse than everything in sight.
; This is called the ``tancestors hack'' and is commented upon below.
; Performance Notes:
; Type set was first made to track dependencies  after a fashion 
; during the coding of forward chaining in April, 1990. At that time,
; typeset had an option under which it would not track dependencies
; and that option was often used in rewrite; indeed, the only time
; dependencies were tracked was during setting up of the typealist
; and forward chaining activations in simplifyclause. In addition,
; compound recognizer lemmas were never tracked. The paragraph below
; was written of that version of a ``dependency tracking'' typeset.
; Experiments show that (at the time of this writing) this typeset is
; roughly 30% slower than the typeset ACL2 had immediately before
; this addition. That data was obtained by collecting roughly 70,000
; external calls of typeset that occurred during the proof that
; TAUTOLOGYP is sound and then timing their reevaluation in both
; versions of ACL2 (with appropriate modifications of the typealists
; being passed in). That same experiment led to the surprising fact
; that type set may represent 5075% of the time spent in the prover!
; We have since added full dependency tracking to typeset and have
; adopted the invariants on typealist requiring canonical forms. How
; much these changes slow things down is anyone's guess. Stay tuned.
; The DWP flag
; or
; Performance Notes on the "TypeSet Objective" Idea and Double Whammy
; "DWP" stands for "double whammy flag". It does not affect the
; soundness of the result returned but, when t, makes typeset "try
; harder" to get a narrow type. It was added Feb 7, 1995 and replaces
; a heuristic hack controlling the "double whammy" idea. The
; historical comment below explains.
; I have tried an experiment in which typeset gets the type of x in
; two ways and intersects them. The first way is to look x up on the
; typealist. The second way is to compute it from scratch. Call
; this the "double whammy" approach. Double whammy is the simplest
; case of a more sophisticated typeset that computes a type for x
; relative to some specified "expected type." The idea of that design
; was to have the caller of typeset supply the type it wanted x to
; have and typeset then did a double whammy if the typealist type
; wasn't a subset of the expected type. But that "conditional double
; whammy" idea is hard to implement. For example, suppose you want (
; a) to have a typeset of nonnegative rational. Then when you get
; the typeset of a you should want it to have type nonpositive
; rational. Rather than implement that fine tuned use of the expected
; typeset, I decided simply to implement the double whammy method,
; i.e., always using both ways and intersecting the results. To my
; surprise, the double whammy method is 3 times slower than the
; ordinary typeset. That number was obtained by running nqthm.lisp,
; which ordinarily takes 3460 seconds but which takes 10300 seconds
; under double whammy. I then backed off the full blown double whammy
; and limited its use to the special case where (a) the typeset
; computed from the typealist is negative and (b) forcing is allowed.
; Under these two cases, typeset is about 6% slower than without any
; double whammy processing.
; Why these two cases? Here is the rationale I had, for what it is
; worth. Condition (a) often indicates the type was "nonnil" or
; "anything but a negative", as when you assume (< 0 a) without
; knowing a is rational. Presumably, forcing was disallowed when this
; negative binding was created, since we probably have forced
; hypotheses around to ensure that the guards are met. Therefore, if
; condition (b) is also met, the chances are good that a "from
; scratch" computation will force now and we'll get a better answer.
; The hit rate even with these restrictions is quite unimpressive:
; double whammy changes the looked up type in only 1% of the cases
; where we try it! Of the roughly 4.4 million calls of typeset in
; the nqthm.lisp proofs, 39% of them (1.7 million) find a binding on
; the typealist and therefore check conditions (a) and (b). In
; roughly 90% of the those cases, either the found typeset is
; negative or forcing is disallowed and so double whammy is not used.
; In only 176000 calls is double whammy even tried. That is only 4%
; of the total number of typeset calls. But of those 176000 attempts
; to use double whammy, in only 2254 cases did it help. That's a 1%
; hit rate on double whammy. Not really impressive. However, one of
; those hits is the case that Bishop reported we couldn't prove and
; now we can. That example is given below just for future reference.
# (progn (defstub foo (x) t)
(defun barp (x)
(consp x))
(intheory (disable barp))
(defaxiom foo>=0
(implies
(force (barp x))
(and (integerp (foo x))
(>= (foo x) 0)))
:ruleclasses :typeprescription)
(defaxiom foobound
(implies
(force (barp x))
(< (foo x) 2))
:ruleclasses (:linear :rewrite)))
(defthm testfootoo
(not (< 1 (foo '(1 . 1)))))#
; The problem is that (foo '(1 . 1)) is given the typeset
; nonnegative anything when we construct the typealist for the
; linear pot, because we do not force the (barp '(1 . 1)). But
; later, when we are in linear we ask whether (foo '(1 . 1)) is an
; integer and, because of double whammy, force the previously unforced
; barp.
; Thus ends the historical comment. Below, where (not dwp) is tested,
; we used to test
; (or (null forceflg) ;;;(b)
; (>= (thetypeset ts0) 0)) ;;;(a)
; This heuristic control on when to double whammy is thwarted by the
; example below. Consider the clause shown below. It ought to be
; decidable by typeset alone because if i is an integerp then (binary+ '1 i)
; is too. But the "irrelevant" hypothesis that (binary+ '1 i) is a rationalp
; messes things up. Let 1+i stand for the binary+ expression.
; (typealistclause '((not (rationalp (binary+ '1 i))) ; lit 1
; (not (integerp i)) ; lit 2
; (integerp (binary+ '1 i))) ; lit 3
; nil nil nil (ens state) (w state))
; We process lit 3 in a typealist generated by assuming lits 1 and 2
; false. In that typealist, 1+i is assumed rational and i is assumed
; integral. When we process lit 3, we get the type of 1+i. Because of
; lit 1, we find it on the typealist with rational type. Because the
; type is nonnegative we do not double whammy. Thus, we miss the
; chance to use lit 2 in computing the type of 1+i. We thus return a
; typealist in which 1+i is assumed to be a ratio (noninteger
; rational) and i is integral.
; However, by arranging for assumetruefalse always to call typeset
; with dwp = t, we make it use double whammy when assuming things.
; That allows us to catch this. Our hope is that it does not slow us
; down too much.
(mvlet
(ts0 ttree0)
(assoctypealist x typealist w)
(cond
((and ts0 (not dwp))
(mv ts0 (constagtrees ttree ttree0)))
(t
(let ((dwp nil))
(cond
((variablep x)
; Warning: You may be tempted to change ttree below to nil on the
; grounds that we are not using any information about x to say its
; type is unknown. But the specification for typeset is that ttree
; is an accumulator. Our caller may have put a lot of work into
; deriving x and passed the associated ttree to typeset in good
; faith. We are obliged to pass it on.
(typesetfinish ts0 ttree0 *tsunknown* ttree))
((fquotep x)
(typesetfinish ts0 ttree0 (typesetquote (cadr x)) ttree))
((flambdaapplicationp x)
; Once upon a time, we tried to do this by using subcorvar to replace
; the actuals by the formals and then take the typeset of the body.
; The old code is shown, commented out, below. But that was bad
; because it duplicated the actuals so often. We now take the
; typeset of the body under a typealist obtained from the actuals.
; We have to be careful to avoid forcing.
(mvlet (ts1 ttree1)
(typeset (lambdabody (ffnsymb x))
nil
dwp
(zipvariabletypealist
(lambdaformals (ffnsymb x))
(typesetlst
(fargs x)
forceflg dwp typealist ancestors ens w
potlst pt))
; Here is the motivation of the tancestors hack. We cannot compare subterms
; of the lambda body to terms on the current ancestors because the lambda
; body should be instantiated with the actuals and it is not. For example
; we might know (p x) on ancestors and go into ((lambda (x) (p x)) a) and
; mistakenly think the body is true because it is on ancestors. (Ancestors
; is not used that way, but the point is made.) So when ancestors is
; set to t it means ignore ancestors and don't backchain. The typeset
; clique is the only nest of functions that treats ancestors that way.
; Here is the one place we initiate the tancestors hack.
t ;;; tancestors hack
ens w ttree potlst pt)
(typesetfinish ts0 ttree0 ts1 ttree1)))
# ((flambdaapplicationp x)
; Note: Once upon a time, assumptions only recorded the term forced and not the
; typealist involved. We could get away with that because rewriteatm would
; recover all the assumptions and force a case split on the whole clause to
; handle them. During those simple days, we treated lambda expressions
; efficiently here, by computing the typeset of the lambdabody under a
; typealist binding the lambdaformals to the types of the actuals.
; Afterwards, we swept the ttree and appropriately instantiated the forced
; terms with the actuals. But when we introduced assumption records, with the
; typealists recorded in them, this design became problematic: we would have
; had to instantiate the :typealists too. Rather than do so, we abandoned
; efficiency here and did the obvious: we expanded lambda applications
; by substituting actuals for formals in the body and computed the typeset
; of the result. This survived until Version 2.6.
#(mvlet (ts1 ttree1)
(typeset (subcorvar (lambdaformals (ffnsymb x))
(fargs x)
(lambdabody (ffnsymb x)))
forceflg
dwp
typealist
ancestors
ens w ttree potlst pt)
(typesetfinish ts0 ttree0 ts1 ttree1))#
; When we introduced the nurewriter, we made clausify no longer
; expand lambdas so aggressively. This meant that typeset began to
; see lot more lambdas. In that environment, the expansion of lambdas
; here was taking lot of time and generating a lot of conses. So now
; we take the efficient AND braindead approach of saying we simply
; don't know anything about a lambda application.
(typesetfinish ts0 ttree0 *tsunknown* ttree))#
((eq (ffnsymb x) 'not)
(mvlet (ts1 ttree1)
(typeset (fargn x 1) forceflg dwp typealist ancestors
ens w ttree potlst pt)
(mvlet (ts1 ttree1)
(typesetnot ts1 ttree1 ttree)
(typesetfinish ts0 ttree0 ts1 ttree1))))
(t
(let* ((fn (ffnsymb x))
(recogtuple
(mostrecentenabledrecogtuple fn
(globalval 'recognizeralist w)
ens)))
(cond
(recogtuple
(mvlet
(ts1 ttree1)
(typeset (fargn x 1) forceflg dwp typealist ancestors
ens w ttree potlst pt)
(mvlet
(ts1 ttree1)
(typesetrecognizer recogtuple ts1 ttree1 ttree)
(mvlet (ts ttree)
(typesetfinish ts0 ttree0 ts1 ttree1)
; At this point, ts is the intersection of the typealist information and the
; recog information. Unless ts is t or nil we also try any typeprescription
; rules we have about this function symbol.
(cond
((or (ts= ts *tst*)
(ts= ts *tsnil*))
(mv ts ttree))
(t
; WARNING: There is another call of typesetwithrules below, in the normal
; case. This call is for the recognizer function case. If you change this
; one, change that one!
(mvlet
(ts2 ttree2)
(typesetwithrules
(getprop fn 'typeprescriptions nil 'currentacl2world w)
x forceflg dwp typealist ancestors ens w
*tsunknown* ttree potlst pt)
(mv (tsintersection ts ts2) ttree2))))))))
((eq fn 'if)
; It is possible that the ifexpression x is on the typealist. It
; would get there if we had gone through an earlier assumetruefalse
; on x, i.e., if we were processing b in (if (if x1 x2 x3) b c). So
; we will compute the typeset of x directly based on its structure
; and then finish as usual by anding it with ts0, the typeset of x
; itself as recorded on the typealist, as appropriate.
(mvlet
(ts1 ttree1)
(mvlet
(mustbetrue
mustbefalse
truetypealist
falsetypealist
ttree1)
(assumetruefalse (fargn x 1)
nil
forceflg
dwp
typealist
ancestors
ens
w
potlst pt nil)
; If mustbetrue or mustbefalse is set, then ttree1 explains the
; derivation of that result. If neither is derived, then ttree1 is
; nil and we can ignore it.
(cond (mustbetrue
(typeset (fargn x 2)
forceflg
dwp
truetypealist
ancestors
ens
w
(constagtrees ttree1 ttree)
potlst pt))
(mustbefalse
(typeset (fargn x 3)
forceflg
dwp
falsetypealist
ancestors
ens
w
(constagtrees ttree1 ttree)
potlst pt))
(t (mvlet (ts1 ttree)
(typeset (fargn x 2)
forceflg
dwp
truetypealist
ancestors
ens
w
ttree
potlst pt)
(mvlet (ts2 ttree)
(typeset (fargn x 3)
forceflg
dwp
falsetypealist
ancestors
ens
w
ttree
potlst pt)
(mv (tsunion ts1 ts2)
ttree))))))
(typesetfinish ts0 ttree0 ts1 ttree1)))
((membereq fn *expandablebootstrapnonrecfns*)
; For these particular functions we actually substitute the actuals
; for the formals into the guarded body and dive into the body to get
; the answer. Typically we will not ever encounter these functions in
; proofs because they will have been expanded away. However, we will
; encounter them during the early typeprescription work and
; preverifyguard work, and so think it is worthwhile to handle them.
(mvlet (ts1 ttree1)
(typeset (subcorvar (formals fn w)
(fargs x)
(body fn t w))
forceflg
dwp
typealist
ancestors
ens
w
ttree
potlst pt)
(typesetfinish ts0 ttree0 ts1 ttree1)))
(t
; Otherwise, we apply all known typeprescriptions and conclude with
; whatever is builtin about fn.
; Note: We do not know that 'typeprescriptions is nonnil. Once upon
; a time we insisted that every fn have a typeprescription. This
; complicated the defun principle because one might encounter the
; unadmitted function symbol in the termination proofs (e.g.,
; mcflatten). So now we are lenient. This happens to be what Nqthm
; does too, and now we know why!
; WARNING: There is another call of typesetwithrules above, in the
; recogtuple case. If you change this one, change that one!
(mvlet (ts1 ttree1)
(typesetwithrules
(getprop fn 'typeprescriptions nil 'currentacl2world w)
x forceflg dwp typealist ancestors ens w
*tsunknown* ttree
potlst pt)
(typesetfinish ts0 ttree0 ts1 ttree1))))))))))))
(defun typesetlst (x forceflg dwp typealist ancestors ens w
potlst pt)
; This function computes the typeset of each element of x, obtaining for each
; a ts and a ttree. It conses the two together and makes a list of those pairs
; in 1:1 correspondence with x. That is, if x is (x1 ... xn) then the answer,
; ans, is ((ts1 . ttree1) ... (tsn . ttreen)). (Stripcars ans) will return a
; list of the type sets and (stripcdrs ans) will return a list of the ttrees.
; Furthermore, if x is a list of variables, (zipvariabletypealist x ans)
; will return a typealist!
(cond
((null x) nil)
(t (mvlet (ts ttree)
(typeset (car x) forceflg dwp typealist ancestors ens w nil
potlst pt)
(cons (cons ts ttree)
(typesetlst (cdr x)
forceflg dwp typealist ancestors ens w
potlst pt))))))
(defun typesetrelievehyps
(rune target hyps forceflg dwp alist typealist ancestors ens wrld ttree ttree0
potlst pt)
; Hyps is a list of terms, implicitly conjoined. Alist is a substitution
; mapping variables in hyps to terms governed by typealist. Consider the
; result, hyps', of substituting alist into each hyp in hyps. We wish to know
; whether, by typeset reasoning alone, we can get that hyps' are all true in
; the context of typealist. We do the substitution one hyp at a time, so we
; don't pay the price of consing up instances beyond the first hyp that fails.
; While we are at it, we record in an extension of typealist the type computed
; for each hyp', so that if subsequent rules need that information, they can
; get it quickly.
; No Change Loser for ttree, but not for typealist.
(cond
((null hyps) (mv t typealist (constagtrees ttree ttree0)))
(t (mvlet
(forcep bindflg)
(bindinghypp (car hyps) alist wrld)
(let ((hyp (if forcep
(fargn (car hyps) 1)
(car hyps))))
(cond
(bindflg
(typesetrelievehyps
rune target (cdr hyps) forceflg dwp
(cons (cons (fargn hyp 1) (fargn hyp 2)) alist)
typealist ancestors ens wrld ttree ttree0
potlst pt))
(t
(mvlet
(lookuphypans alist ttree)
(lookuphyp hyp typealist wrld alist ttree)
(cond
(lookuphypans
(typesetrelievehyps rune
target
(cdr hyps)
forceflg dwp alist
typealist ancestors ens wrld
ttree ttree0
potlst pt))
((freevarsp hyp alist)
(mvlet
(forceflg ttree)
(cond
((not (and forcep forceflg))
(mv nil ttree))
(t (forceassumption
rune
target
(sublisvarandmarkfree alist hyp)
typealist
nil
(immediateforcep (ffnsymb (car hyps)) ens)
forceflg
ttree)))
(cond
(forceflg
(typesetrelievehyps
rune target (cdr hyps) forceflg dwp
alist typealist ancestors ens wrld
ttree ttree0
potlst pt))
(t (mv nil typealist ttree0)))))
(t
(mvlet
(notflg atm)
(stripnot hyp)
(let ((atm1 (sublisvar alist atm)))
; Note that we stripped off the force (or casesplit) symbol if it was
; present. We don't have to do that (given that the typeset of
; (force x) and of (casesplit x) is known to be that of x) but it ought
; to speed things up slightly. Note that we also stripped off the NOT
; if it was present and have notflg and the instantiated atom, atm1,
; to work on. We work on the atom so that we can record its typeset
; in the final typealist, rather than recording the typeset of (NOT
; atm1).
(mvlet
(onancestorsp assumedtrue)
; Here is the one place where we (potentially) use the tancestors
; hack to abort early.
(if (eq ancestors t)
(mv t nil)
(ancestorscheck (if notflg
(mconsterm* 'not atm1)
atm1)
ancestors
(list rune)))
(cond
(onancestorsp
(cond
(assumedtrue
(typesetrelievehyps rune
target
(cdr hyps)
forceflg dwp alist
typealist ancestors ens wrld
ttree ttree0
potlst pt))
(t (mv nil typealist ttree0))))
(t
(mvlet
(ts1 ttree1)
(typeset atm1 forceflg dwp typealist
; We know ancestors is not t here, by the tests above.
(pushancestor
(if notflg
atm1
(mconsterm* 'not atm1))
(list rune)
ancestors)
ens wrld ttree
potlst pt)
(mvlet (temp1 temp2)
(assoctypealist atm1 typealist wrld)
(declare (ignore temp2))
(let ((typealist
(cond ((and temp1 (tssubsetp temp1 ts1))
typealist)
(t (extendtypealist
;;*** simple
atm1 ts1 ttree1 typealist
wrld))))
(ts (if notflg
(cond ((ts= ts1 *tsnil*) *tst*)
((tsintersectp ts1 *tsnil*)
*tsboolean*)
(t *tsnil*))
ts1)))
(cond
((ts= ts *tsnil*) (mv nil typealist ttree0))
((tsintersectp *tsnil* ts)
(mvlet
(forceflg ttree)
(cond
((not (and forceflg forcep))
(mv nil ttree))
(t (forceassumption
rune
target
(if notflg
(mconsterm* 'not atm1)
atm1)
typealist nil
(immediateforcep
(ffnsymb (car hyps))
ens)
forceflg
ttree1)))
(cond
(forceflg
(typesetrelievehyps
rune
target
(cdr hyps)
forceflg dwp alist typealist ancestors
ens wrld ttree ttree0 potlst pt))
(t (mv nil typealist ttree0)))))
(t (typesetrelievehyps rune
target
(cdr hyps)
forceflg dwp alist
typealist ancestors
ens wrld
ttree1 ttree0
potlst
pt)))))))))))))))))))))
(defun extendtypealistwithbindings
(alist forceflg dwp typealist ancestors ens w ttree
potlst pt)
; Alist is an alist that pairs variables in some rule with terms. We compute
; the typeset of each term in the range of alist and extend typealist with
; new entries that pair each term to its typeset.
(cond ((null alist) typealist)
(t (extendtypealistwithbindings
(cdr alist)
forceflg
dwp
(cond ((assocequal (cdr (car alist)) typealist)
typealist)
(t
(mvlet (ts ttree1)
(typeset (cdr (car alist))
forceflg dwp typealist ancestors ens w ttree
potlst pt)
(extendtypealist
;;*** simple
(cdr (car alist)) ts ttree1 typealist w))))
ancestors
ens w ttree
potlst pt))))
(defun typesetwithrule (tp term forceflg dwp typealist ancestors ens w ttree
potlst pt)
; We apply the typeprescription, tp, to term, if possible, and return a
; typeset, an extended typealist and a ttree. If the rule is inapplicable,
; the typeset is *tsunknown* and the ttree is unchanged. Recall that
; typeset treats its ttree argument as an accumulator and we are obliged to
; return an extension of the input ttree.
; Note that the specification of this function is that if we were to take the
; resulting typealist and cons the input ttree on to each ttree in that
; typealist, the resulting typealist would be "appropriate". In particular,
; we don't put ttree into the typealist, but instead we assume that our caller
; will compensate appropriately.
(cond
((enablednumep (access typeprescription tp :nume) ens)
(mvlet
(unifyans unifysubst)
(onewayunify (access typeprescription tp :term)
term)
(cond
(unifyans
(withaccumulatedpersistence
(access typeprescription tp :rune)
(ts typealist ttree)
(let* ((hyps (access typeprescription tp :hyps))
(typealist
(cond
((null hyps) typealist)
(t (extendtypealistwithbindings unifysubst
forceflg
dwp
typealist
ancestors
ens w
; We lie here by passing in the nil tag tree, so that we can avoid
; contaminating the resulting typealist with a copy of ttree. We'll make sure
; that ttree gets into the answer returned by typealistwithrules, which is
; the only function that calls typesetwithrule.
nil
potlst pt)))))
(mvlet
(relievehypsans typealist ttree)
(typesetrelievehyps (access typeprescription tp :rune)
term
hyps
forceflg dwp
unifysubst
typealist
ancestors
ens w
; We pass in nil here to avoid contaminating the typealist returned by this
; call of typesetrelievehyps.
nil
ttree
potlst pt)
(cond
(relievehypsans
(typesetwithrule1 unifysubst
(access typeprescription tp :vars)
forceflg
dwp
typealist ancestors ens w
(access typeprescription tp :basicts)
(pushlemma
(access typeprescription tp :rune)
ttree)
potlst pt))
(t (mv *tsunknown* typealist ttree)))))))
(t (mv *tsunknown* typealist ttree)))))
(t (mv *tsunknown* typealist ttree))))
(defun typesetwithrule1
(alist vars forceflg dwp typealist ancestors ens w basicts ttree
potlst pt)
; Alist is an alist that maps variables to terms. The terms are in the context
; described by typealist. Vars is a list of variables. We map over the pairs
; in alist unioning into basicts the typesets of those terms whose
; corresponding vars are in vars. We accumulate the ttrees into ttree and
; ultimately return the final basicts, typealist and ttree. The alist
; contains successive formals paired with actuals.
; We are about to return from typesetwithrule with the typeset of
; a term, say (foo x), as indicated by a :typeprescription rule, say
; tsfoo, but we are not quite done yet. On the initial entry to this
; function, basicts and vars are from the corresponding fields of
; tsfoo. Vars is a (possibly empty) subset of the variables in
; tsfoo. The meaning of tsfoo is that the typeset of (foo x) is
; the union of basicts and the types of (the terms bound to) vars.
; See the definition of a typeprescription rule and surrounding
; discussion. (Search for ``defrec typeprescription'' in this file.)
(cond ((null alist) (mv basicts typealist ttree))
((membereq (caar alist) vars)
(mvlet (ts ttree)
(typeset
(cdar alist) forceflg dwp typealist ancestors ens w ttree
potlst pt)
(typesetwithrule1 (cdr alist) vars forceflg dwp
typealist ancestors ens w
(tsunion ts basicts)
ttree
potlst pt)))
(t (typesetwithrule1 (cdr alist) vars forceflg dwp
typealist ancestors ens w
basicts
ttree
potlst pt))))
(defun typesetwithrules (tplst term forceflg dwp typealist ancestors ens
w ts ttree potlst pt)
; We try to apply each typeprescription in tplst, intersecting
; together all the type sets we get and accumulating all the ttrees.
; However, if a rule fails to change the accumulating typeset, we
; ignore its ttree.
(cond
((null tplst)
(mvlet
(ts1 ttree1)
(typesetprimitive term forceflg dwp typealist ancestors ens w ttree
potlst pt)
(let ((ts2 (tsintersection ts1 ts)))
(mv ts2 (if (ts= ts2 ts) ttree ttree1)))))
((tssubsetp ts
(access typeprescription (car tplst) :basicts))
; Our goal is to make the final typeset, ts, as small as possible by
; intersecting it with the typesets returned to the various rules. If ts is
; already smaller than or equal to the :basicts of a rule, there is no point
; in trying that rule: the returned typeset will be at least as large as
; :basicts (it has the :vars types unioned into it) and then when we intersect
; ts with it we'll just get ts back. The original motivation for this
; shortcut was to prevent the waste of time caused by the
; preguardverification typeprescription if the postguardverification rule
; is present.
(typesetwithrules (cdr tplst)
term forceflg dwp typealist ancestors ens w ts ttree
potlst pt))
(t
(mvlet
(ts1 typealist1 ttree1)
(typesetwithrule (car tplst)
term forceflg dwp typealist ancestors ens w ttree
potlst pt)
(let ((ts2 (tsintersection ts1 ts)))
(typesetwithrules (cdr tplst)
term forceflg dwp typealist1 ancestors ens w
ts2
(if (and (ts= ts2 ts)
(equal typealist typealist1))
ttree
ttree1)
potlst pt))))))
;; RAG  I added an entry for floor1, which is the only primitive
;; nonrecognizer function we added for the reals. [Ruben added entries for
;; some other nonstandard primitives too.]
(defun typesetprimitive (term forceflg dwp typealist ancestors ens w ttree0
potlst pt)
; Note that we call our initial ttree ttree0 and we extend it below to ttree as
; we get the types of the necessary arguments. This function should handle
; every nonrecognizer function handled in *primitiveformalsandguards*,
; evfncall, and consterm1, though like consterm1, we also handle NOT.
; Exception: Since codechar is so simple typetheoretically, we handle its
; type set computation with rule codechartype in axioms.lisp. It is
; perfectly acceptable to handle function symbols here that are not handled by
; the functions above. For example, we compute a typeset for length in a
; special manner below, but consterm1 and the others do not know about
; length.
(case (ffnsymb term)
(cons
(mvlet (ts2 ttree)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetcons ts2 ttree ttree0)))
(equal
(cond ((equal (fargn term 1) (fargn term 2))
(mv *tst* ttree0))
(t (mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree
potlst pt)
(typesetequal ts1 ts2 ttree ttree0))))))
(unary
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetunary ts1 ttree ttree0)))
(unary/
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetunary/ ts1 ttree ttree0)))
#+:nonstandardanalysis
(floor1
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetfloor1 ts1 ttree ttree0)))
(denominator
(mv *tspositiveinteger* (puffert ttree0)))
(numerator
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetnumerator ts1 ttree ttree0)))
#+:nonstandardanalysis
(standardnumberp
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetstandardnumberp ts1 ttree ttree0)))
#+:nonstandardanalysis
(standardpart
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetstandardpart ts1 ttree ttree0)))
#+:nonstandardanalysis
(ilargeinteger
(mv *tspositiveinteger* (puffert ttree0)))
(car
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetcar ts1 ttree ttree0)))
(cdr
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetcdr ts1 ttree ttree0)))
(symbolname
(mv *tsstring* (puffert ttree0)))
(symbolpackagename
(mv *tsstring* (puffert ttree0)))
(interninpackageofsymbol
(mvlet (ts1 ttree1)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree2)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
; Note that ttree1 and ttree2 both have ttree0 in them, but ttree2 does not
; have ttree1 in it!
(typesetinterninpackageofsymbol ts1 ts2
ttree1 ttree2
ttree0))))
(pkgwitness
(mv *tssymbol* (puffert ttree0)))
(coerce
(mvlet (ts1 ttree1)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree2)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
; Note that ttree1 and ttree2 both have ttree0 in them, but ttree2 does not
; have ttree1 in it!
(typesetcoerce term ts1 ts2 ttree1 ttree2 ttree0))))
(length
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetlength ts1 ttree ttree0)))
(binary+
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree
potlst pt)
(typesetbinary+ term ts1 ts2 ttree ttree0))))
(binary*
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree
potlst pt)
(typesetbinary* ts1 ts2 ttree ttree0))))
(<
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree
potlst pt)
(typeset< (fargn term 1)
(fargn term 2)
ts1 ts2
typealist ttree ttree0
potlst pt))))
(not
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetnot ts1 ttree ttree0)))
(realpart
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetrealpart ts1 ttree ttree0)))
(imagpart
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetimagpart ts1 ttree ttree0)))
(complex
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(mvlet (ts2 ttree)
(typeset (fargn term 2)
forceflg
dwp
typealist
ancestors
ens
w
ttree
potlst pt)
(typesetcomplex ts1 ts2 ttree ttree0))))
(charcode
(mvlet (ts1 ttree)
(typeset (fargn term 1)
forceflg
dwp
typealist
ancestors
ens
w
ttree0
potlst pt)
(typesetcharcode ts1 ttree ttree0)))
(otherwise (mv *tsunknown* ttree0))))
; MiniEssay on Assumetruefalseif and Implies
; or
; How Strengthening One Part of a Theorem Prover Can Weaken the Whole.
; Normally, when ACL2 rewrites one of the branches of an IF expression,
; it ``knows'' the truth or falsity (as appropriate) of the test. More
; precisely, if x is a term of the form (IF test truebranch falsebranch),
; when ACL2 rewrites truebranch, it can determine that test is true by
; type reasoning alone, and when it rewrites falsebranch it can determine
; that test is false by type reasoning alone. This is certainly what one
; would expect.
; However, previously, if test was such that it would print as (AND
; test1 test2)  so that x would print as (IF (AND test1 test2)
; truebranch falsebranch)  when ACL2 rewrote truebranch it only
; knew that (AND test1 test2) was true  it did not know that test1
; was true nor that test2 was true, but only that their conjunction
; was true. There were also other situations in which ACL2's
; reasoning was weak about the test of an IF expression.
; The function assumetruefalseif was written to correct this problem
; but it caused other problems of its own. This miniessay records
; one of the difficulties encountered and its solution.
; In initial tests with the new assumetruefalseif, more than three
; fourths of the books distributed with ACL2 failed to certify. Upon
; examination it turned out that ACL2 was throwing away many of the
; :use hints as well as some of the results from generalization
; rules. Let us look at a particular example (from inequalities.lisp
; in the arithmetic library):
#(defthm <*rightcancel
(implies (and (rationalp x)
(rationalp y)
(rationalp z))
(iff (< (* x z) (* y z))
(cond
((< 0 z)
(< x y))
((equal z 0)
nil)
(t (< y x)))))
:hints (("Goal" :use
((:instance (:theorem
(implies (and (rationalp a)
(< 0 a)
(rationalp b)
(< 0 b))
(< 0 (* a b))))
(a (abs ( y x)))
(b (abs z)))))))#
; This yields the subgoal:
#(IMPLIES (IMPLIES (AND (RATIONALP (ABS (+ Y ( X))))
(< 0 (ABS (+ Y ( X))))
(RATIONALP (ABS Z))
(< 0 (ABS Z)))
(< 0 (* (ABS (+ Y ( X))) (ABS Z))))
(IMPLIES (AND (RATIONALP X)
(RATIONALP Y)
(RATIONALP Z))
(IFF (< (* X Z) (* Y Z))
(COND ((< 0 Z) (< X Y))
((EQUAL Z 0) NIL)
(T (< Y X))))))#
; Previously, the preprocessclause ledge of the waterfall would
; see this as
#((NOT (IMPLIES (IF (RATIONALP (ABS (BINARY+ Y (UNARY X))))
(IF (< '0 (ABS (BINARY+ Y (UNARY X))))
(IF (RATIONALP (ABS Z))
(< '0 (ABS Z))
'NIL)
