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
|
;;; ses.el --- Simple Emacs Spreadsheet -*- lexical-binding:t -*-
;; Copyright (C) 2002-2025 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Vincent Belaïche <vincentb1@users.sourceforge.net>
;; Keywords: spreadsheet Dijkstra
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; To-do list:
;; * M-w should deactivate the mark.
;; * offer some way to use absolute cell addressing.
;; * Maybe some way to copy a reference to a cell's formula rather than the
;; formula itself.
;; * split (catch 'cycle ...) call back into one or more functions
;; * Use $ or … for truncated fields
;; * M-t to transpose 2 columns.
;; * M-d should kill the cell under point.
;; * C-t to transpose 2 rows.
;; * C-k and M-k should be ses-kill-row and ses-kill-column.
;; * C-o should insert the row below point rather than above?
;; * rows inserted with C-o should inherit formulas from surrounding rows.
;; * Add command to make a range of columns be temporarily invisible.
;; * Allow paste of one cell to a range of cells -- copy formula to each.
;; * Do something about control characters & octal codes in cell print
;; areas. Use string-width?
;; * Input validation functions. How specified?
;; * Faces (colors & styles) in print cells.
;; * Move a column by dragging its letter in the header line.
;; * Left-margin column for row number.
;; * Move a row by dragging its number in the left-margin.
;;; Cycle detection
;; Cycles used to be detected by stationarity of ses--deferred-recalc. This was
;; working fine in most cases, however failed in some cases of several path
;; racing together.
;;
;; The current algorithm is based on Dijkstra's algorithm. The cycle length is
;; stored in some cell property. In order not to reset in all cells such
;; property at each update, the cycle length is stored in this property along
;; with some update attempt id that is incremented at each update. The current
;; update id is ses--Dijkstra-attempt-nb. In case there is a cycle the cycle
;; length diverge to infinite so it will exceed ses--Dijkstra-weight-bound at
;; some point of time that allows detection. Otherwise it converges to the
;; longest path length in the update tree.
;;; Code:
(require 'unsafep)
(require 'macroexp)
(eval-when-compile (require 'cl-lib))
;; Autoloaded, but we have not loaded cl-loaddefs yet.
(declare-function cl-member "cl-seq" (cl-item cl-list &rest cl-keys))
;;----------------------------------------------------------------------------
;; User-customizable variables
;;----------------------------------------------------------------------------
(defgroup ses nil
"Simple Emacs Spreadsheet."
:tag "SES"
:group 'applications
:link '(custom-manual "(ses) Top")
:prefix "ses-"
:version "21.1")
(defcustom ses-initial-size '(1 . 1)
"Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)."
:type '(cons (integer :tag "numrows") (integer :tag "numcols")))
(defcustom ses-initial-column-width 7
"Initial width of columns in a new spreadsheet."
:type '(integer :match (lambda (widget value) (> value 0))))
(defcustom ses-initial-default-printer "%.7g"
"Initial default printer for a new spreadsheet."
:type '(choice string
(list :tag "Parenthesized string" string)
function))
(defcustom ses-after-entry-functions '(forward-char)
"Things to do after entering a value into a cell.
An abnormal hook that usually runs a cursor-movement function.
Each function is called with ARG=1."
:type 'hook
:options '(forward-char backward-char next-line previous-line))
(defcustom ses-mode-hook nil
"Hook functions to be run upon entering SES mode."
:type 'hook)
(defcustom ses-jump-cell-name-function #'upcase
"Function to process the string passed to function `ses-jump'.
Set it to `identity' to make no change.
Set it to `upcase' to make cell name change case isensitive.
May return
* a string, in this case this must be a cell name.
* a (row . col) cons cell, in this case that must be valid cell coordinates."
:type 'function)
(defcustom ses-jump-prefix-function #'ses-jump-prefix
"Function that takes the prefix argument passed to function `ses-jump'.
It may return the same sort of thing as `ses-jump-cell-name-function'."
:type 'function)
;;----------------------------------------------------------------------------
;; Global variables and constants
;;----------------------------------------------------------------------------
(defvar ses-read-cell-history nil
"List of formulas that have been typed in.")
(defvar ses-read-printer-history nil
"List of printer functions that have been typed in.")
(easy-menu-define ses-header-line-menu nil
"Context menu when mouse-3 is used on the header-line in an SES buffer."
'("SES header row"
["Set current row" ses-set-header-row t]
["Unset row" ses-unset-header-row (> ses--header-row 0)]))
(defconst ses-mode-map
(let ((keys `("\C-c\M-\C-l" ses-reconstruct-all
"\C-c\C-l" ses-recalculate-all
"\C-c\C-n" ses-renarrow-buffer
"\C-c\C-c" ses-recalculate-cell
"\C-c\M-\C-s" ses-sort-column
"\C-c\M-\C-h" ses-set-header-row
"\C-c\C-t" ses-truncate-cell
"\C-c\C-j" ses-jump
"\C-c\C-p" ses-read-default-printer
"\M-\C-l" ses-reprint-all
[?\S-\C-l] ses-reprint-all
[header-line down-mouse-3] ,ses-header-line-menu
[header-line mouse-2] ses-sort-column-click))
(newmap (make-sparse-keymap)))
(while keys
(define-key (1value newmap) (car keys) (cadr keys))
(setq keys (cddr keys)))
newmap)
"Local keymap for Simple Emacs Spreadsheet.")
(easy-menu-define ses-menu ses-mode-map
"Menu bar menu for SES."
'("SES"
["Insert row" ses-insert-row (ses-in-print-area)]
["Delete row" ses-delete-row (ses-in-print-area)]
["Insert column" ses-insert-column (ses-in-print-area)]
["Delete column" ses-delete-column (ses-in-print-area)]
["Set column printer" ses-read-column-printer t]
["Set column width" ses-set-column-width t]
["Set default printer" ses-read-default-printer t]
["Jump to cell" ses-jump t]
["Set cell printer" ses-read-cell-printer t]
["Recalculate cell" ses-recalculate-cell t]
["Truncate cell display" ses-truncate-cell t]
["Export values" ses-export-tsv t]
["Export formulas" ses-export-tsf t]))
(defconst ses-completion-keys '("\M-\C-i" "\C-i")
"List for keys that can be used for completion while editing.")
(defvar ses--completion-table nil
"Set globally to what completion table to use depending on type
of completion (local printers, cells, etc.). We need to go
through a local variable to pass the SES buffer local variable
to completing function while the current buffer is the
minibuffer.")
(defvar ses--list-orig-buffer nil
"Calling buffer for SES listing help.
Used for listing local printers or renamed cells.")
(defconst ses-mode-edit-map
(let ((keys '("\C-c\C-r" ses-insert-range
"\C-c\C-s" ses-insert-ses-range
[S-mouse-3] ses-insert-range-click
[C-S-mouse-3] ses-insert-ses-range-click
"\C-h\C-p" ses-list-local-printers
"\C-h\C-n" ses-list-named-cells
"\M-\C-i" lisp-complete-symbol)) ; redefined
; dynamically in
; editing
; functions
(newmap (make-sparse-keymap)))
(set-keymap-parent newmap minibuffer-local-map)
(while keys
(define-key newmap (pop keys) (pop keys)))
newmap)
"Local keymap for SES minibuffer cell-editing.")
;Local keymap for SES print area
(defalias 'ses-mode-print-map
(let ((keys '([backtab] backward-char
[tab] ses-forward-or-insert
"\C-i" ses-forward-or-insert ; Needed for ses-coverage.el?
"\M-o" ses-insert-column
"\C-o" ses-insert-row
"\C-m" ses-edit-cell
"\M-k" ses-delete-column
"\M-y" ses-yank-pop
"\C-k" ses-delete-row
"\C-j" ses-append-row-jump-first-column
"\M-h" ses-mark-row
"\M-H" ses-mark-column
"\C-d" ses-clear-cell-forward
"\C-?" ses-clear-cell-backward
"(" ses-read-cell
"\"" ses-read-cell
"'" ses-read-symbol
"=" ses-edit-cell
"c" ses-recalculate-cell
"j" ses-jump
"p" ses-read-cell-printer
"t" ses-truncate-cell
"w" ses-set-column-width
"x" ses-export-keymap
"\M-p" ses-read-column-printer))
(numeric "0123456789.-")
(newmap (make-keymap)))
;;Get rid of printables
(suppress-keymap newmap t)
;;These keys insert themselves as the beginning of a numeric value
(dotimes (x (length numeric))
(define-key newmap (substring numeric x (1+ x)) #'ses-read-cell))
(define-key newmap [remap clipboard-kill-region] #'ses-kill-override)
(define-key newmap [remap end-of-line] #'ses-end-of-line)
(define-key newmap [remap kill-line] #'ses-delete-row)
(define-key newmap [remap kill-region] #'ses-kill-override)
(define-key newmap [remap open-line] #'ses-insert-row)
;;Define our other local keys
(while keys
(define-key newmap (car keys) (cadr keys))
(setq keys (cddr keys)))
newmap))
;;Helptext for ses-mode wants keymap as variable, not function
(defconst ses-mode-print-map (symbol-function 'ses-mode-print-map))
;;Key map used for 'x' key.
(defalias 'ses-export-keymap
(let ((map (make-sparse-keymap "SES export")))
(define-key map "T" (cons " tab-formulas" 'ses-export-tsf))
(define-key map "t" (cons " tab-values" 'ses-export-tsv))
map))
(defconst ses-print-data-boundary "\n\014\n"
"Marker string denoting the boundary between print area and data area.")
(defconst ses-initial-global-parameters
"\n( ;Global parameters (these are read first)\n 2 ;SES file-format\n 1 ;numrows\n 1 ;numcols\n)\n\n"
"Initial contents for the three-element list at the bottom of the data area.")
(defconst ses-initial-global-parameters-re
"\n( ;Global parameters (these are read first)\n [23] ;SES file-format\n [0-9]+ ;numrows\n [0-9]+ ;numcols\n\\( [0-9]+ ;numlocprn\n\\)?)\n\n"
"Match Global parameters for .")
(defconst ses-initial-file-trailer
";; Local Variables:\n;; mode: ses\n;; End:\n"
"Initial contents for the file-trailer area at the bottom of the file.")
(defconst ses-initial-file-contents
(concat " \n" ; One blank cell in print area.
ses-print-data-boundary
"(ses-cell A1 nil nil nil nil)\n" ; One blank cell in data area.
"\n" ; End-of-row terminator for the one row in data area.
"(ses-column-widths [7])\n"
"(ses-column-printers [nil])\n"
"(ses-default-printer \"%.7g\")\n"
"(ses-header-row 0)\n"
ses-initial-global-parameters
ses-initial-file-trailer)
"The initial contents of an empty spreadsheet.")
(defconst ses-box-prop '(:box (:line-width 2 :style released-button))
"Display properties to create a raised box for cells in the header line.")
(defconst ses-standard-printer-functions
'(ses-center
ses-center-span ses-dashfill ses-dashfill-span
ses-tildefill-span
ses-prin1)
"List of print functions to be included in initial history of printer functions.
None of these standard-printer functions, except function
`ses-prin1', is suitable for use as a column printer or a
global-default printer because they invoke the column or default
printer and then modify its output.")
;;----------------------------------------------------------------------------
;; Local variables and constants
;;----------------------------------------------------------------------------
(eval-and-compile
(defconst ses-localvars
'(ses--blank-line ses--cells ses--col-printers
ses--col-widths ses--curcell ses--curcell-overlay
ses--default-printer
(ses--local-printer-hashmap . :hashmap)
(ses--numlocprn . 0); count of local printers
ses--deferred-narrow ses--deferred-recalc
ses--deferred-write ses--file-format
ses--named-cell-hashmap
(ses--header-hscroll . -1) ; Flag for "initial recalc needed"
ses--header-row ses--header-string ses--linewidth
ses--numcols ses--numrows ses--symbolic-formulas
ses--data-marker ses--params-marker (ses--Dijkstra-attempt-nb . 0)
ses--Dijkstra-weight-bound
;; This list is useful for clean-up of symbols when an area
;; containing renamed cell is deleted.
ses--in-killing-named-cell-list
;; Global variables that we override
next-line-add-newlines transient-mark-mode)
"Buffer-local variables used by SES."))
(defmacro ses--\,@ (exp) (declare (debug t)) (macroexp-progn (eval exp t)))
(ses--\,@
(mapcar (lambda (x) `(defvar ,(or (car-safe x) x))) ses-localvars))
(defun ses-set-localvars ()
"Set buffer-local and initialize some SES variables."
(dolist (x ses-localvars)
(cond
((symbolp x)
(set (make-local-variable x) nil))
((consp x)
(cond
((integerp (cdr x))
(set (make-local-variable (car x)) (cdr x)))
((eq (cdr x) :hashmap)
(set (make-local-variable (car x)) (make-hash-table :test 'eq)))
(t (error "Unexpected initializer `%S' in list `ses-localvars' for entry %S"
(cdr x) (car x)) ) ))
(t (error "Unexpected elements `%S' in list `ses-localvars'" x)))))
;;; This variable is documented as being permitted in file-locals:
(put 'ses--symbolic-formulas 'safe-local-variable #'consp)
(defconst ses-paramlines-plist
'(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3
ses--header-row -2 ses--file-format 1 ses--numrows 2
ses--numcols 3 ses--numlocprn 4)
"Offsets from \"Global parameters\" line to various parameter lines in the
data area of a spreadsheet.")
(defconst ses-paramfmt-plist
'(ses--col-widths "(ses-column-widths %S)"
ses--col-printers "(ses-column-printers %S)"
ses--default-printer "(ses-default-printer %S)"
ses--header-row "(ses-header-row %S)"
ses--file-format " %S ;SES file-format"
ses--numrows " %S ;numrows"
ses--numcols " %S ;numcols"
ses--numlocprn " %S ;numlocprn")
"Formats of \"Global parameters\" various parameters in the data
area of a spreadsheet.")
;;
;; "Side-effect variables". They are set in one function, altered in
;; another as a side effect, then read back by the first, as a way of
;; passing back more than one value. These declarations are just to make
;; the compiler happy, and to conform to standard Emacs Lisp practice (I
;; think the make-local-variable trick above is cleaner).
;;
(defvar ses-relocate-return nil
"Set by `ses-relocate-formula' and `ses-relocate-range', read by
`ses-relocate-all'. Set to `delete' if a cell-reference was deleted from a
formula--so the formula needs recalculation. Set to `range' if the size of a
`ses-range' was changed--so both the formula's value and list of dependents
need to be recalculated.")
(defvar ses-call-printer-return nil
"Set to t if last cell printer invoked by `ses-call-printer' requested
left-justification of the result. Set to error-signal if `ses-call-printer'
encountered an error during printing. Otherwise nil.")
(defvar ses-start-time nil
"Time when current operation started.
Used by `ses--time-check' to decide when to emit a progress
message.")
;;----------------------------------------------------------------------------
;; Macros
;;----------------------------------------------------------------------------
(defmacro ses-get-cell (row col)
"Return the cell structure that stores information about cell (ROW,COL)."
(declare (debug t))
`(aref (aref ses--cells ,row) ,col))
(cl-defstruct (ses-cell
(:constructor nil)
(:constructor ses-make-cell
(&optional symbol formula printer references))
(:copier nil)
;; This is treated as an 4-elem array in various places.
;; Mostly in ses-set-cell.
(:type vector) ;Not named.
(:conc-name ses-cell--))
symbol formula printer references properties)
(cl-defstruct (ses--locprn
(:constructor)
(:constructor ses-make-local-printer-info
(def &optional (compiled (ses-local-printer-compile def))
(number ses--numlocprn))))
def
compiled
number
local-printer-list)
(defmacro ses-cell-symbol (row &optional col)
"Return symbol of the local-variable holding value of CELL or pair (ROW,COL).
For example, (0,0) => A1."
(declare (debug t))
`(ses-cell--symbol ,(if col `(ses-get-cell ,row ,col) row)))
(put 'ses-cell-symbol 'safe-function t)
(defmacro ses-cell-formula (row &optional col)
"From a CELL or a pair (ROW,COL), get the function that computes its value."
(declare (debug t))
`(ses-cell--formula ,(if col `(ses-get-cell ,row ,col) row)))
(defmacro ses-cell-printer (row &optional col)
"From a CELL or a pair (ROW,COL), get the function that prints its value."
(declare (debug t))
`(ses-cell--printer ,(if col `(ses-get-cell ,row ,col) row)))
(defmacro ses-cell-references (row &optional col)
"From a CELL or a pair (ROW,COL), get the list of symbols for cells whose
functions refer to its value."
(declare (debug t))
`(ses-cell--references ,(if col `(ses-get-cell ,row ,col) row)))
(defmacro ses-sym-rowcol (sym)
"From a cell-symbol SYM, gets the cons (row . col). A1 => (0 . 0).
Result is nil if SYM is not a symbol that names a cell."
(declare (debug t))
`(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell))))
(if (eq rc :ses-named)
(and ses--named-cell-hashmap (gethash ,sym ses--named-cell-hashmap))
rc)))
(defun ses-cell-p (cell)
"Return non-nil if CELL is a cell of current buffer."
(and (vectorp cell)
(= (length cell) 5)
(eq cell (let ((rowcol (ses-sym-rowcol (ses-cell-symbol cell))))
(and (consp rowcol)
(ses-get-cell (car rowcol) (cdr rowcol)))))))
(defun ses-plist-delq (plist prop)
"Return PLIST after deleting the first pair (if any) with symbol PROP.
This can alter PLIST."
(cond
((null plist) nil)
((eq (car plist) prop) (cddr plist))
(t (let* ((plist-1 (cdr plist))
(plist-2 (cdr plist-1)))
(setcdr plist-1 (ses-plist-delq plist-2 prop))
plist))))
(defvar ses--ses-buffer-list nil "A list of buffers containing a SES spreadsheet.")
(defun ses--unbind-cell-name (name)
"Make NAME non longer a renamed cell name."
(remhash name ses--named-cell-hashmap)
(kill-local-variable name)
;; remove symbol property 'ses-cell from symbol NAME, unless this
;; symbol is also a renamed cell name in another SES buffer.
(let (used-elsewhere (buffer-list ses--ses-buffer-list) buf)
(while buffer-list
(setq buf (pop buffer-list))
(cond
((eq buf (current-buffer)))
;; This case should not happen, some SES buffer has been
;; killed without the ses-killbuffer-hook being called.
((null (buffer-live-p buf))
;; Silently repair ses--ses-buffer-list
(setq ses--ses-buffer-list (delq buf ses--ses-buffer-list)))
(t
(with-current-buffer buf
(when (gethash name ses--named-cell-hashmap)
(setq used-elsewhere t
buffer-list nil))))))
(unless used-elsewhere
(setplist name (ses-plist-delq (symbol-plist name) 'ses-cell))) ))
(defmacro ses--letref (vars place &rest body)
(declare (indent 2) (debug (sexp form body)))
(gv-letplace (getter setter) place
`(cl-macrolet ((,(nth 0 vars) () ',getter)
(,(nth 1 vars) (v) (funcall ',setter v)))
,@body)))
(defmacro ses-cell-property (property-name row &optional col)
"Get property named PROPERTY-NAME from a CELL or a pair (ROW,COL).
When COL is omitted, CELL=ROW is a cell object. When COL is
present ROW and COL are the integer coordinates of the cell of
interest."
(declare (debug t))
`(alist-get ,property-name
(ses-cell--properties
,(if col `(ses-get-cell ,row ,col) row))))
(defmacro ses-cell-property-pop (property-name row &optional col)
"From a CELL or a pair (ROW,COL), get and remove the property value of
the corresponding cell with name PROPERTY-NAME."
`(ses--letref (pget pset)
(alist-get ,property-name
(ses-cell--properties
,(if col `(ses-get-cell ,row ,col) row))
nil t)
(prog1 (pget) (pset nil))))
(defmacro ses-cell-value (row &optional col)
"From a CELL or a pair (ROW,COL), get the current value for that cell."
(declare (debug t))
`(symbol-value (ses-cell-symbol ,row ,col)))
(defmacro ses-col-width (col)
"Return the width for column COL."
(declare (debug t))
`(aref ses--col-widths ,col))
(defmacro ses-col-printer (col)
"Return the default printer for column COL."
(declare (debug t))
`(aref ses--col-printers ,col))
(defun ses-is-cell-sym-p (sym)
"Check whether SYM point at a cell of this spread sheet."
(and (symbolp sym)
(local-variable-p sym)
(let ((rowcol (get sym 'ses-cell)))
(and rowcol
(if (eq rowcol :ses-named)
(and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap))
(and (< (car rowcol) ses--numrows)
(< (cdr rowcol) ses--numcols)
(eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym)))))))
(defun ses--cell (sym value formula printer references)
"Load a cell SYM from the spreadsheet file.
Does not recompute VALUE from FORMULA, does not reprint using
PRINTER, does not check REFERENCES. Safety-checking for FORMULA
and PRINTER are deferred until first use."
(let ((rowcol (ses-sym-rowcol sym)))
(ses-formula-record formula)
(ses-printer-record printer)
(unless (or formula (eq value '*skip*))
(setq formula (macroexp-quote value)))
(or (atom formula)
(eq safe-functions t)
(setq formula `(ses-safe-formula ,formula)))
(or (not printer)
(stringp printer)
(eq safe-functions t)
(setq printer `(ses-safe-printer ,printer)))
(setf (ses-get-cell (car rowcol) (cdr rowcol))
(ses-make-cell sym formula printer references)))
(set sym value))
(defun ses-local-printer-compile (printer)
"Convert local printer function into faster printer definition."
(cond
((functionp printer) printer)
((stringp printer)
`(lambda (x)
(if (null x) ""
(format ,printer x))))
((stringp (car-safe printer))
`(lambda (x)
(if (null x) ""
(setq ses-call-printer-return t)
(format ,(car printer) x))))
(t (error "Invalid printer %S" printer))))
(defun ses--local-printer (name def)
"Define a local printer with name NAME and definition DEF.
Return the printer info."
(or
(and (symbolp name)
(ses-printer-validate def))
(error "Invalid local printer definition"))
(and (gethash name ses--local-printer-hashmap)
(error "Duplicate printer definition %S" name))
(add-to-list 'ses-read-printer-history (symbol-name name))
(puthash name
(ses-make-local-printer-info (ses-safe-printer def))
ses--local-printer-hashmap))
(defmacro ses-column-widths (widths)
"Load the vector of column widths from the spreadsheet file.
This is a macro to prevent propagate-on-load viruses."
(or (and (vectorp widths) (= (length widths) ses--numcols))
(error "Bad column-width vector"))
;;To save time later, we also calculate the total width of each line in the
;;print area (excluding the terminating newline)
(setq ses--col-widths widths
ses--linewidth (apply #'+ -1 (mapcar #'1+ widths))
ses--blank-line (concat (make-string ses--linewidth ?\s) "\n"))
t)
(defmacro ses-column-printers (printers)
"Load the vector of column printers from the spreadsheet file and check
them for safety. This is a macro to prevent propagate-on-load viruses."
(or (and (vectorp printers) (= (length printers) ses--numcols))
(error "Bad column-printers vector"))
(dotimes (x ses--numcols)
(aset printers x (ses-safe-printer (aref printers x))))
(setq ses--col-printers printers)
(mapc #'ses-printer-record printers)
t)
(defmacro ses-default-printer (def)
"Load the global default printer from the spreadsheet file and check it
for safety. This is a macro to prevent propagate-on-load viruses."
(setq ses--default-printer (ses-safe-printer def))
(ses-printer-record def)
t)
(defmacro ses-header-row (row)
"Load the header row from the spreadsheet file and check it for safety.
This is a macro to prevent propagate-on-load viruses."
(or (and (wholenump row) (or (zerop ses--numrows) (< row ses--numrows)))
(error "Bad header-row"))
(setq ses--header-row row)
t)
(defmacro ses-dorange (curcell &rest body)
"Execute BODY repeatedly, with the variables `row' and `col' set to each
cell in the range specified by CURCELL. The range is available in the
variables `minrow', `maxrow', `mincol', and `maxcol'."
(declare (indent defun) (debug (form body)))
(let ((cur (make-symbol "cur"))
(min (make-symbol "min"))
(max (make-symbol "max"))
(r (make-symbol "r"))
(c (make-symbol "c")))
`(let* ((,cur ,curcell)
(,min (ses-sym-rowcol (if (consp ,cur) (car ,cur) ,cur)))
(,max (ses-sym-rowcol (if (consp ,cur) (cdr ,cur) ,cur))))
(let ((minrow (car ,min))
(maxrow (car ,max))
(mincol (cdr ,min))
(maxcol (cdr ,max)))
(if (or (> minrow maxrow) (> mincol maxcol))
(error "Empty range"))
(dotimes (,r (- maxrow minrow -1))
(let ((row (+ ,r minrow)))
(dotimes (,c (- maxcol mincol -1))
(let ((col (+ ,c mincol)))
,@body))))))))
;;----------------------------------------------------------------------------
;; Utility functions
;;----------------------------------------------------------------------------
(defun ses-vector-insert (array idx new)
"Create a new vector which is one larger than ARRAY and has NEW inserted
before element IDX."
(let* ((len (length array))
(result (make-vector (1+ len) new)))
(dotimes (x len)
(aset result
(if (< x idx) x (1+ x))
(aref array x)))
result))
;;Allow ARRAY to be a symbol for use in buffer-undo-list
(defun ses-vector-delete (array idx count)
"Create a new vector which is a copy of ARRAY with COUNT objects removed
starting at element IDX. ARRAY is either a vector or a symbol whose value
is a vector--if a symbol, the new vector is assigned as the symbol's value."
(let* ((a (if (arrayp array) array (symbol-value array)))
(len (- (length a) count))
(result (make-vector len nil)))
(dotimes (x len)
(aset result x (aref a (if (< x idx) x (+ x count)))))
(if (symbolp array)
(set array result))
result))
(defun ses-delete-line (count)
"Like `kill-line', but no kill ring."
(let ((pos (point)))
(forward-line count)
(delete-region pos (point))))
(defun ses-printer-validate (printer)
"Signal an error if PRINTER is not a valid SES cell printer."
(or (not printer)
(stringp printer)
;; printer is a local printer
(and (symbolp printer) (gethash printer ses--local-printer-hashmap))
(functionp printer)
(and (stringp (car-safe printer)) (not (cdr printer)))
(error "Invalid printer function %S" printer))
printer)
(defun ses-printer-record (printer)
"Add PRINTER to `ses-read-printer-history' if not already there, after first
checking that it is a valid printer function."
(ses-printer-validate printer)
;;To speed things up, we avoid calling prin1 for the very common "nil" case.
(if printer
(add-to-list 'ses-read-printer-history (prin1-to-string printer))))
(defun ses-formula-record (formula)
"If FORMULA is of the form \\='SYMBOL, add it to the list of symbolic formulas
for this spreadsheet."
(and (ses-is-cell-sym-p formula)
(cl-pushnew (symbol-name formula) ses--symbolic-formulas :test #'string=)))
(defun ses-column-letter (col)
"Return the alphabetic name of column number COL.
0-25 become A-Z; 26-701 become AA-ZZ, and so on."
(let ((units (char-to-string (+ ?A (% col 26)))))
(if (< col 26)
units
(concat (ses-column-letter (1- (/ col 26))) units))))
(defun ses-create-cell-symbol (row col)
"Produce a symbol that names the cell (ROW,COL). (0,0) => A1."
(intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
(defun ses-decode-cell-symbol (str)
"Decode a symbol \"A1\" => (0,0).
Return nil if STR is not a canonical cell name."
(let (case-fold-search)
(and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str)
(let* ((col-str (match-string-no-properties 1 str))
(col 0)
(col-base 1)
(col-idx (1- (length col-str)))
(row (1- (string-to-number
(match-string-no-properties 2 str)))))
(and (>= row 0)
(progn
(while
(progn
(setq col (+ col (* (- (aref col-str col-idx) ?A)
col-base))
col-base (* col-base 26)
col-idx (1- col-idx))
(and (>= col-idx 0)
(setq col (+ col col-base)))))
(cons row col)))))))
(defun ses-create-cell-variable-range (minrow maxrow mincol maxcol)
"Create buffer-local variables for cells. This is undoable."
(push `(apply ses-destroy-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
buffer-undo-list)
(let (sym xrow xcol)
(dotimes (row (1+ (- maxrow minrow)))
(dotimes (col (1+ (- maxcol mincol)))
(setq xrow (+ row minrow)
xcol (+ col mincol)
sym (ses-create-cell-symbol xrow xcol))
(put sym 'ses-cell (cons xrow xcol))
(make-local-variable sym)))))
(defun ses-create-cell-variable (sym row col)
"Create a buffer-local variable `SYM' for cell at position (ROW, COL).
SYM is the symbol for that variable, ROW and COL are integers for
row and column of the cell, with numbering starting from 0.
Return nil in case of failure."
(unless (local-variable-p sym)
(make-local-variable sym)
(if (let (case-fold-search) (string-match-p "\\`[A-Z]+[0-9]+\\'" (symbol-name sym)))
(put sym 'ses-cell (cons row col))
(put sym 'ses-cell :ses-named)
(setq ses--named-cell-hashmap (or ses--named-cell-hashmap (make-hash-table :test 'eq)))
(puthash sym (cons row col) ses--named-cell-hashmap))))
;; We do not delete the ses-cell properties for the cell-variables, in
;; case a formula that refers to this cell is in the kill-ring and is
;; later pasted back in.
(defun ses-destroy-cell-variable-range (minrow maxrow mincol maxcol)
"Destroy buffer-local variables for cells. This is undoable."
(let (sym)
(dotimes (row (1+ (- maxrow minrow)))
(dotimes (col (1+ (- maxcol mincol)))
(let ((xrow (+ row minrow)) (xcol (+ col mincol)))
(setq sym (if (and (< xrow ses--numrows) (< xcol ses--numcols))
(ses-cell-symbol xrow xcol)
(ses-create-cell-symbol xrow xcol))))
(if (boundp sym)
(push `(apply ses-set-with-undo ,sym ,(symbol-value sym))
buffer-undo-list))
(kill-local-variable sym))))
(push `(apply ses-create-cell-variable-range ,minrow ,maxrow ,mincol ,maxcol)
buffer-undo-list))
(defun ses-reset-header-string ()
"Flag the header string for update.
Upon undo, the header string will be updated again."
(push '(apply ses-reset-header-string) buffer-undo-list)
(setq ses--header-hscroll -1))
;;Split this code off into a function to avoid coverage-testing difficulties
(defmacro ses--time-check (format &rest args)
"If `ses-start-time' is more than a second ago, call `message' with FORMAT
and ARGS and reset `ses-start-time' to the current time."
`(when (time-less-p 1 (time-since ses-start-time))
(message ,format ,@args)
(setq ses-start-time (float-time))))
;;----------------------------------------------------------------------------
;; The cells
;;----------------------------------------------------------------------------
(defmacro ses-set-cell (row col field val)
"Install VAL as the contents for field FIELD (named by a quoted symbol) of
cell (ROW,COL). This is undoable. The cell's data will be updated through
`post-command-hook'."
(macroexp-let2 nil row row
(macroexp-let2 nil col col
(macroexp-let2 nil val val
`(let* ((cell (ses-get-cell ,row ,col))
(change
,(let ((field (progn (cl-assert (eq (car field) 'quote))
(cadr field))))
(if (eq field 'value)
`(ses-set-with-undo (ses-cell-symbol cell) ,val)
;; (let* ((slots (get 'ses-cell 'cl-struct-slots))
;; (slot (or (assq field slots)
;; (error "Unknown field %S" field)))
;; (idx (- (length slots)
;; (length (memq slot slots)))))
;; `(ses-aset-with-undo cell ,idx ,val))
(let ((getter (intern-soft (format "ses-cell--%s" field))))
`(ses-setter-with-undo
(eval-when-compile
(cons #',getter
(lambda (newval cell)
(setf (,getter cell) newval))))
,val cell))))))
(if change
(add-to-list 'ses--deferred-write (cons ,row ,col)))
nil))))) ; Make coverage-tester happy.
(defun ses-cell-set-formula (row col formula)
"Store a new formula for (ROW . COL) and enqueue the cell for
recalculation via `post-command-hook'. Updates the reference lists for the
cells that this cell refers to. Does not update cell value or reprint the
cell. To avoid inconsistencies, this function is not interruptible, which
means Emacs will crash if FORMULA contains a circular list."
(let* ((cell (ses-get-cell row col))
(old (ses-cell-formula cell)))
(let ((sym (ses-cell-symbol cell))
(oldref (ses-formula-references old))
(newref (ses-formula-references formula))
(inhibit-quit t)
not-a-cell-ref-list
x xref xrow xcol)
(cl-pushnew sym ses--deferred-recalc)
;;Delete old references from this cell. Skip the ones that are also
;;in the new list.
(dolist (ref oldref)
(unless (memq ref newref)
;; Because we do not cancel edit when the user provides a
;; false reference in it, then we need to check that ref
;; points to a cell that is within the spreadsheet.
(when
(and (setq x (ses-sym-rowcol ref))
(< (setq xrow (car x)) ses--numrows)
(< (setq xcol (cdr x)) ses--numcols))
;; Cell reference has to be re-written to data area as its
;; reference list is changed.
(cl-pushnew x ses--deferred-write :test #'equal)
(ses-set-cell xrow xcol 'references
(delq sym (ses-cell-references xrow xcol))))))
;;Add new ones. Skip ones left over from old list
(dolist (ref newref)
;;Do not trust the user, the reference may be outside the spreadsheet
(if (and
(setq x (ses-sym-rowcol ref))
(< (setq xrow (car x)) ses--numrows)
(< (setq xcol (cdr x)) ses--numcols))
(unless (memq sym (setq xref (ses-cell-references xrow xcol)))
;; Cell reference has to be re-written to data area as
;; its reference list is changed.
(cl-pushnew x ses--deferred-write :test #'equal)
(ses-set-cell xrow xcol 'references (cons sym xref)))
(cl-pushnew ref not-a-cell-ref-list)))
(ses-formula-record formula)
(ses-set-cell row col 'formula formula)
(and not-a-cell-ref-list
(error "Found in formula cells not in spreadsheet: %S" not-a-cell-ref-list)))))
(defun ses-repair-cell-reference-all ()
"Repair cell reference and warn if there was some reference corruption."
(interactive "*")
(let (errors)
;; Step 1, reset :ses-repair-reference cell property in the whole sheet.
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let ((references (ses-cell-property-pop :ses-repair-reference
row col)))
(when references
(push (list (ses-cell-symbol row col)
:corrupt-property
references)
errors)))))
;; Step 2, build new.
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let* ((cell (ses-get-cell row col))
(sym (ses-cell-symbol cell))
(formula (ses-cell-formula cell))
(new-ref (ses-formula-references formula)))
(dolist (ref new-ref)
(let ((rowcol (ses-sym-rowcol ref)))
(cl-pushnew sym (ses-cell-property :ses-repair-reference
(car rowcol)
(cdr rowcol))))))))
;; Step 3, overwrite with check.
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let* ((cell (ses-get-cell row col))
(irrelevant (ses-cell-references cell))
(new-ref (ses-cell-property-pop :ses-repair-reference cell))
missing)
(dolist (ref new-ref)
(if (memq ref irrelevant)
(setq irrelevant (delq ref irrelevant))
(push ref missing)))
(ses-set-cell row col 'references new-ref)
(when (or missing irrelevant)
(push `( ,(ses-cell-symbol cell)
,@(and missing (list :missing missing))
,@(and irrelevant (list :irrelevant irrelevant)))
errors)))))
(if errors
(warn "----------------------------------------------------------------
Some references were corrupted.
The following is a list where each element ELT is such
that (car ELT) is the reference of cell CELL with corruption,
and (cdr ELT) is a property list where
* property `:corrupt-property' means that
property `:ses-repair-reference' of cell CELL was initially non
nil,
* property `:missing' is a list of missing references
* property `:irrelevant' is a list of non needed references
%S" errors)
(message "No reference corruption found"))))
(defun ses-calculate-cell (row col force)
"Calculate and print the value for cell (ROW,COL) using the cell's formula
function and print functions, if any. Result is nil for normal operation, or
the error signal if the formula or print function failed. The old value is
left unchanged if it was *skip* and the new value is nil.
Any cells that depend on this cell are queued for update after the end of
processing for the current keystroke, unless the new value is the same as
the old and FORCE is nil."
(let ((cell (ses-get-cell row col))
cycle-error formula-error printer-error)
(let ((oldval (ses-cell-value cell))
(formula (ses-cell-formula cell))
newval
this-cell-Dijkstra-attempt+1)
(when (eq (car-safe formula) 'ses-safe-formula)
(setq formula (ses-safe-formula (cadr formula)))
(ses-set-cell row col 'formula formula))
(condition-case sig
(setq newval (eval formula t))
(error
;; Variable `sig' can't be nil.
(nconc sig (list (ses-cell-symbol cell)))
(setq formula-error sig
newval '*error*)))
(if (and (not newval) (eq oldval '*skip*))
;; Don't lose the *skip* --- previous field spans this one.
(setq newval '*skip*))
(catch 'cycle
(when (or force (not (eq newval oldval)))
(cl-pushnew (cons row col) ses--deferred-write :test #'equal) ; In case force=t.
(ses--letref (pget pset)
(ses-cell-property :ses-Dijkstra-attempt cell)
(let ((this-cell-Dijkstra-attempt (pget)))
(if (null this-cell-Dijkstra-attempt)
(pset
(setq this-cell-Dijkstra-attempt
(cons ses--Dijkstra-attempt-nb 0)))
(unless (= ses--Dijkstra-attempt-nb
(car this-cell-Dijkstra-attempt))
(setcar this-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
(setcdr this-cell-Dijkstra-attempt 0)))
(setq this-cell-Dijkstra-attempt+1
(1+ (cdr this-cell-Dijkstra-attempt)))))
(ses-set-cell row col 'value newval)
(dolist (ref (ses-cell-references cell))
(cl-pushnew ref ses--deferred-recalc)
(ses--letref (pget pset)
(let ((ref-rowcol (ses-sym-rowcol ref)))
(ses-cell-property
:ses-Dijkstra-attempt
(car ref-rowcol) (cdr ref-rowcol)))
(let ((ref-cell-Dijkstra-attempt (pget)))
(if (null ref-cell-Dijkstra-attempt)
(pset
(setq ref-cell-Dijkstra-attempt
(cons ses--Dijkstra-attempt-nb
this-cell-Dijkstra-attempt+1)))
(if (= (car ref-cell-Dijkstra-attempt) ses--Dijkstra-attempt-nb)
(setcdr ref-cell-Dijkstra-attempt
(max (cdr ref-cell-Dijkstra-attempt)
this-cell-Dijkstra-attempt+1))
(setcar ref-cell-Dijkstra-attempt ses--Dijkstra-attempt-nb)
(setcdr ref-cell-Dijkstra-attempt
this-cell-Dijkstra-attempt+1)))))
(when (> this-cell-Dijkstra-attempt+1 ses--Dijkstra-weight-bound)
;; Update print of this cell.
(throw 'cycle (setq formula-error
`(error ,(format "Found cycle on cells %S"
(ses-cell-symbol cell)))
cycle-error formula-error)))))))
(setq printer-error (ses-print-cell row col))
(or
(and cycle-error
(error (error-message-string cycle-error)))
formula-error printer-error)))
(defun ses-clear-cell (row col)
"Delete formula and printer for cell (ROW,COL)."
(ses-set-cell row col 'printer nil)
(ses-cell-set-formula row col nil))
(defcustom ses-self-reference-early-detection nil
"Non-nil if cycle detection is early for cells that refer to themselves."
:version "24.1"
:type 'boolean)
(defun ses-update-cells (list &optional force)
"Recalculate cells in LIST, checking for dependency loops.
Print progress messages every second. Dependent cells are not
recalculated if the cell's value is unchanged and FORCE is nil."
(let ((ses--deferred-recalc list)
(nextlist list)
(pos (point))
curlist prevlist this-sym this-rowcol formula)
(with-temp-message " "
(while ses--deferred-recalc
;; In each loop, recalculate cells that refer only to other cells that
;; have already been recalculated or aren't in the recalculation region.
;; Repeat until all cells have been processed or until the set of cells
;; being worked on stops changing.
(if prevlist
(message "Recalculating... (%d cells left)"
(length ses--deferred-recalc)))
(setq curlist ses--deferred-recalc
ses--deferred-recalc nil
prevlist nextlist)
(while curlist
;; this-sym has to be popped from curlist *BEFORE* the check, and not
;; after because of the case of cells referring to themselves.
(setq this-sym (pop curlist)
this-rowcol (ses-sym-rowcol this-sym)
formula (ses-cell-formula (car this-rowcol)
(cdr this-rowcol)))
(or (catch 'ref
(dolist (ref (ses-formula-references formula))
(if (and ses-self-reference-early-detection (eq ref this-sym))
(error "Cycle found: cell %S is self-referring" this-sym)
(when (or (memq ref curlist)
(memq ref ses--deferred-recalc))
;; This cell refers to another that isn't done yet
(cl-pushnew this-sym ses--deferred-recalc :test #'equal)
(throw 'ref t)))))
;; ses-update-cells is called from post-command-hook, so
;; inhibit-quit is implicitly bound to t.
(when quit-flag
;; Abort the recalculation. User will probably undo now.
(error "Quit"))
(ses-calculate-cell (car this-rowcol) (cdr this-rowcol) force)))
(dolist (ref ses--deferred-recalc)
(cl-pushnew ref nextlist :test #'equal)))
(when ses--deferred-recalc
;; Just couldn't finish these.
(dolist (x ses--deferred-recalc)
(let ((this-rowcol (ses-sym-rowcol x)))
(ses-set-cell (car this-rowcol) (cdr this-rowcol) 'value '*error*)
(1value (ses-print-cell (car this-rowcol) (cdr this-rowcol)))))
(error "Circular references: %s" ses--deferred-recalc))
(message " "))
;; Can't use save-excursion here: if the cell under point is updated,
;; save-excursion's marker will move past the cell.
(goto-char pos)))
;;----------------------------------------------------------------------------
;; The print area
;;----------------------------------------------------------------------------
(defun ses-in-print-area ()
"Return t if point is in print area of spreadsheet."
(<= (point) ses--data-marker))
;; We turn off point-motion-hooks and explicitly position the cursor, in case
;; the intangible properties have gotten screwed up (e.g., when ses-goto-print
;; is called during a recursive ses-print-cell).
(defun ses-goto-print (row col)
"Move point to print area for cell (ROW,COL)."
(let ((n 0))
(goto-char (point-min))
(forward-line row)
;; Calculate column position.
(dotimes (c col)
(setq n (+ n (ses-col-width c) 1)))
;; Move to the position.
(and (> n (move-to-column n))
(eolp)
;; Move point to the bol of next line (for TAB at the last cell).
(forward-char))))
(defun ses--cell-at-pos (pos &optional object)
(or (get-text-property pos 'cursor-intangible object)
;; (when (> pos (if object 0 (point-min)))
;; (get-text-property (1- pos) 'cursor-intangible object))
))
(defun ses--curcell (&optional pos)
"Return the current cell symbol, or a cons (BEG,END) for a
region, or nil if cursor is not at a cell."
(unless pos (setq pos (point)))
(if (or (not mark-active)
deactivate-mark
(= pos (mark t)))
;; Single cell.
(ses--cell-at-pos pos)
;; Range.
(let* ((re (max pos (mark t)))
(bcell (ses--cell-at-pos (min pos (mark t))))
(ecell (ses--cell-at-pos (1- re))))
(when (= re ses--data-marker)
;; Correct for overflow.
(setq ecell (ses--cell-at-pos (- (region-end) 2))))
(if (and bcell ecell)
(cons bcell ecell)
nil))))
(defun ses-set-curcell ()
"Set `ses--curcell' to the current cell symbol, or a cons (BEG,END) for a
region, or nil if cursor is not at a cell."
(setq ses--curcell (ses--curcell))
nil)
(defun ses-check-curcell (&rest args)
"Signal an error if `ses--curcell' is inappropriate.
The end marker is appropriate if some argument is `end'.
A range is appropriate if some argument is `range'.
A single cell is appropriate unless some argument is `needrange'."
(ses-set-curcell); fix bug#21054
(cond
((not ses--curcell)
(or (memq 'end args)
(error "Not at cell")))
((consp ses--curcell)
(or (memq 'range args)
(memq 'needrange args)
(error "Can't use a range")))
((memq 'needrange args)
(error "Need a range"))))
(defvar ses--row)
(defvar ses--col)
(defun ses-print-cell (row col)
"Format and print the value of cell (ROW,COL) to the print area.
Use the cell's printer function. If the cell's new print form is too wide,
it will spill over into the following cell, but will not run off the end of the
row or overwrite the next non-nil field. Result is nil for normal operation,
or the error signal if the printer function failed and the cell was formatted
with \"%s\". If the cell's value is *skip*, nothing is printed because the
preceding cell has spilled over."
(catch 'ses-print-cell
(let* ((cell (ses-get-cell row col))
(value (ses-cell-value cell))
(printer (ses-cell-printer cell))
(maxcol (1+ col))
text sig startpos x)
;; Create the string to print.
(cond
((eq value '*skip*)
;; Don't print anything.
(throw 'ses-print-cell nil))
((eq value '*error*)
(setq text (make-string (ses-col-width col) ?#)))
(t
;; Deferred safety-check on printer.
(if (eq (car-safe printer) 'ses-safe-printer)
(ses-set-cell row col 'printer
(setq printer (ses-safe-printer (cadr printer)))))
;; Print the value.
(setq text
(let ((ses--row row)
(ses--col col))
(ses-call-printer (or printer
(ses-col-printer col)
ses--default-printer)
value)))
(if (consp ses-call-printer-return)
;; Printer returned an error.
(setq sig ses-call-printer-return))))
;; Adjust print width to match column width.
(let ((width (ses-col-width col))
(len (string-width text)))
(cond
((< len width)
;; Fill field to length with spaces.
(setq len (make-string (- width len) ?\s)
text (if (eq ses-call-printer-return t)
(concat text len)
(concat len text))))
((> len width)
;; Spill over into following cells, if possible.
(let ((maxwidth width))
(while (and (> len maxwidth)
(< maxcol ses--numcols)
(or (not (setq x (ses-cell-value row maxcol)))
(eq x '*skip*)))
(unless x
;; Set this cell to '*skip* so it won't overwrite our spillover.
(ses-set-cell row maxcol 'value '*skip*))
(setq maxwidth (+ maxwidth (ses-col-width maxcol) 1)
maxcol (1+ maxcol)))
(if (<= len maxwidth)
;; Fill to complete width of all the fields spanned.
(setq text (concat text (make-string (- maxwidth len) ?\s)))
;; Not enough room to end of line or next non-nil field. Truncate
;; if string or decimal; otherwise fill with error indicator.
(setq sig `(error "Too wide" ,text))
(cond
((stringp value)
(setq text (truncate-string-to-width text maxwidth 0 ?\s)))
((and (numberp value)
(string-match "\\.[0-9]+" text)
(>= 0 (setq width
(- len maxwidth
(- (match-end 0) (match-beginning 0))))))
;; Turn 6.6666666666e+49 into 6.66e+49. Rounding is too hard!
(setq text (concat (substring text
0
(- (match-beginning 0) width))
(substring text (match-end 0)))))
(t
(setq text (make-string maxwidth ?#)))))))))
;; Substitute question marks for tabs and newlines. Newlines are used as
;; row-separators; tabs could confuse the reimport logic.
(setq text (replace-regexp-in-string "[\t\n]" "?" text))
(ses-goto-print row col)
(setq startpos (point))
;; Install the printed result. This is not interruptible.
(let ((inhibit-read-only t)
(inhibit-quit t))
(delete-region (point) (progn
(move-to-column (+ (current-column)
(string-width text)))
(1+ (point))))
;; We use concat instead of inserting separate strings in order to
;; reduce the number of cells in the undo list.
(setq x (concat text (if (< maxcol ses--numcols) " " "\n")))
;; We use set-text-properties to prevent a wacky print function from
;; inserting rogue properties, and to ensure that the keymap property is
;; inherited (is it a bug that only unpropertized strings actually
;; inherit from surrounding text?)
(set-text-properties 0 (length x) nil x)
(insert-and-inherit x)
(put-text-property startpos (point) 'cursor-intangible
(ses-cell-symbol cell))
(when (and (zerop row) (zerop col))
;; Reconstruct special beginning-of-buffer attributes.
(put-text-property (point-min) (point) 'keymap 'ses-mode-print-map)
(put-text-property (point-min) (point) 'read-only 'ses)
(put-text-property (point-min) (1+ (point-min))
;; `cursor-intangible' shouldn't be sticky at BOB.
'front-sticky '(read-only keymap))))
(if (= row (1- ses--header-row))
;; This line is part of the header --- force recalc.
(ses-reset-header-string))
;; If this cell (or a preceding one on the line) previously spilled over
;; and has gotten shorter, redraw following cells on line recursively.
(when (and (< maxcol ses--numcols)
(eq (ses-cell-value row maxcol) '*skip*))
(ses-set-cell row maxcol 'value nil)
(ses-print-cell row maxcol))
;; Return to start of cell.
(goto-char startpos)
sig)))
(defun ses-call-printer (printer &optional value)
"Invoke PRINTER (a string or parenthesized string or function-symbol or
lambda of one argument) on VALUE. Result is the printed cell as a string.
The variable `ses-call-printer-return' is set to t if the printer used
parenthesis to request left-justification, or the error-signal if the
printer signaled one (and \"%s\" is used as the default printer), else nil."
(setq ses-call-printer-return nil)
(condition-case signal
(cond
((stringp printer)
(if value
(format printer value)
""))
((stringp (car-safe printer))
(setq ses-call-printer-return t)
(if value
(format (car printer) value)
""))
(t
(setq value
(funcall
(or (and (symbolp printer)
(let ((locprn (gethash printer
ses--local-printer-hashmap)))
(and locprn
(ses--locprn-compiled locprn))))
printer)
value))
(if (stringp value)
value
(or (stringp (car-safe value))
(error "Printer should return \"string\" or (\"string\")"))
(setq ses-call-printer-return t)
(car value))))
(error
(setq ses-call-printer-return signal)
(ses-prin1 value))))
(defun ses-adjust-print-width (col change)
"Insert CHANGE spaces in front of column COL, or at end of line if
COL=NUMCOLS. Deletes characters if CHANGE < 0. Caller should bind
`inhibit-quit' to t."
(let ((inhibit-read-only t)
(blank (if (> change 0) (make-string change ?\s)))
(at-end (= col ses--numcols)))
(ses-set-with-undo 'ses--linewidth (+ ses--linewidth change))
;; ses-set-with-undo always returns t for strings.
(1value (ses-set-with-undo 'ses--blank-line
(concat (make-string ses--linewidth ?\s) "\n")))
(dotimes (row ses--numrows)
(ses-goto-print row col)
(when at-end
;; Insert new columns before newline.
(backward-char 1))
(if blank
(insert blank)
(delete-char (- change))))))
(defun ses-print-cell-new-width (row col)
"Same as `ses-print-cell', except if the cell's value is *skip*,
the preceding nonskipped cell is reprinted. This function is used
when the width of cell (ROW,COL) has changed."
(if (not (eq (ses-cell-value row col) '*skip*))
(ses-print-cell row col)
;;Cell was skipped over - reprint previous
(ses-goto-print row col)
(backward-char 1)
(let ((rowcol (ses-sym-rowcol (ses--cell-at-pos (point)))))
(ses-print-cell (car rowcol) (cdr rowcol)))))
;;----------------------------------------------------------------------------
;; The data area
;;----------------------------------------------------------------------------
(defun ses-widen ()
"Turn off narrowing, to be reenabled at end of command loop."
(if (buffer-narrowed-p)
(setq ses--deferred-narrow t))
(widen))
(defun ses-goto-data (def &optional col)
"Move point to data area for (DEF,COL). If DEF is a row
number, COL is the column number for a data cell -- otherwise DEF
is one of the symbols ses--col-widths, ses--col-printers,
ses--default-printer, ses--numrows, or ses--numcols."
(ses-widen)
(if col
;; It's a cell.
(progn
(goto-char ses--data-marker)
(forward-line (+ 1 (* def (1+ ses--numcols)) col)))
;; Convert def-symbol to offset.
(setq def (plist-get ses-paramlines-plist def))
(or def (signal 'args-out-of-range nil))
(goto-char ses--params-marker)
(forward-line def)))
(defun ses-file-format-extend-parameter-list (new-file-format)
"Extend the global parameters list when file format is updated
from 2 to 3. This happens when local printer function are added
to a sheet that was created with SES version 2. This is not
undoable. Return nil when there was no change, and non-nil otherwise."
(save-excursion
(cond
((and (= ses--file-format 2) (= 3 new-file-format))
(ses-set-parameter 'ses--file-format 3)
(message "Upgrading from SES-2 to SES-3 file format")
(ses-widen)
(goto-char ses--params-marker)
(forward-line (plist-get ses-paramlines-plist 'ses--numlocprn ))
(insert (format (plist-get ses-paramfmt-plist 'ses--numlocprn)
ses--numlocprn)
?\n)
t) )))
(defun ses-set-parameter (def value &optional elem)
"Set parameter DEF to VALUE (with undo) and write the value to the data area.
See `ses-goto-data' for meaning of DEF. Newlines in the data are escaped.
If ELEM is specified, it is the array subscript within DEF to be set to VALUE."
(save-excursion
;; We call ses-goto-data early, using the old values of numrows and numcols
;; in case one of them is being changed.
(ses-goto-data def)
(let ((inhibit-read-only t)
(fmt (plist-get ses-paramfmt-plist
def))
oldval)
(if elem
(progn
(setq oldval (aref (symbol-value def) elem))
(aset (symbol-value def) elem value))
(setq oldval (symbol-value def))
(set def value))
;; Special undo since it's outside the narrowed buffer.
(let (buffer-undo-list)
(delete-region (point) (line-end-position))
(insert (format fmt (symbol-value def))))
(push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list))))
(defun ses-write-cells ()
"Write cells in `ses--deferred-write' from local variables to data area.
Newlines in the data are escaped."
(let* ((inhibit-read-only t)
(print-escape-newlines t)
rowcol row col cell sym formula printer text)
(setq ses-start-time (float-time))
(with-temp-message " "
(save-excursion
(while ses--deferred-write
(ses--time-check "Writing... (%d cells left)"
(length ses--deferred-write))
(setq rowcol (pop ses--deferred-write)
row (car rowcol)
col (cdr rowcol)
cell (ses-get-cell row col)
sym (ses-cell-symbol cell)
formula (ses-cell-formula cell)
printer (ses-cell-printer cell))
(if (eq (car-safe formula) 'ses-safe-formula)
(setq formula (cadr formula)))
(if (eq (car-safe printer) 'ses-safe-printer)
(setq printer (cadr printer)))
(setq text (prin1-to-string
;; We could shorten it to (ses-cell SYM VAL) when
;; the other parameters are nil, but in practice most
;; cells have non-nil `references', so it's
;; rather pointless.
`(ses-cell ,sym
,(symbol-value sym)
,(unless (equal formula (symbol-value sym))
formula)
,printer
,(ses-cell-references cell))))
(ses-goto-data row col)
(let ((inhibit-quit t))
(delete-region (point) (line-end-position))
(insert text))))
(message " "))))
;;----------------------------------------------------------------------------
;; Formula relocation
;;----------------------------------------------------------------------------
(defun ses-formula-references (formula &optional result-so-far)
"Produce a list of symbols for cells that this FORMULA's value
refers to. For recursive calls, RESULT-SO-FAR is the list being
constructed, or t to get a wrong-type-argument error when the
first reference is found."
(if (ses-sym-rowcol formula)
;; Entire formula is one symbol.
(cl-pushnew formula result-so-far :test #'equal)
(if (consp formula)
(cond
((eq (car formula) 'ses-range)
(dolist (cur
(cdr (funcall 'macroexpand
(list 'ses-range (nth 1 formula)
(nth 2 formula)))))
(cl-pushnew cur result-so-far :test #'equal)))
((null (eq (car formula) 'quote))
;;Recursive call for subformulas
(dolist (cur formula)
(setq result-so-far (ses-formula-references cur result-so-far))))
(t
;;Ignore other stuff
))
;; other type of atom are ignored
))
result-so-far)
(defsubst ses-relocate-symbol (sym rowcol startrow startcol rowincr colincr)
"Relocate one symbol SYM, which corresponds to ROWCOL (a cons of ROW and
COL). Cells starting at (STARTROW,STARTCOL) are being shifted
by (ROWINCR,COLINCR)."
(let ((row (car rowcol))
(col (cdr rowcol)))
(if (or (< row startrow) (< col startcol))
sym
(setq row (+ row rowincr)
col (+ col colincr))
(if (and (>= row startrow) (>= col startcol)
(< row ses--numrows) (< col ses--numcols))
;;Relocate this variable, unless it is a named cell
(if (eq (get sym 'ses-cell) :ses-named)
sym
;; otherwise, we create the relocated cell symbol because
;; ses-cell-symbol gives the old symbols, however since
;; renamed cell are not relocated we keep the relocated
;; cell old symbol in this case.
(if (eq (get (setq sym (ses-cell-symbol row col)) 'ses-cell) :ses-named)
sym
(ses-create-cell-symbol row col)))
;;Delete reference to a deleted cell
nil))))
(defun ses-relocate-formula (formula startrow startcol rowincr colincr)
"Produce a copy of FORMULA where all symbols that refer to cells in row
STARTROW or above, and col STARTCOL or above, are altered by adding ROWINCR
and COLINCR. STARTROW and STARTCOL are 0-based. Example:
(ses-relocate-formula \\='(+ A1 B2 D3) 1 2 1 -1)
=> (+ A1 B2 C4)
If ROWINCR or COLINCR is negative, references to cells being deleted are
removed. Example:
(ses-relocate-formula \\='(+ A1 B2 D3) 0 1 0 -1)
=> (+ A1 C3)
Sets `ses-relocate-return' to `delete' if cell-references were removed."
(let (rowcol result)
(if (or (atom formula) (eq (car formula) 'quote))
(if (setq rowcol (ses-sym-rowcol formula))
(ses-relocate-symbol formula rowcol
startrow startcol rowincr colincr)
;; Constants pass through as-is.
formula)
(dolist (cur formula)
(setq rowcol (ses-sym-rowcol cur))
(cond
(rowcol
(setq cur (ses-relocate-symbol cur rowcol
startrow startcol rowincr colincr))
(if cur
(push cur result)
;; Reference to a deleted cell. Set a flag in ses-relocate-return.
;; don't change the flag if it's already 'range, since range implies
;; 'delete.
(unless ses-relocate-return
(setq ses-relocate-return 'delete))))
((eq (car-safe cur) 'ses-range)
(setq cur (ses-relocate-range cur startrow startcol rowincr colincr))
(if cur
(push cur result)))
((or (atom cur) (eq (car cur) 'quote))
;; Constants pass through unchanged.
(push cur result))
(t
;; Recursively copy and alter subformulas.
(push (ses-relocate-formula cur startrow startcol
rowincr colincr)
result))))
(nreverse result))))
(defun ses-relocate-range (range startrow startcol rowincr colincr)
"Relocate one RANGE, of the form (ses-range MIN MAX). Cells starting
at (STARTROW,STARTCOL) are being shifted by (ROWINCR,COLINCR). Result is the
new range, or nil if the entire range is deleted. If new rows are being added
just beyond the end of a row range, or new columns just beyond a column range,
the new rows/columns will be added to the range. Sets `ses-relocate-return'
if the range was altered."
(let* ((minorig (cadr range))
(minrowcol (ses-sym-rowcol minorig))
(min (ses-relocate-symbol minorig minrowcol
startrow startcol
rowincr colincr))
(maxorig (nth 2 range))
(maxrowcol (ses-sym-rowcol maxorig))
(max (ses-relocate-symbol maxorig maxrowcol
startrow startcol
rowincr colincr))
field)
(cond
((and (not min) (not max))
(setq range nil)) ; The entire range is deleted.
((zerop colincr)
;; Inserting or deleting rows.
(setq field 'car)
(if (not min)
;; Chopped off beginning of range.
(setq min (ses-create-cell-symbol startrow (cdr minrowcol))
ses-relocate-return 'range))
(if (not max)
(if (> rowincr 0)
;; Trying to insert a nonexistent row.
(setq max (ses-create-cell-symbol (1- ses--numrows)
(cdr minrowcol)))
;; End of range is being deleted.
(setq max (ses-create-cell-symbol (1- startrow) (cdr minrowcol))
ses-relocate-return 'range))
(and (> rowincr 0)
(= (car maxrowcol) (1- startrow))
(= (cdr minrowcol) (cdr maxrowcol))
;; Insert after ending row of vertical range --- include it.
(setq max (ses-create-cell-symbol (+ startrow rowincr -1)
(cdr maxrowcol))))))
(t
;; Inserting or deleting columns.
(setq field 'cdr)
(if (not min)
;; Chopped off beginning of range.
(setq min (ses-create-cell-symbol (car minrowcol) startcol)
ses-relocate-return 'range))
(if (not max)
(if (> colincr 0)
;; Trying to insert a nonexistent column.
(setq max (ses-create-cell-symbol (car maxrowcol)
(1- ses--numcols)))
;; End of range is being deleted.
(setq max (ses-create-cell-symbol (car maxrowcol) (1- startcol))
ses-relocate-return 'range))
(and (> colincr 0)
(= (cdr maxrowcol) (1- startcol))
(= (car minrowcol) (car maxrowcol))
;; Insert after ending column of horizontal range --- include it.
(setq max (ses-create-cell-symbol (car maxrowcol)
(+ startcol colincr -1)))))))
(when range
(if (/= (- (funcall field maxrowcol)
(funcall field minrowcol))
(- (funcall field (ses-sym-rowcol max))
(funcall field (ses-sym-rowcol min))))
;; This range has changed size.
(setq ses-relocate-return 'range))
`(ses-range ,min ,max ,@(cdddr range)))))
(defun ses-relocate-all (minrow mincol rowincr colincr)
"Alter all cell values, symbols, formulas, and reference-lists to relocate
the rectangle (MINROW,MINCOL)..(NUMROWS,NUMCOLS) by adding ROWINCR and COLINCR
to each symbol."
(let (reform)
(let (mycell newval xrow)
(dotimes-with-progress-reporter
(row ses--numrows) "Relocating formulas..."
(dotimes (col ses--numcols)
(setq ses-relocate-return nil
mycell (ses-get-cell row col)
newval (ses-relocate-formula (ses-cell-formula mycell)
minrow mincol rowincr colincr)
xrow (- row rowincr))
(ses-set-cell row col 'formula newval)
(if (eq ses-relocate-return 'range)
;; This cell contains a (ses-range X Y) where a cell has been
;; inserted or deleted in the middle of the range.
(push (cons row col) reform))
(if ses-relocate-return
;; This cell referred to a cell that's been deleted or is no
;; longer part of the range. We can't fix that now because
;; reference lists cells have been partially updated.
(cl-pushnew (ses-create-cell-symbol row col)
ses--deferred-recalc :test #'equal))
(setq newval (ses-relocate-formula (ses-cell-references mycell)
minrow mincol rowincr colincr))
(ses-set-cell row col 'references newval)
(and (>= row minrow) (>= col mincol)
(let ((sym (ses-cell-symbol row col))
(xcol (- col colincr)))
(if (and
sym
(>= xrow 0)
(>= xcol 0)
;; the following could also be tested as
;; (null (eq sym (ses-create-cell-symbol xrow xcol)))
(eq (get sym 'ses-cell) :ses-named))
;; This is a renamed cell, do not update the cell
;; name, but just update the coordinate property.
(puthash sym (cons row col) ses--named-cell-hashmap)
(ses-set-cell row col 'symbol
(setq sym (ses-create-cell-symbol row col)))
(unless (local-variable-if-set-p sym)
(set (make-local-variable sym) nil)
(put sym 'ses-cell (cons row col)))))) )))
;; Relocate the cell values.
(let (oldval myrow mycol xrow xcol sym)
(cond
((and (<= rowincr 0) (<= colincr 0))
;; Deletion of rows and/or columns.
(dotimes-with-progress-reporter
(row (- ses--numrows minrow)) "Relocating variables..."
(setq myrow (+ row minrow))
(dotimes (col (- ses--numcols mincol))
(setq mycol (+ col mincol)
xrow (- myrow rowincr)
xcol (- mycol colincr)
sym (ses-cell-symbol myrow mycol))
;; We don't need to relocate value for renamed cells, as they keep the same
;; symbol.
(unless (eq (get sym 'ses-cell) :ses-named)
(ses-set-cell myrow mycol 'value
(if (and (< xrow ses--numrows) (< xcol ses--numcols))
(ses-cell-value xrow xcol)
;; Cell is off the end of the array.
(symbol-value (ses-create-cell-symbol xrow xcol)))))))
(when ses--in-killing-named-cell-list
(message "Unbinding killed named cell symbols...")
(setq ses-start-time (float-time))
(while ses--in-killing-named-cell-list
(ses--time-check "Unbinding killed named cell symbols... (%d left)" (length ses--in-killing-named-cell-list))
(ses--unbind-cell-name (pop ses--in-killing-named-cell-list)) )
(message nil)) )
((and (wholenump rowincr) (wholenump colincr))
;; Insertion of rows and/or columns. Run the loop backwards.
(let ((disty (1- ses--numrows))
(distx (1- ses--numcols))
myrow mycol)
(dotimes-with-progress-reporter
(row (- ses--numrows minrow)) "Relocating variables..."
(setq myrow (- disty row))
(dotimes (col (- ses--numcols mincol))
(setq mycol (- distx col)
xrow (- myrow rowincr)
xcol (- mycol colincr)
sym (ses-cell-symbol myrow mycol))
;; We don't need to relocate value for renamed cells, as they keep the same
;; symbol.
(unless (eq (get sym 'ses-cell) :ses-named)
(if (or (< xrow minrow) (< xcol mincol))
;; Newly-inserted value.
(setq oldval nil)
;; Transfer old value.
(setq oldval (ses-cell-value xrow xcol)))
(ses-set-cell myrow mycol 'value oldval))))
t)) ; Make testcover happy by returning non-nil here.
(t
(error "ROWINCR and COLINCR must have the same sign"))))
;; Reconstruct reference lists for cells that contain ses-ranges that have
;; changed size.
(when reform
(message "Fixing ses-ranges...")
(let (row col)
(setq ses-start-time (float-time))
(while reform
(ses--time-check "Fixing ses-ranges... (%d left)" (length reform))
(setq row (caar reform)
col (cdar reform)
reform (cdr reform))
(ses-cell-set-formula row col (ses-cell-formula row col))))
(message nil))))
;;----------------------------------------------------------------------------
;; Undo control
;;----------------------------------------------------------------------------
(defun ses-begin-change ()
"For undo, remember point before we start changing hidden stuff."
(let ((inhibit-read-only t))
(insert-and-inherit "X")
(delete-region (1- (point)) (point))))
(defun ses-setter-with-undo (accessors newval &rest args)
"Set a field/variable and record it so it can be undone.
Result is non-nil if field/variable has changed."
(let ((oldval (apply (car accessors) args)))
(unless (equal-including-properties oldval newval)
(push `(apply ses-setter-with-undo ,accessors ,oldval ,@args)
buffer-undo-list)
(apply (cdr accessors) newval args)
t)))
(defun ses-aset-with-undo (array idx newval)
(ses-setter-with-undo (eval-when-compile
(cons #'aref
(lambda (newval array idx) (aset array idx newval))))
newval array idx))
(defun ses-set-with-undo (sym newval)
(ses-setter-with-undo
(eval-when-compile
(cons (lambda (sym) (if (boundp sym) (symbol-value sym) :ses--unbound))
(lambda (newval sym) (if (eq newval :ses--unbound)
(makunbound sym)
(set sym newval)))))
newval sym))
;;----------------------------------------------------------------------------
;; Startup for major mode
;;----------------------------------------------------------------------------
(defun ses-load ()
"Parse the current buffer and set up buffer-local variables.
Does not execute cell formulas or print functions."
(widen)
;; Read our global parameters, which should be a 3-element list.
(goto-char (point-max))
(search-backward ";; Local Variables:\n" nil t)
(backward-list 1)
(setq ses--params-marker (point-marker))
(let* ((params (ignore-errors (read (current-buffer))))
(params-len (safe-length params)))
(or (and (>= params-len 3)
(<= params-len 4)
(numberp (car params))
(numberp (cadr params))
(>= (cadr params) 0)
(numberp (nth 2 params))
(> (nth 2 params) 0)
(or (<= params-len 3)
(let ((numlocprn (nth 3 params)))
(and (integerp numlocprn) (>= numlocprn 0)))))
(error "Invalid SES file"))
(setq ses--file-format (car params)
ses--numrows (cadr params)
ses--numcols (nth 2 params)
ses--numlocprn (or (nth 3 params) 0))
(when (= ses--file-format 1)
(let (buffer-undo-list) ; This is not undoable.
(ses-goto-data 'ses--header-row)
(insert "(ses-header-row 0)\n")
(ses-set-parameter 'ses--file-format 3)
(message "Upgrading from SES-1 to SES-2 file format")))
(or (<= ses--file-format 3)
(error "This file needs a newer version of the SES library code"))
;; Initialize cell array.
(setq ses--cells (make-vector ses--numrows nil))
(dotimes (row ses--numrows)
(aset ses--cells row (make-vector ses--numcols nil)))
;; initialize local printer map.
(clrhash ses--local-printer-hashmap))
;; Skip over print area, which we assume is correct.
(goto-char (point-min))
(forward-line ses--numrows)
(or (looking-at-p ses-print-data-boundary)
(error "Missing marker between print and data areas"))
(forward-char 1)
(setq ses--data-marker (point-marker))
(forward-char (1- (length ses-print-data-boundary)))
;; Initialize printer and symbol lists.
(mapc #'ses-printer-record ses-standard-printer-functions)
(setq ses--symbolic-formulas nil)
;; Load local printer definitions.
;; This must be loaded *BEFORE* cells and column printers because the latter
;; may call them.
(save-excursion
(forward-line (* ses--numrows (1+ ses--numcols)))
(let ((numlocprn ses--numlocprn))
(setq ses--numlocprn 0)
(dotimes (_ numlocprn)
(let ((x (read (current-buffer))))
(or (and (= (following-char) ?\n)
(eq (car-safe x) 'ses-local-printer)
(apply #'ses--local-printer (cdr x)))
(error "Local printer-def error"))
(setq ses--numlocprn (1+ ses--numlocprn))))))
;; Load cell definitions.
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let* ((x (read (current-buffer)))
(sym (car-safe (cdr-safe x))))
(or (and (= (following-char) ?\n)
(eq (car-safe x) 'ses-cell)
(ses-create-cell-variable sym row col))
(error "Cell-def error"))
(apply #'ses--cell (cdr x))))
(or (looking-at-p "\n\n")
(error "Missing blank line between rows")))
;; Skip local printer function declaration --- that were already loaded.
(forward-line (+ 2 ses--numlocprn))
;; Load global parameters.
(let ((widths (read (current-buffer)))
(n1 (char-after (point)))
(printers (read (current-buffer)))
(n2 (char-after (point)))
(def-printer (read (current-buffer)))
(n3 (char-after (point)))
(head-row (read (current-buffer)))
(n4 (char-after (point))))
(or (and (eq (car-safe widths) 'ses-column-widths)
(= n1 ?\n)
(eq (car-safe printers) 'ses-column-printers)
(= n2 ?\n)
(eq (car-safe def-printer) 'ses-default-printer)
(= n3 ?\n)
(eq (car-safe head-row) 'ses-header-row)
(= n4 ?\n))
(error "Invalid SES global parameters"))
(1value (eval widths t))
(1value (eval def-printer t))
(1value (eval printers t))
(1value (eval head-row t)))
;; Should be back at global-params.
(forward-char 1)
(or (looking-at-p ses-initial-global-parameters-re)
(error "Problem with column-defs or global-params"))
;; Check for overall newline count in definitions area.
(forward-line 3)
(let ((start (point)))
(ses-goto-data 'ses--numrows)
(or (= (point) start)
(error "Extraneous newlines someplace?"))))
(defun ses-setup ()
"Set up for display of only the printed cell values.
Narrows the buffer to show only the print area. Gives it `read-only' and
`intangible' properties. Sets up highlighting for current cell."
(interactive)
(let ((end (point-min))
pos sym)
(with-silent-modifications
(ses-goto-data 0 0) ; Include marker between print-area and data-area.
(set-text-properties (point) (point-max) nil) ; Delete garbage props.
(mapc #'delete-overlay (overlays-in (point-min) (point-max)))
;; The print area is read-only (except for our special commands) and
;; uses a special keymap.
(put-text-property (point-min) (1- (point)) 'read-only 'ses)
(put-text-property (point-min) (1- (point)) 'keymap 'ses-mode-print-map)
;; For the beginning of the buffer, we want the read-only and keymap
;; attributes to be inherited from the first character.
(put-text-property (point-min) (1+ (point-min))
;; `cursor-intangible' shouldn't be sticky at BOB.
'front-sticky '(read-only keymap))
;; Create intangible properties, which also indicate which cell the text
;; came from.
(dotimes-with-progress-reporter (row ses--numrows) "Finding cells..."
(dotimes (col ses--numcols)
(setq pos end
sym (ses-cell-symbol row col))
(unless (eq (symbol-value sym) '*skip*)
;; Include skipped cells following this one.
(while (and (< col (1- ses--numcols))
(eq (ses-cell-value row (1+ col)) '*skip*))
(setq end (+ end (ses-col-width col) 1)
;; Beware: Modifying the iteration variable of `dotimes'
;; may or may not affect the iteration!
col (1+ col)))
(setq end (save-excursion
(goto-char pos)
(move-to-column (+ (current-column) (- end pos)
(ses-col-width col)))
(if (eolp)
(+ end (ses-col-width col) 1)
(forward-char)
(point))))
(put-text-property pos end 'cursor-intangible sym))))))
;; Create the underlining overlay. It's impossible for (point) to be 2,
;; because column A must be at least 1 column wide.
(setq ses--curcell-overlay (make-overlay (1+ (point-min)) (1+ (point-min))))
(overlay-put ses--curcell-overlay 'face 'underline))
(defun ses-cleanup ()
"Cleanup when changing a buffer from SES mode to something else.
Delete overlays, remove special text properties."
(widen)
(let ((inhibit-read-only t)
;; When reverting, hide the buffer name, otherwise Emacs will ask the
;; user "the file is modified, do you really want to make modifications
;; to this buffer", where the "modifications" refer to the irrelevant
;; set-text-properties below.
(buffer-file-name nil)
(was-modified (buffer-modified-p)))
;; Delete read-only, keymap, and intangible properties.
(set-text-properties (point-min) (point-max) nil)
;; Delete overlay.
(mapc #'delete-overlay (overlays-in (point-min) (point-max)))
(unless was-modified
(restore-buffer-modified-p nil))))
(defun ses-killbuffer-hook ()
"Hook when the current buffer is killed."
(setq ses--ses-buffer-list (delq (current-buffer) ses--ses-buffer-list)))
;;;###autoload
(defun ses-mode ()
"Major mode for Simple Emacs Spreadsheet.
When you invoke SES in a new buffer, it is divided into cells
that you can enter data into. You can navigate the cells with
the arrow keys and add more cells with the tab key. The contents
of these cells can be numbers, text, or Lisp expressions. (To
enter text, enclose it in double quotes.)
In an expression, you can use cell coordinates to refer to the
contents of another cell. For example, you can sum a range of
cells with `(+ A1 A2 A3)'. There are specialized functions like
`ses+' (addition for ranges with empty cells), `ses-average' (for
performing calculations on cells), and `ses-range' and `ses-select'
\(for extracting ranges of cells).
Each cell also has a print function that controls how it is
displayed.
Each SES buffer is divided into a print area and a data area.
Normally, you can simply use SES to look at and manipulate the print
area, and let SES manage the data area outside the visible region.
See \"ses-example.ses\" (in `data-directory') for an example
spreadsheet, and the Info node `(ses)Top.'
In the following, note the separate keymaps for cell editing mode
and print mode specifications. Key definitions:
\\{ses-mode-map}
These key definitions are active only in the print area (the visible
part):
\\{ses-mode-print-map}
These are active only in the minibuffer, when entering or editing a
formula:
\\{ses-mode-edit-map}"
(interactive)
(unless (and (boundp 'ses--deferred-narrow)
(eq ses--deferred-narrow 'ses-mode))
(kill-all-local-variables)
(ses-set-localvars)
(setq major-mode 'ses-mode
mode-name "SES"
next-line-add-newlines nil
truncate-lines t
;; SES deliberately puts lots of trailing whitespace in its buffer.
show-trailing-whitespace nil
;; Cell ranges do not work reasonably without this.
transient-mark-mode t
;; Not to use tab characters for safe (tabs may do bad for column
;; calculation).
indent-tabs-mode nil)
(1value (add-hook 'change-major-mode-hook #'ses-cleanup nil t))
(1value (add-hook 'kill-buffer-hook #'ses-killbuffer-hook nil t))
(cl-pushnew (current-buffer) ses--ses-buffer-list :test 'eq)
;; This makes revert impossible if the buffer is read-only.
;; (1value (add-hook 'before-revert-hook 'ses-cleanup nil t))
(setq header-line-format '(:eval (progn
(when (/= (window-hscroll)
ses--header-hscroll)
;; Reset ses--header-hscroll first,
;; to avoid recursion problems when
;; debugging ses-create-header-string
(setq ses--header-hscroll
(window-hscroll))
(ses-create-header-string))
ses--header-string)))
(setq-local mode-line-process '(:eval (ses--mode-line-process)))
(add-hook 'pre-redisplay-functions #'ses--cursor-sensor-highlight
;; Highlight the cell after moving cursor out of intangible.
'append t)
(cursor-intangible-mode 1)
(let ((was-empty (zerop (buffer-size)))
(was-modified (buffer-modified-p)))
(save-excursion
(if was-empty
;; Initialize buffer to contain one cell, for now.
(insert ses-initial-file-contents))
(ses-load)
(ses-setup))
(when was-empty
(unless (equal ses-initial-default-printer
(1value ses--default-printer))
(1value (ses-read-default-printer ses-initial-default-printer)))
(unless (= ses-initial-column-width (1value (ses-col-width 0)))
(1value (ses-set-column-width 0 ses-initial-column-width)))
(ses-set-curcell)
(if (> (car ses-initial-size) (1value ses--numrows))
(1value (ses-insert-row (1- (car ses-initial-size)))))
(if (> (cdr ses-initial-size) (1value ses--numcols))
(1value (ses-insert-column (1- (cdr ses-initial-size)))))
(ses-write-cells)
(restore-buffer-modified-p was-modified)
(buffer-disable-undo)
(buffer-enable-undo)
(goto-char (point-min))))
(use-local-map ses-mode-map)
;; Set the deferred narrowing flag (we can't narrow until after
;; after-find-file completes). If .ses is on the auto-load alist and the
;; file has "mode: ses", our ses-mode function will be called twice! Use a
;; special flag to detect this (will be reset by ses-command-hook). For
;; find-alternate-file, post-command-hook doesn't get run for some reason,
;; so use an idle timer to make sure.
(setq ses--deferred-narrow 'ses-mode)
(1value (add-hook 'post-command-hook #'ses-command-hook nil t))
(run-with-idle-timer 0.01 nil #'ses-command-hook)
(run-mode-hooks 'ses-mode-hook)))
(put 'ses-mode 'mode-class 'special)
(defun ses-command-hook ()
"Invoked from `post-command-hook'. If point has moved to a different cell,
move the underlining overlay. Perform any recalculations or cell-data
writes that have been deferred. If buffer-narrowing has been deferred,
narrow the buffer now."
(condition-case err
(when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore.
(when ses--deferred-recalc
;; We reset the deferred list before starting on the recalc --- in
;; case of error, we don't want to retry the recalc after every
;; keystroke!
(ses-initialize-Dijkstra-attempt)
(let ((old ses--deferred-recalc))
(setq ses--deferred-recalc nil)
(ses-update-cells old)))
(when ses--deferred-write
;; We don't reset the deferred list before starting --- the most
;; likely error is keyboard-quit, and we do want to keep trying these
;; writes after a quit.
(ses-write-cells)
(push '(apply ses-widen) buffer-undo-list))
(when ses--deferred-narrow
;; We're not allowed to narrow the buffer until after-find-file has
;; read the local variables at the end of the file. Now it's safe to
;; do the narrowing.
(narrow-to-region (point-min) ses--data-marker)
(setq ses--deferred-narrow nil)))
;; Prevent errors in this post-command-hook from silently erasing the hook!
(error
(unless executing-kbd-macro
(ding))
(message "%s" (error-message-string err))))
nil) ; Make coverage-tester happy.
(defun ses--mode-line-process ()
(let ((cmlp (window-parameter nil 'ses--mode-line-process))
(curcell (ses--curcell (window-point))))
(if (equal curcell (car cmlp))
(cdr cmlp)
(let ((mlp
(cond
((not curcell) nil)
((atom curcell) (list " cell " (symbol-name curcell)))
(t
(list " range "
(symbol-name (car curcell))
"-"
(symbol-name (cdr curcell)))))))
(set-window-parameter nil 'ses--mode-line-process (cons curcell mlp))
mlp))))
(defun ses--cursor-sensor-highlight (window)
(let ((curcell (ses--curcell))
(ol (window-parameter window 'ses--curcell-overlay)))
(unless ol
(setq ol (make-overlay (point) (point)))
(overlay-put ol 'window window)
(overlay-put ol 'face 'underline)
(set-window-parameter window 'ses--curcell-overlay ol))
;; Use underline overlay for single-cells only, turn off otherwise.
(if (listp curcell)
(delete-overlay ol)
(let* ((pos (window-point window))
(next (next-single-property-change pos 'cursor-intangible)))
(move-overlay ol pos (1- next))))))
(defun ses-create-header-string ()
"Set up `ses--header-string' as the buffer's header line.
Based on the current set of columns and `window-hscroll' position."
(let ((totwidth (- (window-hscroll)))
result width x)
;; Leave room for the left-side fringe and scrollbar.
(push (propertize " " 'display '((space :align-to 0))) result)
(dotimes (col ses--numcols)
(setq width (ses-col-width col)
totwidth (+ totwidth width 1))
(if (= totwidth 1)
;; Scrolled so intercolumn space is leftmost.
(push " " result))
(when (> totwidth 1)
(if (> ses--header-row 0)
(save-excursion
(ses-goto-print (1- ses--header-row) col)
(setq x (buffer-substring-no-properties (point)
(+ (point) width)))
;; Strip trailing space.
(if (string-match "[ \t]+\\'" x)
(setq x (substring x 0 (match-beginning 0))))
;; Cut off excess text.
(if (>= (length x) totwidth)
(setq x (substring x 0 (- totwidth -1)))))
(setq x (ses-column-letter col)))
(push (propertize x 'face ses-box-prop) result)
(push (propertize "."
'display `((space :align-to ,(1- totwidth)))
'face ses-box-prop)
result)
;; Allow the following space to be squished to make room for the 3-D box
;; Coverage test ignores properties, thinks this is always a space!
(push (1value (propertize " " 'display `((space :align-to ,totwidth))))
result)))
(if (> ses--header-row 0)
(push (propertize (format " [row %d]" ses--header-row)
'display '((height (- 1))))
result))
(setq ses--header-string (apply #'concat (nreverse result)))))
;;----------------------------------------------------------------------------
;; Redisplay and recalculation
;;----------------------------------------------------------------------------
(defun ses-jump-prefix (prefix-int)
"Convert an integer (universal prefix) into a (ROW . COL).
Does it by numbering cells starting from 0 from top left to bottom right,
going row by row."
(and (>= prefix-int 0)
(< prefix-int (* ses--numcols ses--numrows))
(cons (/ prefix-int ses--numcols) (% prefix-int ses--numcols))))
(defun ses-jump (&optional sym)
"Move point to cell SYM."
(interactive "P")
(setq sym
(if current-prefix-arg
(funcall ses-jump-prefix-function (prefix-numeric-value sym))
(or sym
(completing-read
"Jump to cell: "
(and ses--named-cell-hashmap
(let (names)
(maphash (lambda (key _val)
(push (symbol-name key) names))
ses--named-cell-hashmap)
names))))))
(and (stringp sym)
(not (and ses--named-cell-hashmap (gethash (intern sym) ses--named-cell-hashmap)))
(setq sym (funcall ses-jump-cell-name-function sym)))
(if (stringp sym)
(if (string= sym "")
(user-error "Empty cell name")
(setq sym (intern sym))))
(let ((rowcol (if (consp sym)
(prog1 sym (setq sym (ses-cell-symbol (car sym) (cdr sym))))
(ses-sym-rowcol sym))))
(or rowcol (error "Invalid cell name"))
(if (eq (symbol-value sym) '*skip*)
(error "Cell is covered by preceding cell"))
(ses-goto-print (car rowcol) (cdr rowcol))))
(defun ses-jump-safe (cell)
"Like `ses-jump', but no error if invalid cell."
(ignore-errors
(ses-jump cell)))
(defun ses-reprint-all (&optional nonarrow)
"Recreate the display area. Call all printer functions.
Narrow to print area if optional argument NONARROW is nil."
(interactive "*P")
(widen)
(unless nonarrow
(setq ses--deferred-narrow t))
(let ((startcell (ses--cell-at-pos (point)))
(inhibit-read-only t))
(ses-begin-change)
(goto-char (point-min))
(search-forward ses-print-data-boundary)
(backward-char (length ses-print-data-boundary))
(delete-region (point-min) (point))
;; Insert all blank lines before printing anything, so ses-print-cell can
;; find the data area when inserting or deleting *skip* values for cells.
(dotimes (_ ses--numrows)
(insert-and-inherit ses--blank-line))
(dotimes-with-progress-reporter (row ses--numrows) "Reprinting..."
(if (eq (ses-cell-value row 0) '*skip*)
;; Column deletion left a dangling skip.
(ses-set-cell row 0 'value nil))
(dotimes (col ses--numcols)
(ses-print-cell row col))
(beginning-of-line 2))
(ses-jump-safe startcell)))
(defun ses-initialize-Dijkstra-attempt ()
(setq ses--Dijkstra-attempt-nb (1+ ses--Dijkstra-attempt-nb)
ses--Dijkstra-weight-bound (* ses--numrows ses--numcols)))
;; These functions use the variables 'row' and 'col' that are dynamically bound
;; by ses-print-cell. We define these variables at compile-time to make the
;; compiler happy.
;; (defvar row)
;; (defvar col)
;; (defvar maxrow)
;; (defvar maxcol)
(defun ses-recalculate-cell (&optional curcell)
"Recalculate and reprint the current cell or range.
If CURCELL is non nil use it as current cell or range
without any check, otherwise function (ses-check-curcell \\='range)
is called.
For an individual cell, shows the error if the formula or printer
signals one, or otherwise shows the cell's complete value. For a range, the
cells are recalculated in \"natural\" order, so cells that other cells refer
to are recalculated first."
(interactive "*")
(if curcell (setq ses--curcell curcell)
(ses-check-curcell 'range))
(ses-begin-change)
(ses-initialize-Dijkstra-attempt)
(let (sig cur-rowcol)
(setq ses-start-time (float-time))
(if (atom ses--curcell)
(when
(setq cur-rowcol (ses-sym-rowcol ses--curcell)
sig (progn
(setf (ses-cell-property :ses-Dijkstra-attempt
(car cur-rowcol)
(cdr cur-rowcol))
(cons ses--Dijkstra-attempt-nb 0))
(ses-calculate-cell (car cur-rowcol) (cdr cur-rowcol) t)))
(nconc sig (list (ses-cell-symbol (car cur-rowcol)
(cdr cur-rowcol)))))
;; First, recalculate all cells that don't refer to other cells and
;; produce a list of cells with references.
(ses-dorange ses--curcell
(ses--time-check "Recalculating... %s" (ses-cell-symbol row col))
(condition-case nil
(progn
;; The t causes an error if the cell has references. If no
;; references, the t will be the result value.
(1value (ses-formula-references (ses-cell-formula row col) t))
(setf (ses-cell-property :ses-Dijkstra-attempt row col)
(cons ses--Dijkstra-attempt-nb 0))
(when (setq sig (ses-calculate-cell row col t))
(nconc sig (list (ses-cell-symbol row col)))))
(wrong-type-argument
;; The formula contains a reference.
(cl-pushnew (ses-cell-symbol row col) ses--deferred-recalc
:test #'equal)))))
;; Do the update now, so we can force recalculation.
(let ((x ses--deferred-recalc))
(setq ses--deferred-recalc nil)
(condition-case hold
(ses-update-cells x t)
(error (setq sig hold))))
(cond
(sig
(message "%s" (error-message-string sig)))
((consp ses--curcell)
(message " "))
(t
(princ (symbol-value ses--curcell))))))
(defun ses-recalculate-all ()
"Recalculate and reprint all cells."
(interactive "*")
(let ((startcell (ses--cell-at-pos (point)))
(ses--curcell (cons (ses-cell-symbol 0 0)
(ses-cell-symbol (1- ses--numrows)
(1- ses--numcols)))))
(ses-recalculate-cell ses--curcell)
(ses-jump-safe startcell)))
(defun ses-truncate-cell ()
"Reprint current cell, but without spillover into any following blank cells."
(interactive "*")
(ses-check-curcell)
(let* ((rowcol (ses-sym-rowcol ses--curcell))
(row (car rowcol))
(col (cdr rowcol)))
(when (and (< col (1- ses--numcols)) ;;Last column can't spill over, anyway
(eq (ses-cell-value row (1+ col)) '*skip*))
;; This cell has spill-over. We'll momentarily pretend the following cell
;; has a t in it.
(cl-progv
(list (ses-cell-symbol row (1+ col)))
'(t)
(ses-print-cell row col))
;; Now remove the *skip*. ses-print-cell is always nil here.
(ses-set-cell row (1+ col) 'value nil)
(1value (ses-print-cell row (1+ col))))))
(defun ses-reconstruct-all ()
"Reconstruct buffer based on cell data stored in Emacs variables."
(interactive "*")
(ses-begin-change)
;;Reconstruct reference lists.
(let (x yrow ycol)
;;Delete old reference lists
(dotimes-with-progress-reporter
(row ses--numrows) "Deleting references..."
(dotimes (col ses--numcols)
(ses-set-cell row col 'references nil)))
;;Create new reference lists
(dotimes-with-progress-reporter
(row ses--numrows) "Computing references..."
(dotimes (col ses--numcols)
(dolist (ref (ses-formula-references (ses-cell-formula row col)))
(setq x (ses-sym-rowcol ref)
yrow (car x)
ycol (cdr x))
(ses-set-cell yrow ycol 'references
(cons (ses-cell-symbol row col)
(ses-cell-references yrow ycol)))))))
;; Delete everything and reconstruct basic data area.
(ses-widen)
(let ((inhibit-read-only t))
(goto-char (point-max))
(if (search-backward ";; Local Variables:\n" nil t)
(delete-region (point-min) (point))
;; Buffer is quite screwed up --- can't even save the user-specified
;; locals.
(delete-region (point-min) (point-max))
(insert ses-initial-file-trailer)
(goto-char (point-min)))
;; Create a blank display area.
(dotimes (_ ses--numrows)
(insert ses--blank-line))
(insert ses-print-data-boundary)
(backward-char (1- (length ses-print-data-boundary)))
(setq ses--data-marker (point-marker))
(forward-char (1- (length ses-print-data-boundary)))
;; Placeholders for cell data.
(insert (make-string (* ses--numrows (1+ ses--numcols)) ?\n))
;; Placeholders for col-widths, col-printers, default-printer, header-row.
(insert "\n\n\n\n")
(insert ses-initial-global-parameters)
(backward-char (1- (length ses-initial-global-parameters)))
(setq ses--params-marker (point-marker))
(forward-char (1- (length ses-initial-global-parameters))))
(ses-set-parameter 'ses--col-widths ses--col-widths)
(ses-set-parameter 'ses--col-printers ses--col-printers)
(ses-set-parameter 'ses--default-printer ses--default-printer)
(ses-set-parameter 'ses--header-row ses--header-row)
(ses-set-parameter 'ses--numrows ses--numrows)
(ses-set-parameter 'ses--numcols ses--numcols)
;;Keep our old narrowing
(ses-setup)
(ses-recalculate-all)
(goto-char (point-min)))
;;----------------------------------------------------------------------------
;; Input of cell formulas
;;----------------------------------------------------------------------------
(defun ses-edit-cell-complete-symbol ()
(interactive)
(let ((completion-at-point-functions (cons 'ses--edit-cell-completion-at-point-function
completion-at-point-functions)))
(completion-at-point)))
(defun ses--edit-cell-completion-at-point-function ()
(and
ses--completion-table
(let* ((bol (save-excursion (move-beginning-of-line nil) (point)))
start end collection
(prefix
(save-excursion
(setq end (point))
(backward-sexp)
(if (< (point) bol)
(progn
(setq start bol)
(buffer-substring start end))
(setq start (point))
(forward-sexp)
(if (>= (point) end)
(progn
(setq end (point))
(buffer-substring start end))
nil))))
prefix-length)
(when (and prefix (null (string= prefix "")))
(setq prefix-length (length prefix))
(maphash (lambda (key _val)
(let ((key-name (symbol-name key)))
(when (and (>= (length key-name) prefix-length)
(string= prefix (substring key-name 0 prefix-length)))
(push key-name collection))))
ses--completion-table)
(and collection (list start end collection))))))
(defun ses-edit-cell (row col newval)
"Display current cell contents in minibuffer, for editing.
Return nil if cell formula was unsafe and user declined confirmation."
(interactive
(progn
(barf-if-buffer-read-only)
(ses-check-curcell)
(let* ((rowcol (ses-sym-rowcol ses--curcell))
(row (car rowcol))
(col (cdr rowcol))
(formula (ses-cell-formula row col))
initial)
(if (eq (car-safe formula) 'ses-safe-formula)
(setq formula (cadr formula)))
(if (eq (car-safe formula) 'quote)
(setq initial (format "'%S" (cadr formula)))
(setq initial (prin1-to-string formula)))
(if (stringp formula)
;; Position cursor inside close-quote.
(setq initial (cons initial (length initial))))
(dolist (key ses-completion-keys)
(define-key ses-mode-edit-map key #'ses-edit-cell-complete-symbol))
;; make it globally visible, so that it can be visible from the minibuffer.
(setq ses--completion-table ses--named-cell-hashmap)
(list row col
(read-from-minibuffer (format "Cell %s: " ses--curcell)
initial
ses-mode-edit-map
t ; Convert to Lisp object.
'ses-read-cell-history)))))
(when (ses-warn-unsafe newval 'unsafep)
(ses-begin-change)
(ses-cell-set-formula row col newval)
t))
(defun ses-read-cell (row col newval)
"Self-insert for initial character of cell function."
(interactive
(let* ((initial (this-command-keys))
(rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
(curval (ses-cell-formula (car rowcol) (cdr rowcol))))
(barf-if-buffer-read-only)
(list (car rowcol)
(cdr rowcol)
(if (equal initial "\"")
(progn
(if (not (stringp curval)) (setq curval nil))
(read-string (format-prompt "String Cell %s"
curval ses--curcell)
nil 'ses-read-string-history curval))
(read-from-minibuffer
(format "Cell %s: " ses--curcell)
(cons (if (equal initial "(") "()" initial) 2)
ses-mode-edit-map
t ; Convert to Lisp object.
'ses-read-cell-history
(prin1-to-string (if (eq (car-safe curval) 'ses-safe-formula)
(cadr curval)
curval)))))))
(when (ses-edit-cell row col newval)
(ses-command-hook) ; Update cell widths before movement.
(dolist (x ses-after-entry-functions)
(funcall x 1))))
(defun ses-read-symbol (row col symb)
"Self-insert for a symbol as a cell formula.
The set of all symbols that have been used as formulas in this
spreadsheet is available for completions."
(interactive
(let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
newval)
(barf-if-buffer-read-only)
(setq newval (completing-read (format "Cell %s ': " ses--curcell)
ses--symbolic-formulas))
(list (car rowcol)
(cdr rowcol)
(if (string= newval "")
nil ; Don't create zero-length symbols!
(list 'quote (intern newval))))))
(when (ses-edit-cell row col symb)
(ses-command-hook) ; Update cell widths before movement.
(dolist (x ses-after-entry-functions)
(funcall x 1))))
(defun ses-clear-cell-forward (count)
"Delete formula and printer for current cell and then move to next cell.
With prefix, deletes several cells."
(interactive "*p")
(if (< count 0)
(1value (ses-clear-cell-backward (- count)))
(ses-check-curcell)
(ses-begin-change)
(dotimes (_ count)
(ses-set-curcell)
(let ((rowcol (ses-sym-rowcol ses--curcell)))
(or rowcol (signal 'end-of-buffer nil))
(ses-clear-cell (car rowcol) (cdr rowcol)))
(forward-char 1))))
(defun ses-clear-cell-backward (count)
"Move to previous cell and then delete it. With prefix, delete several cells."
(interactive "*p")
(if (< count 0)
(1value (ses-clear-cell-forward (- count)))
(ses-check-curcell 'end)
(ses-begin-change)
(dotimes (_ count)
(backward-char 1) ; Will signal 'beginning-of-buffer if appropriate.
(ses-set-curcell)
(let ((rowcol (ses-sym-rowcol ses--curcell)))
(ses-clear-cell (car rowcol) (cdr rowcol))))))
;;----------------------------------------------------------------------------
;; Input of cell-printer functions
;;----------------------------------------------------------------------------
(defun ses-read-printer-complete-symbol ()
(interactive)
(let ((completion-at-point-functions
(cons #'ses--read-printer-completion-at-point-function
completion-at-point-functions)))
(completion-at-point)))
(defun ses--read-printer-completion-at-point-function ()
(let* ((bol (save-excursion (move-beginning-of-line nil) (point)))
start end collection
(prefix
(save-excursion
(setq end (point))
(backward-sexp)
(if (< (point) bol)
(progn
(setq start bol)
(buffer-substring start end))
(setq start (point))
(forward-sexp)
(if (>= (point) end)
(progn
(setq end (point))
(buffer-substring start end))
nil))))
prefix-length)
(when prefix
(setq prefix-length (length prefix))
(maphash (lambda (key _val)
(let ((key-name (symbol-name key)))
(when (and (>= (length key-name) prefix-length)
(string= prefix (substring key-name 0 prefix-length)))
(push key-name collection))))
ses--completion-table)
(and collection (list start end collection)))))
(defun ses-read-printer (prompt default)
"Common code for functions `ses-read-cell-printer', `ses-read-column-printer',
`ses-read-default-printer' and `ses-define-local-printer'.
PROMPT should end with \": \". Result is t if operation was
canceled."
(barf-if-buffer-read-only)
(if (eq default t)
(setq default "")
(setq prompt (format-prompt prompt default)))
(dolist (key ses-completion-keys)
(define-key ses-mode-edit-map key #'ses-read-printer-complete-symbol))
;; make it globally visible, so that it can be visible from the minibuffer.
(setq ses--completion-table ses--local-printer-hashmap)
(let ((new (read-from-minibuffer prompt
nil ; Initial contents.
ses-mode-edit-map
t ; Evaluate the result.
'ses-read-printer-history
(prin1-to-string default))))
(if (equal new default)
;; User changed mind, decided not to change printer.
(setq new t)
(ses-printer-validate new)
(or (not new)
(stringp new)
(stringp (car-safe new))
(and (symbolp new) (gethash new ses--local-printer-hashmap))
(ses-warn-unsafe new 'unsafep-function)
(setq new t)))
new))
(defun ses-read-cell-printer (newval)
"Set the printer function for the current cell or range.
A printer function is either a string (a format control-string with one
%-sequence -- result from format will be right-justified), or a list of one
string (result from format will be left-justified), or a lambda-expression of
one argument, or a symbol that names a function of one argument. In the
latter two cases, the function's result should be either a string (will be
right-justified) or a list of one string (will be left-justified)."
(interactive
(let ((default t))
(ses-check-curcell 'range)
;;Default is none if not all cells in range have same printer
(catch 'ses-read-cell-printer
(ses-dorange ses--curcell
(let ((x (ses-cell-printer row col)))
(if (eq (car-safe x) 'ses-safe-printer)
(setq x (cadr x)))
(if (eq default t)
(setq default x)
(unless (equal default x)
;;Range contains differing printer functions
(setq default t)
(throw 'ses-read-cell-printer t))))))
(list (ses-read-printer (format "Cell %S printer" ses--curcell)
default))))
(unless (eq newval t)
(ses-begin-change)
(ses-dorange ses--curcell
(ses-set-cell row col 'printer newval)
(ses-print-cell row col))))
(defun ses-read-column-printer (col newval)
"Set the printer function for the current column.
See `ses-read-cell-printer' for input forms."
(interactive
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(ses-check-curcell)
(list col (ses-read-printer (format "Column %s printer"
(ses-column-letter col))
(ses-col-printer col)))))
(unless (eq newval t)
(ses-begin-change)
(ses-set-parameter 'ses--col-printers newval col)
(save-excursion
(dotimes (row ses--numrows)
(ses-print-cell row col)))))
(defun ses-read-default-printer (newval)
"Set the default printer function for cells that have no other.
See `ses-read-cell-printer' for input forms."
(interactive
(list (ses-read-printer "Default printer" ses--default-printer)))
(unless (eq newval t)
(ses-begin-change)
(ses-set-parameter 'ses--default-printer newval)
(ses-reprint-all t)))
;;----------------------------------------------------------------------------
;; Spreadsheet size adjustments
;;----------------------------------------------------------------------------
(defun ses--blank-line-needs-printing-p ()
"Returns `t' when blank new line print-out needs to be initialized
by calling the printers on it, `nil' otherwise."
(let (ret
printer
(printers (append ses--col-printers (list ses--default-printer))))
(while printers
(if (and (setq printer (pop printers))
(null (string= "" (ses-call-printer printer))))
(setq ret t
printers nil)))
ret))
(defun ses-insert-row (count)
"Insert a new row before the current one.
With prefix, insert COUNT rows before current one."
(interactive "*p")
(ses-check-curcell 'end)
(or (> count 0) (signal 'args-out-of-range nil))
(ses-begin-change)
(let ((inhibit-quit t)
(inhibit-read-only t)
(row (or (car (ses-sym-rowcol ses--curcell)) ses--numrows))
newrow)
;;Create a new set of cell-variables
(ses-create-cell-variable-range ses--numrows (+ ses--numrows count -1)
0 (1- ses--numcols))
(ses-set-parameter 'ses--numrows (+ ses--numrows count))
;;Insert each row
(ses-goto-print row 0)
(dotimes-with-progress-reporter (x count) "Inserting row..."
;;Create a row of empty cells. The `symbol' fields will be set by
;;the call to ses-relocate-all.
(setq newrow (make-vector ses--numcols nil))
(dotimes (col ses--numcols)
(aset newrow col (ses-make-cell)))
(setq ses--cells (ses-vector-insert ses--cells row newrow))
(push `(apply ses-vector-delete ses--cells ,row 1) buffer-undo-list)
(insert ses--blank-line))
;;Insert empty lines in cell data area (will be replaced by
;;ses-relocate-all)
(ses-goto-data row 0)
(insert (make-string (* (1+ ses--numcols) count) ?\n))
(ses-relocate-all row 0 count 0)
;;If any cell printers insert constant text, insert that text into
;;the line.
(if (ses--blank-line-needs-printing-p)
(dotimes (x count)
(dotimes (col ses--numcols)
;;These cells are always nil, only constant formatting printed
(1value (ses-print-cell (+ x row) col)))))
(when (> ses--header-row row)
;;Inserting before header
(ses-set-parameter 'ses--header-row (+ ses--header-row count))
(ses-reset-header-string)))
;;Reconstruct text attributes
(ses-setup)
;;Prepare for undo
(push '(apply ses-widen) buffer-undo-list)
;;Return to current cell
(if ses--curcell
(ses-jump-safe ses--curcell)
(ses-goto-print (1- ses--numrows) 0)))
(defun ses-delete-row (count)
"Delete the current row.
With prefix, deletes COUNT rows starting from the current one."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(let ((inhibit-quit t)
(inhibit-read-only t)
(row (car (ses-sym-rowcol ses--curcell))))
(setq count (min count (- ses--numrows row)))
(ses-begin-change)
(ses-set-parameter 'ses--numrows (- ses--numrows count))
;;Delete lines from print area
(ses-goto-print row 0)
(ses-delete-line count)
;;Delete lines from cell data area
(ses-goto-data row 0)
(ses-delete-line (* count (1+ ses--numcols)))
;; Collect named cells in the deleted rows, in order to clean the
;; symbols out of the named cell hash map, once the deletion is
;; complete
(unless (null ses--in-killing-named-cell-list)
(warn "Internal error, `ses--in-killing-named-cell-list' should be nil, but is equal to %S"
ses--in-killing-named-cell-list)
(setq ses--in-killing-named-cell-list nil))
(dotimes-with-progress-reporter (nrow count)
"Collecting named cell in deleted rows..."
(dotimes (col ses--numcols)
(let* ((row (+ row nrow))
(sym (ses-cell-symbol row col)))
(and (eq (get sym 'ses-cell) :ses-named)
(push sym ses--in-killing-named-cell-list)))))
;;Relocate variables and formulas
(ses-set-with-undo 'ses--cells (ses-vector-delete ses--cells row count))
(ses-relocate-all row 0 (- count) 0)
(ses-destroy-cell-variable-range ses--numrows (+ ses--numrows count -1)
0 (1- ses--numcols))
(when (> ses--header-row row)
(if (<= ses--header-row (+ row count))
;;Deleting the header row
(ses-set-parameter 'ses--header-row 0)
(ses-set-parameter 'ses--header-row (- ses--header-row count)))
(ses-reset-header-string)))
;;Reconstruct attributes
(ses-setup)
;;Prepare for undo
(push '(apply ses-widen) buffer-undo-list)
(ses-jump-safe ses--curcell))
(defun ses-insert-column (count &optional col width printer)
"Insert a new column before COL (default is the current one).
With prefix, insert COUNT columns before current one.
If COL is specified, the new column(s) get the specified WIDTH and PRINTER
\(otherwise they're taken from the current column)."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(or col
(setq col (cdr (ses-sym-rowcol ses--curcell))
width (ses-col-width col)
printer (ses-col-printer col)))
(ses-begin-change)
(let ((inhibit-quit t)
(inhibit-read-only t)
(widths ses--col-widths)
(printers ses--col-printers)
has-skip)
;;Create a new set of cell-variables
(ses-create-cell-variable-range 0 (1- ses--numrows)
ses--numcols (+ ses--numcols count -1))
;;Insert each column.
(dotimes-with-progress-reporter (x count) "Inserting column..."
;;Create a column of empty cells. The `symbol' fields will be set by
;;the call to ses-relocate-all.
(ses-adjust-print-width col (1+ width))
(ses-set-parameter 'ses--numcols (1+ ses--numcols))
(dotimes (row ses--numrows)
(and (< (1+ col) ses--numcols) (eq (ses-cell-value row col) '*skip*)
;;Inserting in the middle of a spill-over
(setq has-skip t))
(ses-aset-with-undo ses--cells row
(ses-vector-insert (aref ses--cells row)
col (ses-make-cell)))
;;Insert empty lines in cell data area (will be replaced by
;;ses-relocate-all)
(ses-goto-data row col)
(insert ?\n))
;; Insert column width and printer.
(setq widths (ses-vector-insert widths col width)
printers (ses-vector-insert printers col printer)))
(ses-set-parameter 'ses--col-widths widths)
(ses-set-parameter 'ses--col-printers printers)
(ses-reset-header-string)
(ses-relocate-all 0 col 0 count)
(if has-skip
(ses-reprint-all t)
(when (or (> (length (ses-call-printer printer)) 0)
(> (length (ses-call-printer ses--default-printer)) 0))
;; Either column printer or global printer inserts some constant text.
;; Reprint the new columns to insert that text.
(dotimes (x ses--numrows)
(dotimes (y count)
;; Always nil here --- this is a blank column.
(1value (ses-print-cell-new-width x (+ y col))))))
(ses-setup)))
(ses-jump-safe ses--curcell))
(defun ses-delete-column (count)
"Delete the current column.
With prefix, deletes COUNT columns starting from the current one."
(interactive "*p")
(ses-check-curcell)
(or (> count 0) (signal 'args-out-of-range nil))
(let ((inhibit-quit t)
(inhibit-read-only t)
(rowcol (ses-sym-rowcol ses--curcell))
(width 0)
col origrow has-skip)
(setq origrow (car rowcol)
col (cdr rowcol)
count (min count (- ses--numcols col)))
(if (= count ses--numcols)
(error "Can't delete all columns!"))
;;Determine width of column(s) being deleted
(dotimes (x count)
(setq width (+ width (ses-col-width (+ col x)) 1)))
(ses-begin-change)
(ses-set-parameter 'ses--numcols (- ses--numcols count))
(ses-adjust-print-width col (- width))
;; Prepare collecting named cells in the deleted columns, in order
;; to clean the symbols out of the named cell hash map, once the
;; deletion is complete
(unless (null ses--in-killing-named-cell-list)
(warn "Internal error, `ses--in-killing-named-cell-list' should be nil, but is equal to %S"
ses--in-killing-named-cell-list)
(setq ses--in-killing-named-cell-list nil))
(dotimes-with-progress-reporter (row ses--numrows) "Deleting column..."
;;Delete lines from cell data area
(ses-goto-data row col)
(ses-delete-line count)
;; Collect named cells in the deleted columns within this row
(dotimes (ncol count)
(let ((sym (ses-cell-symbol row (+ col ncol))))
(and (eq (get sym 'ses-cell) :ses-named)
(push sym ses--in-killing-named-cell-list))))
;;Delete cells. Check if deletion area begins or ends with a skip.
(if (or (eq (ses-cell-value row col) '*skip*)
(and (< col ses--numcols)
(eq (ses-cell-value row (+ col count)) '*skip*)))
(setq has-skip t))
(ses-aset-with-undo ses--cells row
(ses-vector-delete (aref ses--cells row) col count)))
;;Update globals
(ses-set-parameter 'ses--col-widths
(ses-vector-delete ses--col-widths col count))
(ses-set-parameter 'ses--col-printers
(ses-vector-delete ses--col-printers col count))
(ses-reset-header-string)
;;Relocate variables and formulas
(ses-relocate-all 0 col 0 (- count))
(ses-destroy-cell-variable-range 0 (1- ses--numrows)
ses--numcols (+ ses--numcols count -1))
(if has-skip
(ses-reprint-all t)
(ses-setup))
(if (>= col ses--numcols)
(setq col (1- col)))
(ses-goto-print origrow col)))
(defun ses-forward-or-insert (&optional count)
"Move to next cell in row, or inserts a new cell if already in last one, or
inserts a new row if at bottom of print area. Repeat COUNT times."
(interactive "p")
(ses-check-curcell 'end)
(setq deactivate-mark t) ; Doesn't combine well with ranges.
(dotimes (x count)
(ses-set-curcell)
(if (not ses--curcell)
(progn ; At bottom of print area.
(barf-if-buffer-read-only)
(ses-insert-row 1))
(let ((col (cdr (ses-sym-rowcol ses--curcell))))
(when (/= 32
(char-before (next-single-property-change (point)
'cursor-intangible)))
;; We're already in last nonskipped cell on line. Need to create a
;; new column.
(barf-if-buffer-read-only)
(ses-insert-column (- count x)
ses--numcols
(ses-col-width col)
(ses-col-printer col)))))
(forward-char)))
(defun ses-append-row-jump-first-column ()
"Insert a new row after current one and jump to its first column."
(interactive "*")
(ses-check-curcell)
(ses-begin-change)
(beginning-of-line 2)
(ses-set-curcell)
(ses-insert-row 1))
(defun ses-set-column-width (col newwidth)
"Set the width of the current column."
(interactive
(let ((col (cdr (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))))
(barf-if-buffer-read-only)
(list col
(if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
(read-from-minibuffer (format-prompt "Column %s width"
(ses-col-width col)
(ses-column-letter col))
nil ; No initial contents.
nil ; No override keymap.
t ; Convert to Lisp object.
nil ; No history.
(number-to-string
(ses-col-width col))))))) ; Default value.
(if (< newwidth 1)
(error "Invalid column width"))
(ses-begin-change)
(ses-reset-header-string)
(save-excursion
(let ((inhibit-quit t))
(ses-adjust-print-width col (- newwidth (ses-col-width col)))
(ses-set-parameter 'ses--col-widths newwidth col))
(dotimes (row ses--numrows)
(ses-print-cell-new-width row col))))
;;----------------------------------------------------------------------------
;; Cut and paste, import and export
;;----------------------------------------------------------------------------
(defun ses--advice-copy-region-as-kill (crak-fun beg end &rest args)
;; FIXME: Why doesn't it make sense to copy read-only or
;; intangible attributes? They're removed upon yank!
"It doesn't make sense to copy read-only or intangible attributes into the
kill ring. It probably doesn't make sense to copy keymap properties.
We'll assume copying front-sticky properties doesn't make sense, either.
This advice also includes some SES-specific code because otherwise it's too
hard to override how mouse-1 works."
(when (and beg end (> beg end))
(let ((temp beg))
(setq beg end
end temp)))
(if (not (and (derived-mode-p 'ses-mode)
(eq (get-text-property beg 'read-only) 'ses)
(eq (get-text-property (1- end) 'read-only) 'ses)))
(apply crak-fun beg end args) ; Normal copy-region-as-kill.
(kill-new (ses-copy-region beg end))
(if transient-mark-mode
(setq deactivate-mark t))
nil))
(advice-add 'copy-region-as-kill :around #'ses--advice-copy-region-as-kill)
(defun ses-copy-region (beg end)
"Treat the region as rectangular.
Convert the intangible attributes to SES attributes recording the
contents of the cell as of the time of copying."
(when (= end ses--data-marker)
;;Avoid overflow situation
(setq end (1- ses--data-marker)))
(let* ((x (mapconcat #'ses-copy-region-helper
(extract-rectangle beg (1- end)) "\n")))
(remove-text-properties 0 (length x)
'(read-only t
cursor-intangible t
keymap t
front-sticky t)
x)
x))
(defun ses-copy-region-helper (line)
"Convert one line (of a rectangle being extracted from a spreadsheet) to
external form by attaching to each print cell a `ses' attribute that records
the corresponding data cell."
(or (> (length line) 1)
(error "Empty range"))
(let ((inhibit-read-only t)
(pos 0)
mycell next sym rowcol)
(while pos
(setq sym (ses--cell-at-pos pos line)
next (next-single-property-change pos 'cursor-intangible line)
rowcol (ses-sym-rowcol sym)
mycell (ses-get-cell (car rowcol) (cdr rowcol)))
(put-text-property pos (or next (length line))
'ses
(list (ses-cell-symbol mycell)
(ses-cell-formula mycell)
(ses-cell-printer mycell))
line)
(setq pos next)))
line)
(defun ses-kill-override (beg end)
"Generic override for any commands that kill text.
We clear the killed cells instead of deleting them."
(interactive "r")
(ses-check-curcell 'needrange)
;; For some reason, the text-read-only error is not caught by `delete-region',
;; so we have to use subterfuge.
(let ((buffer-read-only t))
(1value (condition-case nil
(noreturn (funcall (lookup-key (current-global-map)
(this-command-keys))
beg end))
(buffer-read-only nil)))) ; The expected error.
;; Because the buffer was marked read-only, the kill command turned itself
;; into a copy. Now we clear the cells or signal the error. First we check
;; whether the buffer really is read-only.
(barf-if-buffer-read-only)
(ses-begin-change)
(ses-dorange ses--curcell
(ses-clear-cell row col))
(ses-jump (car ses--curcell)))
(defun ses--advice-yank (yank-fun &optional arg &rest args)
"In SES mode, the yanked text is inserted as cells.
If the text contains `ses' attributes (meaning it went to the kill-ring from a
SES buffer), the formulas and print functions are restored for the cells. If
the text contains tabs, this is an insertion of tab-separated formulas.
Otherwise the text is inserted as the formula for the current cell.
When inserting cells, the formulas are usually relocated to keep the same
relative references to neighboring cells. This is best if the formulas
generally refer to other cells within the yanked text. You can use the \\[universal-argument]
prefix to specify insertion without relocation, which is best when the
formulas refer to cells outside the yanked text.
When inserting formulas, the text is treated as a string constant if it doesn't
make sense as a sexp or would otherwise be considered a symbol. Use `sym' to
explicitly insert a symbol, or use the \\[universal-argument] prefix to treat all unmarked words
as symbols."
(if (not (and (derived-mode-p 'ses-mode)
(eq (get-text-property (point) 'keymap) 'ses-mode-print-map)))
(apply yank-fun arg args) ; Normal non-SES yank.
(ses-check-curcell 'end)
(push-mark)
(let ((text (current-kill (cond
((listp arg) 0)
((eq arg '-) -1)
(t (1- arg))))))
(or (ses-yank-cells text arg)
(ses-yank-tsf text arg)
(ses-yank-one (ses-yank-resize 1 1)
text
0
(if (memq (aref text (1- (length text))) '(?\t ?\n))
;; Just one cell --- delete final tab or newline.
(1- (length text)))
arg)))
(if (consp arg)
(exchange-point-and-mark))))
(advice-add 'yank :around #'ses--advice-yank)
(defun ses-yank-pop (arg)
"Replace just-yanked stretch of killed text with a different stretch.
This command is allowed only immediately after a `yank' or a `yank-pop',
when the region contains a stretch of reinserted previously-killed text.
We replace it with a different stretch of killed text.
Unlike standard `yank-pop', this function uses `undo' to delete the
previous insertion."
(interactive "*p")
(or (eq last-command 'yank)
;;Use noreturn here just to avoid a "poor-coverage" warning in its
;;macro definition.
(noreturn (error "Previous command was not a yank")))
(undo)
(ses-set-curcell)
(yank (1+ (or arg 1)))
(setq this-command 'yank))
(defun ses-yank-cells (text arg)
"If TEXT has a proper set of `ses' attributes, insert it as cells.
Otherwise, return nil. The cells are reprinted--the supplied text is
ignored because the column widths, default printer, etc. at yank time might
be different from those at kill-time. ARG is a list to indicate that
formulas are to be inserted without relocation."
(let ((first (get-text-property 0 'ses text))
(last (get-text-property (1- (length text)) 'ses text)))
(when (and first last) ;;Otherwise not proper set of attributes
(setq first (ses-sym-rowcol (car first))
last (ses-sym-rowcol (car last)))
(let* ((needrows (- (car last) (car first) -1))
(needcols (- (cdr last) (cdr first) -1))
(rowcol (ses-yank-resize needrows needcols))
(rowincr (- (car rowcol) (car first)))
(colincr (- (cdr rowcol) (cdr first)))
(pos 0)
myrow mycol x)
(dotimes-with-progress-reporter (row needrows) "Yanking..."
(setq myrow (+ row (car rowcol)))
(dotimes (col needcols)
(setq mycol (+ col (cdr rowcol))
last (get-text-property pos 'ses text)
pos (next-single-property-change pos 'ses text)
x (ses-sym-rowcol (car last)))
(if (not last)
;; Newline --- all remaining cells on row are skipped.
(setq x (cons (- myrow rowincr) (+ needcols colincr -1))
last (list nil nil nil)
pos (1- pos)))
(if (/= (car x) (- myrow rowincr))
(error "Cell row error"))
(if (< (- mycol colincr) (cdr x))
;; Some columns were skipped.
(let ((oldcol mycol))
(while (< (- mycol colincr) (cdr x))
(ses-clear-cell myrow mycol)
(setq col (1+ col)
mycol (1+ mycol)))
(ses-print-cell myrow (1- oldcol)))) ;; This inserts *skip*.
(when (car last) ; Skip this for *skip* cells.
(setq x (nth 2 last))
(unless (equal x (ses-cell-printer myrow mycol))
(or (not x)
(stringp x)
(eq (car-safe x) 'ses-safe-printer)
(setq x `(ses-safe-printer ,x)))
(ses-set-cell myrow mycol 'printer x))
(setq x (cadr last))
(if (atom arg)
(setq x (ses-relocate-formula x 0 0 rowincr colincr)))
(or (atom x)
(eq (car-safe x) 'ses-safe-formula)
(setq x `(ses-safe-formula ,x)))
(ses-cell-set-formula myrow mycol x)))
(when pos
(if (get-text-property pos 'ses text)
(error "Missing newline between rows"))
(setq pos (next-single-property-change pos 'ses text))))
t))))
(defun ses-yank-one (rowcol text from to arg)
"Insert the substring [FROM,TO] of TEXT as the formula for cell ROWCOL (a
cons of ROW and COL). Treat plain symbols as strings unless ARG is a list."
(let ((val (condition-case nil
(read-from-string text from to)
(error (cons nil from)))))
(cond
((< (cdr val) (or to (length text)))
;; Invalid sexp --- leave it as a string.
(setq val (substring text from to)))
((and (car val) (symbolp (car val)))
(setq val (if (consp arg)
(list 'quote (car val)) ; Keep symbol.
(substring text from to)))) ; Treat symbol as text.
(t
(setq val (car val))))
(let ((row (car rowcol))
(col (cdr rowcol)))
(or (atom val)
(setq val `(ses-safe-formula ,val)))
(ses-cell-set-formula row col val))))
(defun ses-yank-tsf (text arg)
"If TEXT contains tabs and/or newlines, treat the tabs as
column-separators and the newlines as row-separators and insert the text as
cell formulas--else return nil. Treat plain symbols as strings unless ARG
is a list. Ignore a final newline."
(if (or (not (string-match "[\t\n]" text))
(= (match-end 0) (length text)))
;;Not TSF format
nil
(if (/= (aref text (1- (length text))) ?\n)
(setq text (concat text "\n")))
(let ((pos -1)
(spots (list -1))
(cols 0)
(needrows 0)
needcols rowcol)
;;Find all the tabs and newlines
(while (setq pos (string-match "[\t\n]" text (1+ pos)))
(push pos spots)
(setq cols (1+ cols))
(when (eq (aref text pos) ?\n)
(if (not needcols)
(setq needcols cols)
(or (= needcols cols)
(error "Inconsistent row lengths")))
(setq cols 0
needrows (1+ needrows))))
;;Insert the formulas
(setq rowcol (ses-yank-resize needrows needcols))
(dotimes (row needrows)
(dotimes (col needcols)
(ses-yank-one (cons (+ (car rowcol) needrows (- row) -1)
(+ (cdr rowcol) needcols (- col) -1))
text (1+ (cadr spots)) (car spots) arg)
(setq spots (cdr spots))))
(ses-goto-print (+ (car rowcol) needrows -1)
(+ (cdr rowcol) needcols -1))
t)))
(defun ses-yank-resize (needrows needcols)
"If this yank will require inserting rows and/or columns, ask for
confirmation and then insert them. Result is (row,col) for top left of yank
spot, or error signal if user requests cancel."
(ses-begin-change)
(let ((rowcol (if ses--curcell
(ses-sym-rowcol ses--curcell)
(cons ses--numrows 0)))
rowbool colbool)
(setq needrows (- (+ (car rowcol) needrows) ses--numrows)
needcols (- (+ (cdr rowcol) needcols) ses--numcols)
rowbool (> needrows 0)
colbool (> needcols 0))
(when (or rowbool colbool)
;;Need to insert. Get confirm
(or (y-or-n-p (format "Yank will insert %s%s%s. Continue? "
(if rowbool (format "%d rows" needrows) "")
(if (and rowbool colbool) " and " "")
(if colbool (format "%d columns" needcols) "")))
(error "Canceled"))
(when rowbool
(let (ses--curcell)
(save-excursion
(ses-goto-print ses--numrows 0)
(ses-insert-row needrows))))
(when colbool
(ses-insert-column needcols
ses--numcols
(ses-col-width (1- ses--numcols))
(ses-col-printer (1- ses--numcols)))))
rowcol))
(defun ses-export-tsv (_beg _end)
"Export values from the current range, with tabs between columns and
newlines between rows. Result is placed in kill ring."
(interactive "r")
(ses-export-tab nil))
(defun ses-export-tsf (_beg _end)
"Export formulas from the current range, with tabs between columns and
newlines between rows. Result is placed in kill ring."
(interactive "r")
(ses-export-tab t))
(defun ses-export-tab (want-formulas)
"Export the current range with tabs between columns and newlines between rows.
Result is placed in kill ring. The export is values unless WANT-FORMULAS
is non-nil. Newlines and tabs in the export text are escaped."
(ses-check-curcell 'needrange)
(let ((print-escape-newlines t)
result item)
(ses-dorange ses--curcell
(setq item (if want-formulas
(ses-cell-formula row col)
(ses-cell-value row col)))
(if (eq (car-safe item) 'ses-safe-formula)
;;Hide our deferred safety-check marker
(setq item (cadr item)))
(if (or (not item) (eq item '*skip*))
(setq item ""))
(when (eq (car-safe item) 'quote)
(push "'" result)
(setq item (cadr item)))
(setq item (ses-prin1 item))
(setq item (string-replace "\t" "\\t" item))
(push item result)
(cond
((< col maxcol)
(push "\t" result))
((< row maxrow)
(push "\n" result))))
(setq result (apply #'concat (nreverse result)))
(kill-new result)))
;;----------------------------------------------------------------------------
;; Interactive help on symbols
;;----------------------------------------------------------------------------
(defun ses-list-local-printers (&optional local-printer-hashmap)
"List local printers in a help buffer.
Can be called either during editing a printer or a formula, or
while in the SES buffer."
(interactive
(list (cond
((derived-mode-p 'ses-mode) ses--local-printer-hashmap)
((minibufferp) ses--completion-table)
((derived-mode-p 'help-mode) nil)
(t (user-error "Not in a SES buffer")))))
(when local-printer-hashmap
(let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer))))
(help-setup-xref
(list (lambda (local-printer-hashmap buffer)
(let ((ses--list-orig-buffer
(if (buffer-live-p buffer) buffer)))
(ses-list-local-printers local-printer-hashmap)))
local-printer-hashmap ses--list-orig-buffer)
(called-interactively-p 'interactive))
(save-excursion
(with-help-window (help-buffer)
(if (= 0 (hash-table-count local-printer-hashmap))
(princ "No local printers defined.")
(princ "List of local printers definitions:\n")
(maphash (lambda (key val)
(princ key)
(princ " as ")
(prin1 (ses--locprn-def val))
(princ "\n"))
local-printer-hashmap))
(with-current-buffer standard-output
(buffer-string)))))))
(defun ses-list-named-cells (&optional named-cell-hashmap)
"List named cells in a help buffer.
Can be called either during editing a printer or a formula, or
while in the SES buffer."
(interactive
(list (cond
((derived-mode-p 'ses-mode) ses--named-cell-hashmap)
((minibufferp) ses--completion-table)
((derived-mode-p 'help-mode) nil)
(t (user-error "Not in a SES buffer")))))
(when named-cell-hashmap
(let ((ses--list-orig-buffer (or ses--list-orig-buffer (current-buffer))))
(help-setup-xref
(list (lambda (named-cell-hashmap buffer)
(let ((ses--list-orig-buffer
(if (buffer-live-p buffer) buffer)))
(ses-list-named-cells named-cell-hashmap)))
named-cell-hashmap ses--list-orig-buffer)
(called-interactively-p 'interactive))
(save-excursion
(with-help-window (help-buffer)
(if (= 0 (hash-table-count named-cell-hashmap))
(princ "No cell was renamed.")
(princ "List of named cells definitions:\n")
(maphash (lambda (key val)
(princ key)
(princ " for ")
(prin1 (ses-create-cell-symbol (car val) (cdr val)))
(princ "\n"))
named-cell-hashmap))
(with-current-buffer standard-output
(buffer-string)))))))
;;----------------------------------------------------------------------------
;; Other user commands
;;----------------------------------------------------------------------------
(defun ses-unset-header-row ()
"Select the default header row."
(interactive)
(ses-set-header-row 0))
(defun ses-set-header-row (row)
"Set the ROW to display in the header-line.
With a numerical prefix arg, use that row.
With no prefix arg, use the current row.
With a \\[universal-argument] prefix arg, prompt the user.
The top row is row 1. Selecting row 0 displays the default header row."
(interactive
(list (if (numberp current-prefix-arg) current-prefix-arg
(let* ((curcell (or (ses--cell-at-pos (point))
(user-error "Invalid header-row")))
(currow (1+ (car (ses-sym-rowcol curcell)))))
(if current-prefix-arg
(read-number "Header row: " currow)
currow)))))
(if (or (< row 0) (> row ses--numrows))
(error "Invalid header-row"))
(ses-begin-change)
(let ((oldval ses--header-row))
(let (buffer-undo-list)
(ses-set-parameter 'ses--header-row row))
(push `(apply ses-set-header-row ,oldval) buffer-undo-list))
(ses-reset-header-string))
(defun ses-mark-row ()
"Mark the entirety of current row as a range."
(interactive)
(ses-check-curcell 'range)
(let ((row (car (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell)))))
(push-mark)
(ses-goto-print (1+ row) 0)
(push-mark (point) nil t)
(ses-goto-print row 0)))
(defun ses-mark-column ()
"Mark the entirety of current column as a range."
(interactive)
(ses-check-curcell 'range)
(let ((col (cdr (ses-sym-rowcol (or (car-safe ses--curcell) ses--curcell))))
(row 0))
(push-mark)
(ses-goto-print (1- ses--numrows) col)
(forward-char 1)
(push-mark (point) nil t)
(while (eq '*skip* (ses-cell-value row col))
;;Skip over initial cells in column that can't be selected
(setq row (1+ row)))
(ses-goto-print row col)))
(defun ses-end-of-line ()
"Move point to last cell on line."
(interactive)
(ses-check-curcell 'end 'range)
(when ses--curcell ; Otherwise we're at the bottom row, which is empty
; anyway.
(let ((col (1- ses--numcols))
row rowcol)
(if (symbolp ses--curcell)
;; Single cell.
(setq row (car (ses-sym-rowcol ses--curcell)))
;; Range --- use whichever end of the range the point is at.
(setq rowcol (ses-sym-rowcol (if (< (point) (mark))
(car ses--curcell)
(cdr ses--curcell))))
;; If range already includes the last cell in a row, point is actually
;; in the following row.
(if (<= (cdr rowcol) (1- col))
(setq row (car rowcol))
(setq row (1+ (car rowcol)))
(if (= row ses--numrows)
;;Already at end - can't go anywhere
(setq col 0))))
(when (< row ses--numrows) ; Otherwise it's a range that includes last cell.
(while (eq (ses-cell-value row col) '*skip*)
;; Back to beginning of multi-column cell.
(setq col (1- col)))
(ses-goto-print row col)))))
(defun ses-renarrow-buffer ()
"Narrow the buffer so only the print area is visible.
Use after \\[widen]."
(interactive)
(setq ses--deferred-narrow t))
(defun ses-sort-column (sorter &optional reverse)
"Sort the range by a specified column.
With prefix, sorts in REVERSE order."
(interactive "*sSort column: \nP")
(ses-check-curcell 'needrange)
(let ((min (ses-sym-rowcol (car ses--curcell)))
(max (ses-sym-rowcol (cdr ses--curcell))))
(let ((minrow (car min))
(mincol (cdr min))
(maxrow (car max))
(maxcol (cdr max))
keys extracts end)
(setq sorter (cdr (ses-sym-rowcol (intern (concat sorter "1")))))
(or (and sorter (>= sorter mincol) (<= sorter maxcol))
(error "Invalid sort column"))
;;Get key columns and sort them
(dotimes (x (- maxrow minrow -1))
(ses-goto-print (+ minrow x) sorter)
(setq end (next-single-property-change (point) 'cursor-intangible))
(push (cons (buffer-substring-no-properties (point) end)
(+ minrow x))
keys))
(setq keys (sort keys (lambda (x y) (string< (car x) (car y)))))
;;Extract the lines in reverse sorted order
(or reverse
(setq keys (nreverse keys)))
(dolist (x keys)
(ses-goto-print (cdr x) (1+ maxcol))
(setq end (point))
(ses-goto-print (cdr x) mincol)
(push (ses-copy-region (point) end) extracts))
(deactivate-mark)
;;Paste the lines sequentially
(dotimes (x (- maxrow minrow -1))
(ses-goto-print (+ minrow x) mincol)
(ses-set-curcell)
(ses-yank-cells (pop extracts) nil)))))
(defun ses-sort-column-click (event reverse)
"Mouse version of `ses-sort-column'."
(interactive "*e\nP")
(setq event (event-end event))
(select-window (posn-window event))
(setq event (car (posn-col-row event))) ; Click column.
(let ((col 0))
(while (and (< col ses--numcols) (> event (ses-col-width col)))
(setq event (- event (ses-col-width col) 1)
col (1+ col)))
(if (>= col ses--numcols)
(ding)
(ses-sort-column (ses-column-letter col) reverse))))
(defun ses-insert-range ()
"Insert into minibuffer the list of cells currently highlighted in the
spreadsheet."
(interactive "*")
(let (x)
(with-current-buffer (window-buffer minibuffer-scroll-window)
(ses-command-hook) ; For ses-coverage.
(ses-check-curcell 'needrange)
(setq x (cdr (macroexpand `(ses-range ,(car ses--curcell)
,(cdr ses--curcell))))))
(insert (substring (prin1-to-string (nreverse x)) 1 -1))))
(defun ses-insert-ses-range ()
"Insert \"(ses-range x y)\" in the minibuffer to represent the currently
highlighted range in the spreadsheet."
(interactive "*")
(let (x)
(with-current-buffer (window-buffer minibuffer-scroll-window)
(ses-command-hook) ; For ses-coverage.
(ses-check-curcell 'needrange)
(setq x (format "(ses-range %S %S)"
(car ses--curcell)
(cdr ses--curcell))))
(insert x)))
(defun ses-insert-range-click (event)
"Mouse version of `ses-insert-range'."
(interactive "*e")
(mouse-set-point event)
(ses-insert-range))
(defun ses-insert-ses-range-click (event)
"Mouse version of `ses-insert-ses-range'."
(interactive "*e")
(mouse-set-point event)
(ses-insert-ses-range))
(defun ses-replace-name-in-formula (formula old-name new-name)
(let ((new-formula formula))
(cond
((eq (car-safe formula) 'quote))
((symbolp formula)
(if (eq formula old-name)
(setq new-formula new-name)))
((consp formula)
(while formula
(let ((elt (car-safe formula)))
(cond
((consp elt)
(setcar formula (ses-replace-name-in-formula elt old-name new-name)))
((and (symbolp elt)
(eq (car-safe formula) old-name))
(setcar formula new-name))))
(setq formula (cdr formula)))))
new-formula))
(defun ses-rename-cell (new-name &optional cell)
"Rename current cell."
(interactive "*SEnter new name: ")
(or
(and (ses-is-cell-sym-p new-name)
(error "Already a cell name"))
(and (boundp new-name)
(null (yes-or-no-p
(format-message
"`%S' is already bound outside this buffer, continue? "
new-name)))
(error "Already a bound cell name")))
(let* (curcell
(sym (if (ses-cell-p cell)
(ses-cell-symbol cell)
(setq cell nil
curcell t)
(ses-check-curcell)
ses--curcell))
(rowcol (ses-sym-rowcol sym))
(row (car rowcol))
(col (cdr rowcol))
new-rowcol old-name old-value)
(setq cell (or cell (ses-get-cell row col))
old-name (ses-cell-symbol cell)
old-value (symbol-value old-name)
new-rowcol (ses-decode-cell-symbol (symbol-name new-name)))
;; when ses-rename-cell is called interactively, then 'sym' is the
;; 'cursor-intangible' property of text at cursor position, while
;; 'old-name' is the symbol stored in array cell at coordinate
;; 'rowcol' corresponding to 'ses-cell' property of symbol
;; 'sym'. Both must be the same.
(unless (eq sym old-name)
(error "Spreadsheet is broken, both symbols %S and %S referring to cell (%d,%d)" sym old-name row col))
(if new-rowcol
;; the new name is of A1 type, so we test that the coordinate
;; inferred from new name
(if (equal new-rowcol rowcol)
(put new-name 'ses-cell rowcol)
(error "Not a valid name for this cell location"))
(setq ses--named-cell-hashmap
(or ses--named-cell-hashmap (make-hash-table :test 'eq)))
(put new-name 'ses-cell :ses-named)
(puthash new-name rowcol ses--named-cell-hashmap))
(push `(ses-rename-cell ,old-name ,cell) buffer-undo-list)
(cl-pushnew rowcol ses--deferred-write :test #'equal)
;; Replace name by new name in formula of cells referring to renamed cell.
(dolist (ref (ses-cell-references cell))
(let* ((x (ses-sym-rowcol ref))
(xcell (ses-get-cell (car x) (cdr x))))
(cl-pushnew x ses--deferred-write :test #'equal)
(setf (ses-cell-formula xcell)
(ses-replace-name-in-formula
(ses-cell-formula xcell)
old-name
new-name))))
;; Replace name by new name in reference list of cells to which renamed
;; cell refers to.
(dolist (ref (ses-formula-references (ses-cell-formula cell)))
(let* ((x (ses-sym-rowcol ref))
(xcell (ses-get-cell (car x) (cdr x))))
(cl-pushnew x ses--deferred-write :test #'equal)
(setf (ses-cell-references xcell)
(cons new-name (delq old-name
(ses-cell-references xcell))))))
(set (make-local-variable new-name) (symbol-value sym))
(setf (ses-cell--symbol cell) new-name)
;; set new name to value
(set new-name old-value)
;; Unbind old name
(if (eq (get old-name 'ses-cell) :ses-named)
(ses--unbind-cell-name old-name)
(kill-local-variable old-name))
(and curcell (setq ses--curcell new-name))
(save-excursion
(or curcell (ses-goto-print row col))
(let* ((pos (point))
(inhibit-read-only t)
(end (next-single-property-change pos 'cursor-intangible)))
(put-text-property pos end 'cursor-intangible new-name)))
;; Update the cell name in the mode-line.
(force-mode-line-update)))
(defun ses-refresh-local-printer (name _compiled-value) ;FIXME: unused arg?
"Refresh printout for all cells which use printer NAME.
NAME should be the name of a locally defined printer.
Uses the value COMPILED-VALUE for this printer."
(message "Refreshing cells using printer %S" name)
(let (new-print)
(dotimes (row ses--numrows)
(dotimes (col ses--numcols)
(let ((cell-printer (ses-cell-printer row col)))
(when (eq cell-printer name)
(unless new-print
(setq new-print t)
(ses-begin-change))
(ses-print-cell row col)))))))
(defun ses-define-local-printer (name definition)
"Define a local printer with name NAME and definition DEFINITION.
NAME shall be a symbol. Use TAB to complete over existing local
printer names.
DEFINITION shall be either a string formatter, e.g.:
\"%.2f\" or (\"%.2f\") for left alignment.
or a lambda expression, e.g. for formatting in ISO format dates
created with a `(calcFunc-date YEAR MONTH DAY)' formula:
(lambda (x)
(cond
((null val) \"\")
((eq (car-safe x) \\='date)
(let ((calc-format-date \\='(X YYYY \"-\" MM \"-\" DD)))
(math-format-date x)))
(t (ses-center-span val ?# \\='ses-prin1))))
If NAME is already used to name a local printer function, then
the current definition is proposed as default value, and the
function is redefined."
(interactive
(let (name def already-defined-names)
(maphash (lambda (key _val) (push (symbol-name key) already-defined-names))
ses--local-printer-hashmap)
(setq name (completing-read "Enter printer name: " already-defined-names))
(when (string= name "")
(error "Invalid printer name"))
(setq name (intern name))
(let* ((cur-printer (gethash name ses--local-printer-hashmap))
(default (and cur-printer (ses--locprn-def cur-printer))))
(setq def (ses-read-printer (format-prompt
"Enter definition of printer %S"
default name)
default)))
(list name def)))
(let* ((cur-printer (gethash name ses--local-printer-hashmap))
(default (and cur-printer (ses--locprn-def cur-printer)))
create-printer)
(cond
;; canceled operation => do nothing
((eq definition t))
;; no change => do nothing
((and cur-printer (equal definition default)))
;; re-defined printer
(cur-printer
(setq create-printer 0)
(setf (ses--locprn-def cur-printer) definition)
(ses-refresh-local-printer
name
(setf (ses--locprn-compiled cur-printer)
(ses-local-printer-compile definition))))
;; new definition
(t
(setq create-printer 1)
(puthash name
(setq cur-printer
(ses-make-local-printer-info definition))
ses--local-printer-hashmap)))
(when create-printer
(let ((printer-def-text
(concat
"(ses-local-printer "
(symbol-name name)
" "
(prin1-to-string (ses--locprn-def cur-printer))
")")))
(save-excursion
(ses-goto-data ses--numrows
(ses--locprn-number cur-printer))
(let ((inhibit-read-only t))
;; Special undo since it's outside the narrowed buffer.
(let (buffer-undo-list)
(if (= create-printer 0)
(delete-region (point) (line-end-position))
(insert ?\n)
(backward-char))
(insert printer-def-text)
(when (= create-printer 1)
(ses-file-format-extend-parameter-list 3)
(ses-set-parameter 'ses--numlocprn
(1+ ses--numlocprn))))))))))
(defsubst ses-define-if-new-local-printer (name def)
"Same as function `ses-define-if-new-local-printer', except
that the definition occurs only when the local printer does not
already exists.
Function `ses-define-if-new-local-printer' is not interactive; it
is intended for mode hooks to add local printers automatically."
(unless (gethash name ses--local-printer-hashmap)
(ses-define-local-printer name def)))
;;----------------------------------------------------------------------------
;; Checking formulas for safety
;;----------------------------------------------------------------------------
(defun ses-safe-printer (printer)
"Return PRINTER if safe, or the substitute printer `ses-unsafe' otherwise."
(if (or (stringp printer)
(stringp (car-safe printer))
(not printer)
(and (symbolp printer) (gethash printer ses--local-printer-hashmap))
(ses-warn-unsafe printer 'unsafep-function))
printer
'ses-unsafe))
(defun ses-safe-formula (formula)
"Return FORMULA if safe, or the substitute formula *unsafe* otherwise."
(if (ses-warn-unsafe formula 'unsafep)
formula
`(ses-unsafe ',formula)))
(defun ses-warn-unsafe (formula checker)
"Apply CHECKER to FORMULA.
If result is non-nil, asks user for confirmation about FORMULA,
which might be unsafe. Returns t if formula is safe or user allows
execution anyway. Always returns t if `safe-functions' is t."
(if (eq safe-functions t)
t
(setq checker (funcall checker formula))
(if (not checker)
t
(y-or-n-p (format "Formula %S\nmight be unsafe %S. Process it? "
formula checker)))))
;;----------------------------------------------------------------------------
;; Standard formulas
;;----------------------------------------------------------------------------
(defun ses--clean-! (&rest x)
"Clean by `delq' list X from any occurrence of nil or `*skip*'."
(delq nil (delq '*skip* x)))
(defun ses--clean-_ (x y)
"Clean list X by replacing by Y any occurrence of nil or `*skip*'.
This will change X by making `setcar' on its cons cells."
(let ((ret x) ret-elt)
(while ret
(setq ret-elt (car ret))
(when (memq ret-elt '(nil *skip*))
(setcar ret y))
(setq ret (cdr ret))))
x)
(defmacro ses-range (from to &rest rest)
"Expand to a list of cell-symbols for the range going from
FROM up to TO. The range automatically expands to include any
new row or column inserted into its middle. The SES library code
specifically looks for the symbol `ses-range', so don't create an
alias for this macro!
By passing in REST some flags one can configure the way the range
is read and how it is formatted.
In the sequel we assume that cells A1, B1, A2 B2 have respective values
1 2 3 and 4.
Readout direction is specified by a `>v', `>^', `<v', `<^',
`v>', `v<', `^>', `^<' flag. For historical reasons, in absence
of such a flag, a default direction of `^<' is assumed. This
way `(ses-range A1 B2 ^>)' will evaluate to `(1 3 2 4)',
while `(ses-range A1 B2 >^)' will evaluate to (3 4 1 2).
If the range is one row, then `>' can be used as a shorthand to
`>v' or `>^', and `<' to `<v' or `<^'.
If the range is one column, then `v' can be used as a shorthand to
`v>' or `v<', and `^' to `^>' or `v<'.
A `!' flag will remove all cells whose value is nil or `*skip*'.
A `_' flag will replace nil or `*skip*' by the value following
the `_' flag. If the `_' flag is the last argument, then they are
replaced by integer 0.
A `*', `*1' or `*2' flag will vectorize the range in the sense of
Calc. See info node `(Calc) Top'. Flag `*' will output either a
vector or a matrix depending on the number of rows, `*1' will
flatten the result to a one row vector, and `*2' will make a
matrix whatever the number of rows.
Warning: interaction with Calc is experimental and may produce
confusing results if you are not aware of Calc data format.
Use `math-format-value' as a printer for Calc objects."
(let (result-row
result
(prev-row -1)
(reorient-x nil)
(reorient-y nil)
transpose vectorize
(clean 'list))
(ses-dorange (cons from to)
(when (/= prev-row row)
(push result-row result)
(setq result-row nil))
(push (ses-cell-symbol row col) result-row)
(setq prev-row row))
(push result-row result)
(while rest
(let ((x (pop rest)))
(pcase x
('>v (setq transpose nil reorient-x nil reorient-y nil))
('>^ (setq transpose nil reorient-x nil reorient-y t))
('<^ (setq transpose nil reorient-x t reorient-y t))
('<v (setq transpose nil reorient-x t reorient-y nil))
('v> (setq transpose t reorient-x nil reorient-y t))
('^> (setq transpose t reorient-x nil reorient-y nil))
('^< (setq transpose t reorient-x t reorient-y nil))
('v< (setq transpose t reorient-x t reorient-y t))
((or '* '*2 '*1) (setq vectorize x))
('! (setq clean 'ses--clean-!))
('_ (setq clean `(lambda (&rest x)
(ses--clean-_ x ,(if rest (pop rest) 0)))))
(_
(cond
; shorthands one row
((and (null (cddr result)) (memq x '(> <)))
(push (intern (concat (symbol-name x) "v")) rest))
; shorthands one col
((and (null (cdar result)) (memq x '(v ^)))
(push (intern (concat (symbol-name x) ">")) rest))
(t (error "Unexpected flag `%S' in ses-range" x)))))))
(if reorient-y
(setcdr (last result 2) nil)
(setq result (cdr (nreverse result))))
(unless reorient-x
(setq result (mapcar #'nreverse result)))
(when transpose
(let ((ret (mapcar (lambda (x) (list x)) (pop result))) iter)
(while result
(setq iter ret)
(dolist (elt (pop result))
(setcar iter (cons elt (car iter)))
(setq iter (cdr iter))))
(setq result ret)))
(cl-flet ((vectorize-*1
(clean result)
(cons clean (cons (quote 'vec) (apply #'append result))))
(vectorize-*2
(clean result)
(cons clean (cons (quote 'vec)
(mapcar (lambda (x)
(cons clean (cons (quote 'vec) x)))
result)))))
(pcase vectorize
('nil (cons clean (apply #'append result)))
('*1 (vectorize-*1 clean result))
('*2 (vectorize-*2 clean result))
('* (funcall (if (cdr result)
#'vectorize-*2
#'vectorize-*1)
clean result))))))
(defun ses-delete-blanks (&rest args)
"Return ARGS reversed, with the blank elements (nil and *skip*) removed."
(let (result)
(dolist (cur args)
(unless (memq cur '(nil *skip*))
(push cur result)))
result))
(defun ses+ (&rest args)
"Compute the sum of the arguments, ignoring blanks."
(apply #'+ (apply #'ses-delete-blanks args)))
(defun ses-average (list)
"Calculate the sum of the numbers in LIST, divided by their length.
Blanks are ignored. Result is always floating-point, even if all
args are integers."
(setq list (apply #'ses-delete-blanks list))
(/ (float (apply #'+ list)) (length list)))
(defmacro ses-select (fromrange test torange)
"Select cells in FROMRANGE that are `equal' to TEST.
For each match, return the corresponding cell from TORANGE.
The ranges are macroexpanded but not evaluated so they should be
either (ses-range BEG END) or (list ...). The TEST is evaluated."
(setq fromrange (cdr (macroexpand fromrange))
torange (cdr (macroexpand torange))
test (eval test t))
(or (= (length fromrange) (length torange))
(error "ses-select: Ranges not same length"))
(let (result)
(dolist (x fromrange)
(if (equal test (symbol-value x))
(push (car torange) result))
(setq torange (cdr torange)))
(cons 'list result)))
;;All standard formulas are safe
(dolist (x '(ses-cell-value ses-range ses-delete-blanks ses+ ses-average
ses-select))
(put x 'side-effect-free t))
;;----------------------------------------------------------------------------
;; Standard print functions
;;----------------------------------------------------------------------------
(defun ses-center (value &optional span fill printer)
"Print VALUE, centered within column.
FILL is the fill character for centering (default = space).
SPAN indicates how many additional rightward columns to include
in width (default = 0).
PRINTER is the printer to use for printing the value, default is the
column printer if any, or the spreadsheet the spreadsheet default
printer otherwise."
(setq printer (or printer (ses-col-printer ses--col) ses--default-printer))
(let ((width (ses-col-width ses--col))
half)
(or fill (setq fill ?\s))
(or span (setq span 0))
(setq value (ses-call-printer printer value))
(dotimes (x span)
(setq width (+ width 1 (ses-col-width (+ ses--col span (- x))))))
;; Set column width.
(setq width (- width (string-width value)))
(if (<= width 0)
value ; Too large for field, anyway.
(setq half (make-string (/ width 2) fill))
(concat half value half
(if (> (% width 2) 0) (char-to-string fill))))))
(defun ses-center-span (value &optional fill printer)
"Print VALUE, centered within the span that starts in the current column
and continues until the next nonblank column.
FILL specifies the fill character (default = space)."
(let ((end (1+ ses--col)))
(while (and (< end ses--numcols)
(memq (ses-cell-value ses--row end) '(nil *skip*)))
(setq end (1+ end)))
(ses-center value (- end ses--col 1) fill printer)))
(defun ses-dashfill (value &optional span printer)
"Print VALUE centered using dashes.
SPAN indicates how many rightward columns to include in width (default = 0)."
(ses-center value span ?- printer))
(defun ses-dashfill-span (value &optional printer)
"Print VALUE, centered using dashes.
Centers within the span that starts in the current column and continues
until the next nonblank column."
(ses-center-span value ?- printer))
(defun ses-tildefill-span (value &optional printer)
"Print VALUE, centered using tildes.
Centers within the span that starts in the current column and continues
until the next nonblank column."
(ses-center-span value ?~ printer))
(defun ses-prin1 (value)
"Shorthand for `(prin1-to-string VALUE t)'.
Useful to handle the default behavior in custom lambda based
printer functions."
(prin1-to-string value t))
(defun ses-unsafe (_value)
"Substitute for an unsafe formula or printer."
(error "Unsafe formula or printer"))
;;All standard printers are safe, including ses-unsafe!
(dolist (x (cons 'ses-unsafe ses-standard-printer-functions))
(put x 'side-effect-free t))
(defun ses-unload-function ()
"Unload the Simple Emacs Spreadsheet."
(advice-remove 'yank #'ses--advice-yank)
(advice-remove 'copy-region-as-kill #'ses--advice-copy-region-as-kill)
;; Continue standard unloading.
nil)
(provide 'ses)
;;; ses.el ends here
|