Comment: | Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | descendants | master | trunk |
Files: | files | file ages | folders |
SHA3-256: |
f2fda60abd183e6ea7adfc3fb2cba581 |
User & Date: | arthurcnorman@users.sourceforge.net on 2011-09-02 18:13:33 |
Other Links: | manifest | tags |
2011-09-02
| ||
18:41:44 |
discard some files that are probably not especially useful
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1376 2bfe0521-f11c-4a00-b80e-6202646ff360 check-in: 2bf132ecc3 user: arthurcnorman@users.sourceforge.net tags: master, trunk | |
18:13:33 |
Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 check-in: f2fda60abd user: arthurcnorman@users.sourceforge.net tags: master, trunk | |
Added LICENSE version [fe78eb7312].
> > > | 1 2 3 | The files here have a variety of license and are NOT to be considered to fall under the BSD license used with the main distribution. |
Added README version [4de28ae9c1].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | These are informal and not-guaranteed-complete smapshots of some previous releases of Reduce. There should not be any binaries or serious build scripts here and these are all to be viewed as OUT OF DATE and NOT SUPPORTED AT ALL. However some people may enjoy seeing how the code-base has grown and getting a bit of insight into the world of the past. And developers tracking a newly uncovered bug may sometimes find it useful to look back into these archives in case that gives insight. PLEASE do not ask the main developers about building or installing from these old files. ALL current support will be focussed on the main version. The files here typically have old restrictive copyright notices and sometimes restrictive license terms. They are included here by virtue of the permission that their originators granted to Tony Hearn and his distributors to use them, but you should not modify and redistribute anything from this directory without careful thought. Arthur Norman. August 2011 |
Added r33/alg1.red version [cb09116124].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module alg!-parse; % Particular infix operators for algebraic mode. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. newtok '((!. !+) add); newtok '((!. !*) mult); newtok '((!. !^) to); newtok '((!. !* !*) to); newtok '((!. !/) over); infix .^,.*,.+,./; endmodule; module alg!-form; % Some particular algebraic mode analysis functions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(inputbuflis!* resultbuflis!* ws); symbolic procedure forminput(u,vars,mode); begin scalar x; u := cadr u; if x := assoc(u,inputbuflis!*) then return cadr x else rederr list("Entry",u,"not found") end; put('input,'formfn,'forminput); symbolic procedure formws(u,vars,mode); begin scalar x; if x := assoc(cadr u,resultbuflis!*) then return mkquote cdr x else rederr list("Entry",cadr u,"not found") end; put('ws,'formfn,'formws); endmodule; module intro; % Introductory material for algebraic mode. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*cref !*exp !*intstr !*lcm !*mcd !*mode !*precise !*rationalize !*sub2); global '(!*factor !*fort !*ifactor !*msg !*nat !*nero !*period !*pri !*reduced !*resubs !*val !*xdn erfg!* exlist!* initl!* nat!*!* ofl!* posn!* simpcount!* simplimit!* subfg!* tstack!*); % Non-local variables needing top level initialization. !*exp := t; %expansion control flag; !*lcm := t; %least common multiple computation flag; !*mcd := t; %common denominator control flag; !*mode := 'symbolic; %current evaluation mode; !*msg := t; %flag controlling message printing; !*nat := t; %specifies natural printing mode; !*period := t; %prints a period after a fixed coefficient %when FORT is on; !*resubs := t; %external flag controlling resubstitution; !*val := t; %controls operator argument evaluation; !*xdn := t; %flag indicating that denominators should be %expanded; exlist!* := '((!*)); %property list for standard forms used as % kernels; initl!* := append('(subfg!* !*sub2 tstack!*),initl!*); simpcount!* := 0; %depth of recursion within simplifier; simplimit!* := 2000; %allowed recursion limit within simplifier; subfg!* := t; %flag to indicate whether substitution %is required during evaluation; tstack!* := 0; %stack counter in SIMPTIMES; % Initial values of some global variables in BEGIN1 loops. put('subfg!*,'initl,t); put('tstack!*,'initl,0); % Description of some non-local variables used in algebraic mode. % alglist!* := nil; %association list for previously simplified %expressions; % asymplis!* := nil; %association list of asymptotic replacements; % cursym!* current symbol (i. e. identifier, parenthesis, % delimiter, e.t.c,) in input line; % dmode!* := nil; %name of current polynomial domain mode if not %integer; % domainlist!* := nil; %list of currently supported poly domain modes; % dsubl!* := nil; %list of previously calculated derivatives of % expressions; % exptl!* := nil; %list of exprs with non-integer exponents; % frlis!* := nil; %list of renamed free variables to be found in %substitutions; % kord!* := nil; %kernel order in standard forms; % kprops!* := nil; %list of active non-atomic kernel plists; % mchfg!* := nil; %indicates that a pattern match occurred during %a cycle of the matching routines; % mul!* := nil; %list of additional evaluations needed in a %given multiplication; % nat!*!* := nil; %temporary variable used in algebraic mode; % ncmp!* := nil; %flag indicating non-commutative multiplication %mode; % ofl!* := nil; %current output file name; % posn!* := nil; %used to store output character position in %printing functions; % powlis!* := nil; %association list of replacements for powers; % powlis1!* := nil; %association list of conditional replacements %for powers; % subl!* := nil; %list of previously evaluated expressions; % wtl!* := nil; %tells that a WEIGHT assignment has been made; % !*ezgcd := nil; %ezgcd calculation flag; % !*float := nil; %floating arithmetic mode flag; % !*fort := nil; %specifies FORTRAN output; % !*gcd := nil; %greatest common divisor mode flag; % !*group := nil; %causes expressions to be grouped when EXP off; % !*intstr := nil; %makes expression arguments structured; % !*int indicates interactive system use; % !*match := nil; %list of pattern matching rules; % !*nero := nil; %flag to suppress printing of zeros; % !*nosubs := nil; %internal flag controlling substitution; % !*numval := nil; %used to indicate that numerical expressions %should be converted to a real value; % !*outp := nil; %holds prefix output form for extended output %package; % !*pri := nil; %indicates that fancy output is required; % !*reduced := nil; %causes arguments of radicals to be factored. %E.g., sqrt(-x) --> i*sqrt(x); % !*sub2 := nil; %indicates need for call of RESIMP; % ***** UTILITY FUNCTIONS *****. symbolic procedure mkid(x,y); % creates the ID XY from identifier X and (evaluated) object Y. if not idp x then typerr(x,"MKID root") else if atom y and (idp y or fixp y and not minusp y) then intern compress nconc(explode x,explode y) else typerr(y,"MKID index"); flag('(mkid),'opfn); symbolic procedure multiple!-result(z,w); % Z is a list of items (n . prefix-form), in ordering in descending % order wrt n, which must be non-negative. W is either an array % name, another id, a template for a multi-dimensional array or NIL. % Elements of Z are accordingly stored in W if it is non-NIL, or % returned as a list otherwise. begin scalar x,y; if null w then return 'list . reversip!* fillin z; x := getrtype w; if x and not x eq 'array then typerr(w,"array or id"); lpriw("*****", list(if x eq 'array then "ARRAY" else "ID", "fill no longer supported --- use lists instead")); if atom w then (if not arrayp w then (if numberp(w := reval w) then typerr(w,'id))) else if not arrayp car w then typerr(car w,'array) else w := car w . for each x in cdr w collect if x eq 'times then x else reval x; x := length z-1; % don't count zeroth element; if not((not atom w and atom car w and (y := dimension car w)) or ((y := dimension w) and null cdr y)) then <<y := explode w; w := nil; for each j in z do <<w := intern compress append(y,explode car j) . w; setk1(car w,cdr j,t)>>; lprim if length w=1 then list(car w,"is non zero") else aconc!*(reversip!* w,"are non zero"); return x>> else if atom w then <<if caar z neq (car y-1) then <<y := list(caar z+1); put(w,'array,mkarray(y,'algebraic)); put(w,'dimension,y)>>; w := list(w,'times)>>; y := pair(cdr w,y); while y and not smemq('times,caar y) do y := cdr y; if null y then errach "MULTIPLE-RESULT"; y := cdar y-reval subst(0,'times,caar y)-1; %-1 needed since DIMENSION gives length, not highest index; if caar z>y then rederr list("Index",caar z,"out of range"); repeat if null z or y neq caar z then setelv(subst(y,'times,w),0) else <<setelv(subst(y,'times,w),cdar z); z := cdr z>> until (y := y-1) < 0; return x end; symbolic procedure fillin u; % fills in missing terms in multiple result argument list u % and returns list of coefficients. if null u then nil else fillin1(u,caar u); symbolic procedure fillin1(u,n); if n<0 then nil else if u and caar u=n then cdar u . fillin1(cdr u,n-1) else 0 . fillin1(u,n-1); % ***** FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES ***** symbolic procedure msgpri(u,v,w,x,y); begin scalar nat1,z; if null y and null !*msg then return; nat1 := !*nat; !*nat := nil; if ofl!* and (!*fort or not nat1) then go to c; a: terpri(); lpri ((if null y then "***" else "*****") . if u and atom u then list u else u); posn!* := posn(); maprin v; prin2 " "; lpri if w and atom w then list w else w; posn!* := posn(); maprin x; terpri!*(t); % IF NOT Y OR Y EQ 'HOLD THEN TERPRI(); if null z then go to b; wrs cdr z; go to d; b: if null ofl!* then go to d; c: z := ofl!*; wrs nil; go to a; d: !*nat := nat1; if y then if y eq 'hold then erfg!* := y else error1() end; symbolic procedure errach u; begin terpri!* t; lprie "CATASTROPHIC ERROR *****"; printty u; lpriw(" ",nil); rederr "Please send output and input listing to A. C. Hearn" end; symbolic procedure errpri1 u; msgpri("Substitution for",u,"not allowed",nil,t); % was 'HOLD symbolic procedure errpri2(u,v); msgpri("Syntax error:",u,"invalid",nil,v); symbolic procedure redmsg(u,v); if null !*msg or v neq "operator" then nil else if terminalp() then yesp list("Declare",u,v,"?") or error1() else lprim list(u,"declared",v); symbolic procedure typerr(u,v); <<terpri!* t; prin2!* "***** "; if not atom u and atom car u and cdr u and atom cadr u and null cddr u then <<prin2!* car u; prin2!* " "; prin2!* cadr u>> else maprin u; prin2!* " invalid as "; prin2!* v; terpri!* nil; erfg!* := t; error1()>>; % ***** ALGEBRAIC MODE DECLARATIONS ***** flag ('(aeval arrayfn cond getel go prog progn prog2 return reval setq setk setel varpri !*s2i),'nochange); flag ('(or and not member memq equal neq eq geq greaterp leq fixp lessp numberp ordp),'boolean); flag ('(or and not),'boolargs); deflist ('((exp ((nil (rmsubs)) (t (rmsubs)))) (factor ((nil (setq !*exp t) (rmsubs)) (t (setq !*exp nil) (rmsubs)))) (fort ((nil (setq !*nat nat!*!*)) (t (setq !*nat nil)))) (gcd ((t (rmsubs)))) (intstr ((nil (rmsubs)) (t (rmsubs)))) (mcd ((nil (rmsubs)) (t (rmsubs)))) (nat ((nil (setq nat!*!* nil)) (t (setq nat!*!* t)))) (numval ((t (rmsubs)))) (rationalize ((t (rmsubs)))) (reduced ((t (rmsubs)))) (val ((t (rmsubs))))),'simpfg); switch exp,cref,factor,fort,gcd,ifactor,intstr,lcm,mcd,nat,nero,numval, period,precise,pri,rationalize,reduced; % resubs, val. endmodule; module general; % General functions for the support of REDUCE. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!!arbint); !!arbint := 0; % Index for arbitrary constants. symbolic procedure atomlis u; null u or (atom car u and atomlis cdr u); symbolic procedure carx(u,v); if null cdr u then car u else rederr list("Wrong number of arguments to",v); symbolic procedure delasc(u,v); if null v then nil else if atom car v or u neq caar v then car v . delasc(u,cdr v) else cdr v; symbolic procedure eqexpr u; % Returns true if U is an equation. not atom u and car u memq '(eq equal) and cddr u and null cdddr u; symbolic procedure evenp x; remainder(x,2)=0; flag('(evenp),'opfn); % Make a symbolic operator. symbolic procedure get!*(u,v); if numberp u then nil else get(u,v); symbolic procedure lengthc u; %gives character length of U excluding string and escape chars; begin integer n; scalar x; n := 0; x := explode u; if car x eq '!" then return length x-2; while x do <<if car x eq '!! then x := cdr x; n := n+1; x := cdr x>>; return n end; symbolic procedure lhs u; % Returns the left-hand-side of an equation. if not eqexpr u then typerr(u,"equation") else cadr u; symbolic procedure rhs u; % Returns the right-hand-side of an equation. if not eqexpr u then typerr(u,"equation") else caddr u; flag('(lhs rhs),'opfn); % Make symbolic operators. symbolic procedure makearbcomplex; begin scalar ans; !!arbint := !!arbint+1; ans := car(simp!*(list('arbcomplex, !!arbint))); % This CAR is NUMR, which is not yet defined. return ans end; symbolic procedure mapcons(u,v); for each j in u collect v . j; symbolic procedure mappend(u,v); for each j in u collect append(v,j); symbolic procedure nlist(u,n); if n=0 then nil else u . nlist(u,n-1); symbolic procedure nth(u,n); car pnth(u,n); symbolic procedure pnth(u,n); if null u then rederr "Index out of range" else if n=1 then u else pnth(cdr u,n-1); symbolic procedure permp(u,v); if null u then t else if car u eq car v then permp(cdr u,cdr v) else not permp(cdr u,subst(car v,car u,cdr v)); symbolic procedure posintegerp u; % True if U is a positive (non-zero) integer. numberp u and fixp u and u>0; symbolic procedure remove(x,n); %Returns X with Nth element removed; if null x then nil else if n=1 then cdr x else car x . remove(cdr x,n-1); symbolic procedure repasc(u,v,w); % replaces value of key U by V in association list W. if null w then rederr list("key",u,"not found") else if u = caar w then (u . v) . cdr w else car w . repasc(u,v,cdr w); symbolic procedure repeats x; if null x then nil else if car x member cdr x then car x . repeats cdr x else repeats cdr x; symbolic procedure revpr u; cdr u . car u; symbolic procedure smember(u,v); %determines if S-expression U is a member of V at any level; if u=v then t else if atom v then nil else smember(u,car v) or smember(u,cdr v); symbolic procedure smemql(u,v); %Returns those members of id list U contained in V at any %level (excluding quoted expressions); if null u then nil else if smemq(car u,v) then car u . smemql(cdr u,v) else smemql(cdr u,v); symbolic procedure smemqlp(u,v); %True if any member of id list U is contained at any level %in V (exclusive of quoted expressions); if null v then nil else if atom v then v memq u else if car v eq 'quote then nil else smemqlp(u,car v) or smemqlp(u,cdr v); symbolic procedure spaces n; for i := 1:n do prin2 " "; symbolic procedure subla(u,v); begin scalar x; if null u or null v then return v else if atom v then return if x:= atsoc(v,u) then cdr x else v else return(subla(u,car v) . subla(u,cdr v)) end; symbolic procedure xnp(u,v); %returns true if the atom lists U and V have at least one common %element; u and (car u memq v or xnp(cdr u,v)); endmodule; module sqconsel; % Constructors and selectors for standard forms. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. smacro procedure u.+v; %standard (polynomial) addition constructor; u . v; smacro procedure lc u; %leading coefficient of standard form; cdar u; smacro procedure ldeg u; %leading degree of standard form; cdaar u; smacro procedure lt u; %leading term of standard form; car u; smacro procedure u.*v; %standard form multiplication constructor; u . v; smacro procedure mvar u; %main variable of standard form; caaar u; smacro procedure lpow u; %leading power of standard form; caar u; smacro procedure pdeg u; %returns the degree of the power U; cdr u; smacro procedure red u; %reductum of standard form; cdr u; smacro procedure tc u; %coefficient of standard term; cdr u; smacro procedure tdeg u; %degree of standard term; cdar u; smacro procedure tpow u; %power of standard term; car u; smacro procedure tvar u; %main variable of a standard term; caar u; smacro procedure numr u; %numerator of standard quotient; car u; smacro procedure denr u; %denominator of standard quotient; cdr u; smacro procedure u ./ v; %constructor for standard quotient; u . v; symbolic smacro procedure domainp u; atom u or atom car u; endmodule; module sqconvert; % Procedures for converting between parts of standard % quotients and prefix forms. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mcd); global '(wtl!*); symbolic procedure !*a2f u; %U is an algebraic expression. Value is the equivalent form %or an error if conversion is not possible; !*q2f simp!* u; symbolic procedure !*a2k u; %U is an algebraic expression. Value is the equivalent kernel %or an error if conversion is not possible. %earlier versions used SIMP0; begin scalar x; if kernp(x := simp!* u) then return mvar numr x else typerr(u,'kernel) end; symbolic procedure !*d2q u; %converts domain element U into a standard quotient. if numberp u then if zerop u then nil ./ 1 % else if floatp u then mkfloat u ./ 1 else u ./ 1 else if eqcar(u,'!:rn!:) and !*mcd then cdr u else u ./ 1; symbolic procedure !*ff2a(u,v); % Converts ratio of two forms U and V to a prefix form. (if wtl!* then prepsq x else mk!*sq x) where x = cancel( u ./ v); smacro procedure !*f2a u; prepf u; smacro procedure !*f2q u; %U is a standard form, value is a standard quotient; u . 1; smacro procedure !*k2f u; %U is a kernel, value is a standard form; list ((u .** 1) . 1); smacro procedure !*k2q u; %U is a kernel, value is a standard quotient; list((u .** 1) . 1) . 1; symbolic procedure !*n2f u; %U is a number. Value is a standard form; if zerop u then nil else u; smacro procedure !*p2f u; %U is a standard power, value is a standard form; list (u . 1); smacro procedure !*p2q u; %U is a standard power, value is a standard quotient; list(u . 1) . 1; symbolic procedure !*q2a u; %U is a standard quotient, value is an algebraic expression. prepsqxx u; symbolic procedure !*q2f u; %U is a standard quotient, value is a standard form; if denr u=1 then numr u else typerr(prepsq u,'polynomial); symbolic procedure !*q2k u; %U is a standard quotient, value is a kernel or an error if %conversion not possible; if kernp u then mvar numr u else typerr(prepsq u,'kernel); smacro procedure !*t2f u; %U is a standard term, value is a standard form; list u; smacro procedure !*t2q u; %U is a standard term, value is a standard quotient; list u . 1; endmodule; module sort; % A simple sorting routine. % Author: Arthur C. Norman. % Modified by: Anthony C. Hearn to use list changing operations for % greater efficiency. expr procedure sort(lst,fn); begin scalar tree; if null lst or null cdr lst then return lst; tree := list(car lst,nil); while pairp(lst := cdr lst) do treeadd(car lst,tree,fn); return tree2list(tree,nil) end; expr procedure tree2list(tree,lst); % { Convert a sorted tree into a list} if null tree then lst else tree2list(cadr tree,car tree . tree2list(cddr tree,lst)); expr procedure treeadd(item,node,fn); % { add item to a node, using fn as an order predicate} if apply2(fn,item, car node) then if cadr node then treeadd(item,cadr node,fn) else rplaca(cdr node,list(item,nil)) else if cddr node then treeadd(item,cddr node,fn) else rplacd(cdr node,list(item,nil)); % expr procedure treeadd(item,tree,fn); % % add item to a tree, using fn as an order predicate; % if null tree then item . (nil . nil) % else if apply2(fn,item,car tree) % then car tree . (treeadd(item,cadr tree,fn) . cddr tree) % else car tree . (cadr tree . treeadd(item,cddr tree,fn)); symbolic procedure idsort u; % lexicographically sort list of ids. sort(u,function idcompare); symbolic procedure idcompare(u,v); % compare lexicographical ordering of two ids. idcomp1(explode2 u,explode2 v); symbolic procedure idcomp1(u,v); if null u then t else if null v then nil else if car u eq car v then idcomp1(cdr u,cdr v) else orderp(car u,car v); % Comparison functions and special cases for sorting. symbolic procedure lesspcar(a,b); car a < car b; symbolic procedure lesspcdr(a,b); cdr a < cdr b; symbolic procedure lessppair(a,b); if car a = car b then cdr a<cdr b else car a<car b; symbolic procedure greaterpcdr(a,b); cdr a > cdr b; symbolic procedure lesspcdadr(a,b); cdadr a < cdadr b; symbolic procedure lesspdeg(a,b); if domainp b then nil else if domainp a then t else ldeg a<ldeg b; symbolic procedure ordopcar(a,b); ordop(car a,car b); symbolic procedure orderfactors(a,b); if cdr a = cdr b then ordp(car a,car b) else cdr a < cdr b; endmodule; module reval; % Functions for algebraic evaluation of prefix forms. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*exp !*intstr alglist!* dmode!*); global '(!*resubs !*sqvar!* !*val); symbolic procedure reval u; reval1(u,t); symbolic procedure aeval u; reval1(u,nil); symbolic procedure reval1(u,v); begin scalar alglist!*,x; % We rebind alglist!* to avoid invalid computation in loops. if null u then return nil % this may give trouble else if stringp u then return u else if numberp u and fixp u then return if flagp(dmode!*,'convert) then reval2(u,v) else u else if atom u then if idp u and (x := get(u,'avalue)) then return reval1(cadr x,v) else nil else if not idp car u or car u eq '!*comma!* then errpri2(u,t) else if car u eq '!*sq then return if caddr u then if null v then u else prepsqxx cadr u else reval2(u,v) else if flagp(car u,'opfn) then return reval1(opfneval u,v) else if x := get(car u,'psopfn) then return apply1(x,cdr u) % Note that we assume that the results of such functions are % always returned in evaluated form. else if arrayp car u then return reval1(getelv u,v); return if x := getrtype u then apply2(get(x,'evfn),u,v) else reval2(u,v) end; symbolic procedure opfneval u; eval(car u . for each j in (if flagp(car u,'noval) then cdr u else revlis cdr u) collect mkquote j); flag('(reval),'opfn); % to make it a symbolic operator. symbolic procedure reval2(u,v); (if null v then mk!*sq x else prepsqxx x) where x = simp!* u; symbolic procedure getrtype u; % Returns overall algebraic type of u (or NIL is expression is a % scalar). Analysis is incomplete for efficiency reasons. % Type conflicts will later be resolved when expression is evaluated. begin scalar x,y; return if atom u then if not idp u then nil else if flagp(u,'share) then getrtype eval u else if x := get(u,'rtype) then if y := get(x,'rtypefn) then apply1(y,nil) else x else nil else if not idp car u then nil else if (x := get(car u,'rtype)) and (x := get(x,'rtypefn)) then apply1(x,cdr u) else if x := get(car u,'rtypefn) then apply1(x,cdr u) else nil end; deflist(' ((difference getrtypecar) (expt getrtypecar) (minus getrtypecar) (plus getrtypecar) (quotient getrtypeor) (recip getrtypecar) (times getrtypeor) (!*sq (lambda (x) nil)) ),'rtypefn); symbolic procedure getrtypecar u; getrtype car u; symbolic procedure getrtypeor u; u and (getrtype car u or getrtypeor cdr u); symbolic procedure !*eqn2a u; % Converts equation U to the difference of its two arguments. if null cdr u or null cddr u or cdddr u then typerr(u,"equation") else list('difference,cadr u,caddr u); symbolic procedure getelv u; %returns the value of the array element U; getel(car u . for each x in cdr u collect ieval x); symbolic procedure setelv(u,v); setel(car u . for each x in cdr u collect ieval x,v); symbolic procedure revlis u; for each j in u collect reval j; symbolic procedure revop1 u; if !*val then car u . revlis cdr u else u; symbolic procedure mk!*sq u; if null numr u then 0 else if atom numr u and denr u=1 then numr u else '!*sq . expchk u . if !*resubs then !*sqvar!* else list nil; symbolic procedure expchk u; if !*exp then u else canprod(mkprod!* numr u,mkprod!* denr u); symbolic procedure lengthreval u; begin scalar v,w; if length u neq 1 then rederr "LENGTH called with wrong number of arguments" else if idp car u and arrayp car u then return 'list . get(car u,'dimension); v := aeval car u; if (w := getrtype v) and (w := get(w,'lengthfn)) then return apply1(w,v) else if atom v then return 1 else if not idp car v or not(w := get(car v,'lengthfn)) then typerr(u,"length argument") else return apply1(w,cdr v) end; put('length,'psopfn,'lengthreval); endmodule; module algbool; % Evaluation functions for algebraic boolean operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure evalequal(u,v); begin scalar x; return if (x := getrtype u) neq getrtype v then nil else if null x then numberp(x := reval list('difference,u,v)) and zerop x else u=v end; put('equal,'boolfn,'evalequal); symbolic procedure equalreval u; 'equal . revlis u; put('equal,'psopfn,'equalreval); symbolic procedure evalgreaterp(u,v); (lambda x; if not atom denr x or not domainp numr x then typerr(mk!*sq if minusf numr x then negsq x else x,"number") else numr x and !:minusp numr x) simp!* list('difference,v,u); put('greaterp,'boolfn,'evalgreaterp); symbolic procedure evalgeq(u,v); not evallessp(u,v); put('geq,'boolfn,'evalgeq); symbolic procedure evallessp(u,v); evalgreaterp(v,u); put('lessp,'boolfn,'evallessp); symbolic procedure evalleq(u,v); not evalgreaterp(u,v); put('leq,'boolfn,'evalleq); symbolic procedure evalneq(u,v); not evalequal(u,v); put('neq,'boolfn,'evalneq); symbolic procedure evalnumberp u; (lambda x; atom denr x and domainp numr x) simp!* u; put('numberp,'boolfn,'evalnumberp); endmodule; module simp; % Functions to convert prefix forms into canonical forms. % Author: Anthony C. Hearn. % Modifications by: F. Kako. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*asymp!* !*exp !*gcd !*keepsqrts !*mcd !*mode !*numval !*precise !*rationalize !*sub2 !*uncached alglist!* current!-modulus dmode!*); global '(!*convert !*match !*reduced exptl!* frlis!* initl!* mul!* ncmp!* powlis1!* simpcount!* simplimit!* subfg!* tstack!* ws); % !*KEEPSQRTS causes SQRT rather than EXPT to be used; !*convert := t; put('simpcount!*,'initl,0); initl!* := union('(simpcount!*),initl!*); simplimit!* := 1000; flagop noncom; symbolic procedure simp!* u; begin scalar !*asymp!*,x; if eqcar(u,'!*sq) and caddr u then return cadr u; x := mul!* . !*sub2; %save current environment; mul!* := nil; u:= simp u; for each j in mul!* do u:= apply1(j,u); mul!* := car x; u := subs2 u; if !*rationalize then u := rationalizesq u; !*sub2 := cdr x; % If any leading terms have cancelled, a gcd check is required. if !*asymp!* and !*rationalize then u := gcdchk u; return u end; symbolic procedure subs2 u; begin scalar xexp,v,w; if null subfg!* then return u else if !*sub2 or powlis1!* then u := subs2q u; if null !*match or null numr u then return u else if null !*exp then <<xexp:= t; !*exp := t; v := u; w := u := resimp u>>; u := subs3q u; if xexp then <<!*exp := nil; if u=w then u := v>>; return u end; symbolic procedure simp u; begin scalar x; if simpcount!*>simplimit!* then <<simpcount!* := 0; rederr "Simplification recursion too deep">> else if eqcar(u,'!*sq) and caddr u then return cadr u else if null !*uncached and (x := assoc(u,alglist!*)) then return <<if cadr x then !*sub2 := t; cddr x>>; simpcount!* := simpcount!*+1; if atom u then return !*ssave(simpatom u,u) else if not idp car u then if idp caar u and (x := get(caar u,'name)) then return !*ssave(u,u) %%% not yet correct else errpri2(u,t) else if flagp(car u,'opfn) then if getrtype(x := opfneval u) then typerr(u,"scalar") else return !*ssave(simp x,u) else if x := get(car u,'psopfn) then if getrtype(x := apply1(x,cdr u)) then typerr(u,"scalar") else if x=u then return !*ssave(!*k2q x,u) else return !*ssave(simp x,u) else if x := get(car u,'polyfn) then return !*ssave(!*f2q apply(x, for each j in cdr u collect !*q2f simp!* j), u) else if get(car u,'opmtch) and not(get(car u,'simpfn) eq 'simpiden) and (x := opmtch revop1 u) then return !*ssave(simp x,u) else if x := get(car u,'simpfn) then return !*ssave(if flagp(car u,'full) or x eq 'simpiden then apply1(x,u) else apply1(x,cdr u),u) else if (x := get(car u,'rtype)) and (x := get(x,'getelemfn)) then return !*ssave(simp apply1(x,u),u) else if flagp(car u,'boolean) or get(car u,'infix) then typerr(if x := get(car u,'prtch) then x else car u, "algebraic operator") else if flagp(car u,'nochange) then return !*ssave(simp eval u,u) else if get(car u,'psopfn) then typerr(u,"scalar") else <<redmsg(car u,"operator"); mkop car u; return !*ssave(simp u,u)>>; end; put('array,'getelemfn,'getelv); put('array,'setelemfn,'setelv); symbolic procedure getinfix u; %finds infix symbol for U if it exists; begin scalar x; return if x := get(u,'prtch) then x else u end; symbolic procedure !*ssave(u,v); % We keep sub2!* as well, since there may be an unsubstituted % power in U. begin if not !*uncached then alglist!* := (v . (!*sub2 . u)) . alglist!*; simpcount!* := simpcount!*-1; return u end; symbolic procedure numlis u; null u or (numberp car u and numlis cdr u); symbolic procedure simpatom u; if null u then nil ./ 1 else if numberp u then if zerop u then nil ./ 1 else if not fixp u then !*d2q int!-equiv!-chk if null dmode!* then mkrat u else if dmode!* eq '!:ft!: then mkfloat u else apply1(get('!:ft!:,dmode!*),mkfloat u) % we assume that a non-fixp number is a float. else if flagp(dmode!*,'convert) then !*d2q int!-equiv!-chk apply1(get(dmode!*,'i2d),u) else u ./ 1 % else if not idp u then typerr(u,"identifier") else if flagp(u,'share) then simp eval u else begin scalar z; if z := get(u,'idvalfn) then return apply1(z,u) else if !*numval and dmode!* and flagp(u,'constant) and (z := get(u,dmode!*)) and not errorp(z := errorset(list('apply,mkquote z,nil), nil,nil)) then return !*d2q int!-equiv!-chk car z else if getrtype u then typerr(u,'scalar) else return mksq(u,1) end; flag('(e pi),'constant); symbolic procedure mkrat u; begin scalar x; x := !*ft2rn mkfloat u; msgpri(nil,u,"represented by", if atom x then x else list('quotient,cadr x,cddr x), nil); return x end; symbolic procedure mkop u; begin scalar x; if null u then typerr("Local variable","operator") else if (x := gettype u) eq 'operator then lprim list(u,"already defined as operator") else if x and not x eq 'procedure then typerr(u,'operator) else if u memq frlis!* then typerr(u,"free variable") else put(u,'simpfn,'simpiden) end; symbolic procedure operatorp u; gettype u eq 'operator; symbolic procedure simpcar u; simp car u; put('quote,'simpfn,'simpcar); symbolic procedure share u; begin scalar y; for each x in u do if not idp x then typerr(x,"id") else <<global list x; if y := get(x,'avalue) then set(x,cadr y); flag(list x,'share)>> end; rlistat '(share); flag('(ws !*mode),'share); % ***** SIMPLIFICATION FUNCTIONS FOR EXPLICIT OPERATORS ***** symbolic procedure simpabs u; (lambda x; absf!* numr x ./ denr x) simpcar u; put('abs,'simpfn,'simpabs); symbolic procedure simpexpon u; % Exponents must not use non-integer arithmetic unless NUMVAL is on, % in which case DOMAINVALCHK must know the mode. if !*numval and not(dmode!* eq '!:mod!:) then simp!* u else begin scalar dmode!*,alglist!*; return simp!* u; end; symbolic procedure simpexpt u; begin scalar flg,m,n,x,y; n := simpexpon carx(cdr u,'expt); u := car u; a: if onep u then return 1 ./ 1; m := numr n; if not domainp m or not domainp denr n then go to nonumexp else if null m then return if numberp u and zerop u then rederr " 0**0 formed" else 1 ./ 1; x := simp u; %we could use simp!* here, except that it messes up the %handling of gamma matrix expressions; if null numr x then return nil ./ 1 else if atom m and m>0 and denr n=1 and domainp numr x and denr x=1 then return !*d2q if atom numr x then numr x**m else int!-equiv!-chk !:expt(numr x,m) else if y := domainvalchk('expt,list(x,n)) then return y else if not atom m or denr n neq 1 then go to nonumexp else if not m<0 then return exptsq(x,m) else if !*mcd then return invsq exptsq(x,-m) else return expsq(x,m); %using OFF EXP code here; %there may be a pattern matching problem though; nonumexp: if onep u then return 1 ./ 1 else if atom u then go to a2 else if car u eq 'times then <<n := prepsq n; x := 1 ./ 1; for each z in cdr u do x := multsq(simpexpt list(z,n),x); return x>> else if car u eq 'quotient then <<if not flg and !*mcd then go to a2; n := prepsq n; return multsq(simpexpt list(cadr u,n), simpexpt list(caddr u,list('minus,n)))>> else if car u eq 'expt then <<n := multsq(simp caddr u,n); if !*precise and numberp caddr u and evenp caddr u and numberp numr n and not evenp numr n then u := list('abs,cadr u) else u := cadr u; x := nil; go to a>> else if car u eq 'sqrt and not !*keepsqrts then <<n := multsq(1 ./ 2,n); u := cadr u; x := nil; go to a>> else if car u eq 'minus and numberp m and denr n=1 then return multsq(simpexpt list(-1,m), simpexpt list(cadr u,m)); a2: if null flg then <<flg := t; u := prepsq if null x then (x := simp!* u) else x; go to nonumexp>> else if numberp u and zerop u then return nil ./ 1 else if not numberp m then m := prepf m; n := prepf cdr n; if m memq frlis!* and n=1 then return list ((u . m) . 1) . 1; %"power" is not unique here; if !*mcd or cdr x neq 1 or not numberp m or n neq 1 or atom u then go to c % else if minusf car x then return multsq(simpexpt list(-1,m), % simpexpt list(prepf negf car x,m)); else if car u eq 'plus or not !*mcd and n=1 then return mksq(u,m); %to make pattern matching work. c:% if !*numval and domaintypep u and n=1 % and (y := domainvalchk list('expt,u,m)) *** not correct now % then return y else return simpx1(u,m,n) end; % symbolic procedure intexpt(u,n); % if null current!-modulus or null(dmode!* eq '!:mod!:) then u**n % % I'm not sure we need both here. % else if n<0 % then general!-modular!-expt(general!-modular!-recip u,-n) % else general!-modular!-expt(u,n); put('expt,'simpfn,'simpexpt); symbolic procedure simpx1(u,m,n); %U,M and N are prefix expressions; %Value is the standard quotient expression for U**(M/N); begin scalar flg,x,z; if numberp m and numberp n or null(smemqlp(frlis!*,m) or smemqlp(frlis!*,n)) then go to a; % exptp!* := t; return mksq(list('expt,u,if n=1 then m else list('quotient,m,n)),1); a: if numberp m then if minusp m then <<m := -m; go to mns>> else if fixp m then go to e else go to b else if atom m then go to b else if car m eq 'minus then <<m := cadr m; go to mns>> else if car m eq 'plus then go to pls else if car m eq 'times and numberp cadr m and fixp cadr m and numberp n then go to tms; b: z := 1; c: if idp u and not flagp(u,'used!*) then flag(list u,'used!*); if u = '(minus 1) and n=1 and null numr simp list('difference,m,'(quotient 1 2)) then return simp 'i; u := list('expt,u,if n=1 then m else list('quotient,m,n)); if not u member exptl!* then exptl!* := u . exptl!*; d: return mksq(u,if flg then -z else z); %U is already in lowest %terms; e: if numberp n and fixp n then go to int; z := m; m := 1; go to c; mns: %if numberp m and numberp n and !*rationalizeflag % then return multsq(simpx1(u,n-m,n),invsq simp u) else if !*mcd then return invsq simpx1(u,m,n); flg := not flg; go to a; pls: z := 1 ./ 1; pl1: m := cdr m; if null m then return z; z := multsq(simpexpt list(u, list('quotient,if flg then list('minus,car m) else car m,n)), z); go to pl1; tms: z := gcdn(n,cadr m); n := n/z; z := cadr m/z; m := retimes cddr m; go to c; int:z := divide(m,n); if cdr z<0 then z:= (car z - 1) . (cdr z+n); x := simpexpt list(u,car z); if cdr z=0 then return x else if n=2 then return multsq(x,simpsqrt list u) else return multsq(x,exptsq(simprad(simp!* u,n),cdr z)) end; symbolic procedure expsq(u,n); % Raises standard quotient u to negative power n with exp off. multf(expf(numr u,n),mksfpf(denr u,-n)) ./ 1; symbolic procedure expf(u,n); %U is a standard form. Value is standard form of U raised to %negative integer power N. MCD is assumed off; %what if U is invertable?; if null u then nil else if u=1 then u else if atom u then mkrn(1,u**(-n)) else if domainp u then !:expt(u,n) else if red u then mksp!*(u,n) else (lambda x; if x>0 and sfp mvar u then multf(exptf(mvar u,x),expf(lc u,n)) else mvar u .** x .* expf(lc u,n) .+ nil) (ldeg u*n); symbolic procedure simprad(u,n); %simplifies radical expressions; begin scalar x,y,z; x := radf(numr u,n); y := radf(denr u,n); z := multsq(car x ./ 1,1 ./ car y); z := multsq(multsq(mkrootlsq(cdr x,n),invsq mkrootlsq(cdr y,n)), z); return z end; symbolic procedure mkrootlsq(u,n); %U is a list of prefix expressions, N an integer. %Value is standard quotient for U**(1/N); % NOTE we need the REVAL call so that PREPSQXX is properly called on % the argument for consistency with the pattern matcher. Otherwise % for all x,y let sqrt(x)*sqrt(y)=sqrt(x*y); sqrt(30*(l+1))*sqrt 5; % goes into an infinite loop. if null u then !*d2q 1 else if null !*reduced then mkrootsq(reval retimes u,n) else mkrootlsq1(u,n); symbolic procedure mkrootlsq1(u,n); if null u then !*d2q 1 else multsq(mkrootsq(car u,n),mkrootlsq1(cdr u,n)); symbolic procedure mkrootsq(u,n); %U is a prefix expression, N an integer. %Value is a standard quotient for U**(1/N); if u=1 then !*d2q 1 else if n=2 and (u= -1 or u= '(minus 1)) then simp 'i else if eqcar(u,'expt) and fixp caddr u then mksq(if n=2 then mksqrt cadr u else list('expt,cadr u,list('quotient,1,n)),caddr u) else mksq(if n=2 then mksqrt u else list('expt,u,list('quotient,1,n)),1); comment The following three procedures return a partitioned root expression, which is a dotted pair of integral part (a standard form) and radical part (a list of prefix expressions). The whole structure represents U**(1/N); symbolic procedure radf(u,n); %U is a standard form, N a positive integer. Value is a partitioned %root expression for U**(1/N); begin scalar ipart,rpart,x,y,z,!*gcd; if null u then return list u; !*gcd := t; ipart := 1; z := 1; while not domainp u do <<y := comfac u; if car y then <<x := divide(pdeg car y,n); if car x neq 0 then ipart:=multf(!*p2f if null !*precise or evenp car x then mvar u .** car x else mksp(list('abs,mvar u), car x), ipart); if cdr x neq 0 then rpart := mkexpt(if sfp mvar u then prepf mvar u else mvar u,cdr x) . rpart>>; x := quotf1(u,comfac!-to!-poly y); u := cdr y; if !*reduced and minusf x then <<x := negf x; u := negf u>>; if flagp(dmode!*,'field) then <<y := lnc x; if y neq 1 then <<x := quotf1(x,y); z := multd(y,z)>>>>; if x neq 1 then <<x := radf1(sqfrf x,n); ipart := multf(car x,ipart); rpart := append(rpart,cdr x)>>>>; if u neq 1 then <<x := radd(u,n); ipart := multf(car x,ipart); rpart := append(cdr x,rpart)>>; if z neq 1 then if !*numval and (y := domainvalchk('expt, list(!*f2q z,!*f2q !:recip n))) then ipart := multd(!*q2f y,ipart) else rpart := prepf z . rpart; % was aconc(rpart,z) return ipart . rpart end; symbolic procedure radf1(u,n); %U is a form_power list, N a positive integer. Value is a %partitioned root expression for U**(1/N); begin scalar ipart,rpart,x; ipart := 1; for each z in u do <<x := divide(cdr z,n); if not(car x=0) then ipart := multf(exptf(car z,car x),ipart); if not(cdr x=0) then rpart := mkexpt(prepsq!*(car z ./ 1),cdr x) . rpart>>; return ipart . rpart end; symbolic procedure radd(u,n); %U is a domain element, N an integer. %Value is a partitioned root expression for U**(1/N); begin scalar bool,ipart,x; if not atom u then return list(1,prepf u); % then if x := integer!-equiv u then u := x % else return list(1,prepf u); if u<0 and evenp n then <<bool := t; u := -u>>; x := nrootn(u,n); if bool then if !*reduced and n=2 then <<ipart := multd(car x,!*k2f 'i); x := cdr x>> else <<ipart := car x; x := -cdr x>> else <<ipart := car x; x := cdr x>>; return if x=1 then list ipart else list(ipart,x) end; symbolic procedure iroot(m,n); %M and N are positive integers. %If M**(1/N) is an integer, this value is returned, otherwise NIL; begin scalar x,x1,bk; if m=0 then return m; x := 10**iroot!-ceiling(lengthc m,n); %first guess; a: x1 := x**(n-1); bk := x-m/x1; if bk<0 then return nil else if bk=0 then return if x1*x=m then x else nil; x := x - iroot!-ceiling(bk,n); go to a end; symbolic procedure iroot!-ceiling(m,n); %M and N are positive integers. Value is ceiling of (M/N) (i.e., %least integer greater or equal to M/N); (lambda x; if cdr x=0 then car x else car x+1) divide(m,n); symbolic procedure mkexpt(u,n); if n=1 then u else list('expt,u,n); symbolic procedure nrootn(n,x); %N is an integer, X a positive integer. Value is a pair %of integers I,J such that I*J**(1/X)=N**(1/X); begin scalar i,j,r,signn; r := 1; if n<0 then <<n := -n; if evenp x then signn := t else r := -1>>; j := 2**x; while remainder(n,j)=0 do <<n := n/j; r := r*2>>; i := 3; j := 3**x; while j<=n do <<while remainder(n,j)=0 do <<n := n/j; r := r*i>>; if remainder(i,3)=1 then i := i+4 else i := i+2; j := i**x>>; if signn then n := -n; return r . n end; symbolic procedure simpiden u; begin scalar bool,fn,x,y,z; fn := car u; x := for each j in cdr u collect aeval j; u := fn . for each j in x collect if eqcar(j,'!*sq) then prepsqxx cadr j else if numberp j then j else <<bool := t; j>>; if flagp(fn,'noncom) then ncmp!* := t; if null subfg!* then go to c else if flagp(fn,'linear) and (z := formlnr u) neq u then return simp z else if z := opmtch u then return simp z else if z := get(car u,'opvalfn) then return apply1(z,u) else if null bool and (z := domainvalchk(fn, for each j in x collect simp j)) then return z; c: if flagp(fn,'symmetric) then u := fn . ordn cdr u else if flagp(fn,'antisymmetric) then <<if repeats cdr u then return (nil ./ 1) else if not permp(z:= ordn cdr u,cdr u) then y := t; u := car u . z>>; u := mksq(u,1); return if y then negsq u else u end; symbolic procedure domainvalchk(opr,args); % OPR is an operator, and ARGS its arguments as standard quotients. % If OPR . ARGS can be evaluated to a constant, result is the value, % otherwise NIL; begin scalar v,w,x,y,z; v := dmode!*; if null v or null !*numval or null(w := get(opr,dmode!*)) then return nil; a: if null args then return if errorp(w := errorset(list('apply, mkquote w,mkquote reversip!* y), nil,nil)) or getd 'complexp and complexp car w then nil else if not domainp car w then car w ./ 1 else !*d2q int!-equiv!-chk car w else if not domainp(x := numr car args) or denr car args neq 1 then return nil; if atom x then z := apply1(get(v,'i2d),if null x then 0 else x) else if car x eq v then z := x else if not(z := get(car x,v)) then return nil else z := apply1(z,x); y := z . y; args := cdr args; go to a end; symbolic procedure simpdiff u; addsq(simpcar u,simpminus cdr u); put('difference,'simpfn,'simpdiff); symbolic procedure simpminus u; negsq simp carx(u,'minus); put('minus,'simpfn,'simpminus); symbolic procedure simpplus u; begin scalar z; z := nil ./ 1; a: if null u then return z; z := addsq(simpcar u,z); u := cdr u; go to a end; put('plus,'simpfn,'simpplus); symbolic procedure simpquot u; multsq(simpcar u,simprecip cdr u); put('quotient,'simpfn,'simpquot); symbolic procedure simprecip u; if null !*mcd then simpexpt list(carx(u,'recip),-1) else invsq simp carx(u,'recip); put('recip,'simpfn,'simprecip); symbolic procedure simpset u; begin scalar x; if not idp (x := !*q2a simp!* car u) or null x then typerr(x,"set variable"); let0 list(list('equal,x,mk!*sq(u := simp!* cadr u))); return u end; put ('set, 'simpfn, 'simpset); symbolic procedure simpsqrt u; begin scalar x,y; x := xsimp car u; return if denr x=1 and domainp numr x and !:minusp numr x then if numr x=-1 then simp 'i else multsq(simp 'i, simpsqrt list prepd !:minus numr x) else if y := domainvalchk('expt, list(x,!*f2q mkfloat 0.5)) then y else simprad(x,2) end; symbolic procedure xsimp u; expchk simp!* u; symbolic procedure simptimes u; begin scalar x,y; if tstack!* neq 0 or null mul!* then go to a0; y := mul!*; mul!* := nil; a0: tstack!* := tstack!*+1; x := simpcar u; a: u := cdr u; if null numr x then go to c else if null u then go to b; x := multsq(x,simpcar u); go to a; b: if null mul!* or tstack!*>1 then go to c; x:= apply1(car mul!*,x); alglist!* := nil; % since we may need MUL!* set again; mul!*:= cdr mul!*; go to b; c: tstack!* := tstack!*-1; if tstack!* = 0 then mul!* := y; return x; end; put('times,'simpfn,'simptimes); symbolic procedure resimp u; %U is a standard quotient. %Value is the resimplified standard quotient; quotsq(subf1(numr u,nil),subf1(denr u,nil)); symbolic procedure simp!*sq u; if null cadr u then resimp car u else car u; put('!*sq,'simpfn,'simp!*sq); endmodule; module dmode; % Functions for defining and using poly domain modes. % Author: Anthony C. Hearn; % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*complex dmode!*); global '(!*convert domainlist!*); switch convert; symbolic procedure initdmode u; % Checks that U is a valid domain mode, and sets up appropriate % interfaces to the system. begin dmodechk u; put(u,'simpfg,list(list(t,list('setdmode,mkquote u,t)), list(nil,list('setdmode,mkquote u,nil)))) end; symbolic procedure setdmode(u,bool); % Sets polynomial domain mode. If bool is NIL, integers are used, % or in the case of complex, set to the lower domain. % Otherwise mode is set to u, or derived from it. if null get(u,'tag) then rederr list("Domain mode error:",u,"is not a domain mode") else if u eq 'complex or !*complex then setcmpxmode(u,bool) else setdmode1(u,bool); symbolic procedure setdmode1(u,bool); begin scalar x,y; x := get(u,'tag); y := dmode!*; if null bool then return if null y then nil else <<rmsubs(); dmode!* := nil; get(y,'dname)>> else if x eq y then return x; % Now make sure there are no other domain switches left on. for each j in domainlist!* do if j neq '!:gi!: then set(intern compress append(explode '!*,explode get(j,'dname)), nil); rmsubs(); y := get(y,'dname); if y then lprim list("Domain mode",y,"changed to",u); if u := get(u,'module!-name) then load!-module u; dmode!* := x; return y end; symbolic procedure dmodechk u; %checks to see if U has complete specification for a domain mode; begin scalar z; if not(z := get(u,'tag)) then rederr list("Domain mode error:","No tag for",z) else if not(get(z,'dname) eq u) then rederr list("Domain mode error:", "Inconsistent or missing DNAME for",z) else if not z memq domainlist!* then rederr list("Domain mode error:", z,"not on domain list"); u := z; for each x in domainlist!* do if u=x then nil else <<if not get(u,x) then put(u,x,mkdmoderr(u,x)); if not get(x,u) then put(x,u,mkdmoderr(x,u))>>; % then rederr list("Domain mode error:", % "No conversion defined between",U,"and",X); z := '(plus difference times quotient i2d prepfn prifn minusp onep zerop); if not flagp(u,'field) then z := 'divide . 'gcd . z; for each x in z do if not get(u,x) then rederr list("Domain mode error:", x,"is not defined for",u) end; symbolic procedure dmoderr(u,v); rederr list("Conversion between",get(u,'dname), "and",get(v,'dname),"not defined"); symbolic procedure mkdmoderr(u,v); list('lambda,'(!*x!*),list('dmoderr,mkquote u,mkquote v)); comment *** General Support Functions ***; symbolic procedure fieldp u; %U is a domain element. Value is T if U is invertable, NIL %otherwise; not atom u and flagp(car u,'field); symbolic procedure !:expt(u,n); % Raises domain element U to integer power N. Value is a domain % element; if null u then if n=0 then rederr "0/0 formed" else nil else if n=0 then 1 else if n=1 then u else if u=1 then 1 else if n<0 then !:recip !:expt(if not fieldp u then mkratnum u else u,-n) else if atom u then u**n else if car u eq '!:mod!: then (lambda x; if x=0 then nil else if x=1 then 1 else car u . x) general!-modular!-expt(cdr u,n) else begin scalar v,w,x; v := apply1(get(car u,'i2d),1); %unit element; x := get(car u,'times); a: w := divide(n,2); if cdr w=1 then v := apply2(x,u,v); if car w=0 then return v; u := apply2(x,u,u); n := car w; go to a end; symbolic procedure !:minus u; %U is a domain element. Value is -U; if atom u then -u else dcombine(u,-1,'times); symbolic procedure !:minusp u; if atom u then minusp u else apply1(get(car u,'minusp),u); symbolic procedure minuschk u; if eqcar(u,'minus) and (numberp cadr u or not atom cadr u and idp caadr u and get(caadr u,'dname)) then !:minus cadr u else u; symbolic procedure !:recip u; %U is an invertable domain element. Value is 1/U; begin if numberp u then if abs u=1 then return u else if null dmode!* then return mkrn(1,u) else if dmode!* eq '!:ft!: then return !*rn2ft mkrn(1,u) else u := apply1(get(dmode!*,'i2d),u); return dcombine(1,u,'quotient) end; symbolic procedure dcombine(u,v,fn); %U and V are domain elements, but not both atoms (integers). %FN is a binary function on domain elements; %Value is the domain element representing FN(U,V); int!-equiv!-chk if atom u then apply2(get(car v,fn),apply1(get(car v,'i2d),u),v) else if atom v then apply2(get(car u,fn),u,apply1(get(car u,'i2d),v)) else if car u eq car v then apply2(get(car u,fn),u,v) else begin scalar x; if not(x := get(car u,car v)) then <<v := apply1(get(car v,car u),v); x := get(car u,fn)>> else <<u := apply1(x,u); x := get(car v,fn)>>; return apply2(x,u,v) end; symbolic procedure int!-equiv!-chk u; % U is a domain element. If U can be converted to 0, result is NIL, % if U can be converted to 1, result is 1, % if *convert is on and U can be converted to an integer, result % is that integer. Otherwise, U is returned. % In most cases, U will be structured. begin scalar x; if atom u then return u; if apply1(get(car u,'zerop),u) then return nil else if apply1(get(car u,'onep),u) then return 1 else if null !*convert then return u else if (x := get(car u,'intequivfn)) and (x := apply1(x,u)) then return x else return u end; comment *** Description of Definition Requirements for Domain arithmetics *** Syntactically, such elements have the following form: <domain element>:=NIL|integer|<structured domain element> <structured domain element> ::= (<domain identifier>.<domain structure>), where NIL represents the domain element zero. To introduce a new domain, we need to define: 1) A conversion function from integer to the given mode, stored under the attribute I2D. 2) A conversion function from new mode to or from every other mode. 3) Particular instances of the binary operations +,- and * for this mode. 4) Particular instances of ZEROP, ONEP and MINUSP for this mode. Although ONEP could be defined in terms of ZEROP, we believe it is more efficient to have both functions (though this has not been thoroughly tested). 5) If domain is a field, a quotient must be defined. If domain is a ring, a gcd and divide must be defined, and also a quotient function which returns NIL if the division fails. 6) A printing function for this mode that can print the object in a linear form. The printing function is associated with the attribute PRIFN. This printing function should enclose the printed expression in parentheses if its top level operator has a precedence greater than +. 7) A function to convert structure to an appropriate prefix form. 8) A reading function for this mode. 9) A DNAME property for the tag, and a TAG property for the DNAME To facilitate this, all such modes should be listed in the global variable DOMAINLIST!*. The following rules should also be followed when introducing new domains: Some modes, such as modular arithmetic, require that integers be converted to domain elements when input or addition or multiplication of such objects occurs. Such modes should be flagged "convert". In ALL cases it is assumed that any domain element that tests true to the zero test can be converted into an explicit 0 (represented by NIL), and any that tests true to the onep test can be converted into an explicit 1. If the domain allows for the conversion of other elements into equivalent integers, a function under the optional attribute INTEQUIVFN may also be defined to effect this conversion. The result of an arithmetic (as opposed to a boolean) operation on structured domain elements with the same tag must be another structured domain element with the same tag. In particular, a domain zero must be returned as a tagged zero in that domain. In some cases, it is possible to map functions on domain elements to domain elements. To provide for this capability in the complete system, one can give such functions the domain tag as an indicator. The results of this evaluation must be a tagged domain element (or an integer?), but not necessarily an element from the same domain, or the evaluation should abort with an error. The error number associated with this should be in the range 100-150; endmodule; module rational; % *** Tables for rational numbers ***; % Author: Anthony C. Hearn; % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(domainlist!*); switch rational; domainlist!* := union('(!:rn!:),domainlist!*); put('rational,'tag,'!:rn!:); put('!:rn!:,'dname,'rational); flag('(!:rn!:),'field); put('!:rn!:,'i2d,'!*i2rn); put('!:rn!:,'minusp,'rnminusp!:); put('!:rn!:,'plus,'rnplus!:); put('!:rn!:,'times,'rntimes!:); put('!:rn!:,'difference,'rndifference!:); put('!:rn!:,'quotient,'rnquotient!:); put('!:rn!:,'zerop,'rnzerop!:); put('!:rn!:,'onep,'rnonep!:); put('!:rn!:,'factorfn,'rnfactor!:); put('!:rn!:,'prepfn,'rnprep!:); put('!:rn!:,'prifn,'rnprin); flag('(!:rn!:),'ratmode); symbolic procedure mkratnum u; %U is a domain element. Value is equivalent rational number; if atom u then !*i2rn u else apply1(get(car u,'!:rn!:),u); symbolic procedure mkrn(u,v); %converts two integers U and V into a rational number, an integer %or NIL; if v<0 then mkrn(-u,-v) else (lambda m; '!:rn!: . ((u/m) . (v/m))) gcdn(u,v); symbolic procedure !*i2rn u; %converts integer U to rational number; '!:rn!: . (u . 1); symbolic procedure rnminusp!: u; cadr u<0; symbolic procedure rnplus!:(u,v); mkrn(cadr u*cddr v+cddr u*cadr v,cddr u*cddr v); symbolic procedure rntimes!:(u,v); mkrn(cadr u*cadr v,cddr u*cddr v); symbolic procedure rndifference!:(u,v); mkrn(cadr u*cddr v-cddr u*cadr v,cddr u*cddr v); symbolic procedure rnquotient!:(u,v); mkrn(cadr u*cddr v,cddr u*cadr v); symbolic procedure rnzerop!: u; cadr u=0; symbolic procedure rnonep!: u; cadr u=1 and cddr u=1; symbolic procedure rnfactor!: u; begin scalar x,y,dmode!*; integer m,n; x := subf(u,nil); y := factorf numr x; n := car y; dmode!* := '!:rn!:; y := for each j in cdr y collect <<n := n*(m := (lnc ckrn car j)**cdr j); quotfd(car j,m) . cdr j>>; return int!-equiv!-chk mkrn(n,denr x) . y end; symbolic procedure rnprep!: u; % PREPF is called on arguments, since the LOWEST-TERMS code in extout % can create rational objects with structured arguments. (if cddr u=1 then x else list('quotient,x,prepf cddr u)) where x = prepf cadr u; symbolic procedure rnprin u; <<prin2!* cadr u; prin2!* "/"; prin2!* cddr u>>; initdmode 'rational; endmodule; module float; % *** Tables for floats ***. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(domainlist!* ft!-tolerance!*); switch float; domainlist!* := union('(!:ft!:),domainlist!*); put('float,'tag,'!:ft!:); put('!:ft!:,'dname,'float); flag('(!:ft!:),'field); put('!:ft!:,'i2d,'!*i2ft); put('!:ft!:,'!:rn!:,'!*ft2rn); put('!:ft!:,'minusp,'ftminusp!:); put('!:ft!:,'plus,'ftplus!:); put('!:ft!:,'times,'fttimes!:); put('!:ft!:,'difference,'ftdifference!:); put('!:ft!:,'quotient,'ftquotient!:); put('!:ft!:,'zerop,'ftzerop!:); put('!:ft!:,'onep,'ftonep!:); put('!:ft!:,'prepfn,'ftprep!:); put('!:ft!:,'prifn,'floatprn); put('!:ft!:,'cmpxtype,list '!:gf!:); put('!:ft!:,'intequivfn,'ftintequiv); symbolic procedure mkfloat u; '!:ft!: . u; symbolic procedure !*i2ft u; %converts integer U to tagged floating point form; '!:ft!: . float u; symbolic procedure !*ft2rn n; % Converts a floating point number N into a rational to the system % floating point precision. mkrn(car x,cdr x) where x = ft2rn1(cdr n,ft!-tolerance!*); symbolic procedure ft2rn1(n,prec); begin scalar negp,a,p0,p1,q0,q1,w,flagg; if zerop n then return 0 . 1 else if n<0 then <<negp := t; n := -n>>; top: a := fix n; n := n - float a; if not flagg then <<flagg := t; p0 := 1; p1 := a; q0 := 0; q1 := 1>> else <<w := p0 + a*p1; p0 := p1; p1 := w; w := q0 + a*q1; q0 := q1; q1 := w>>; if n<prec*a then return if negp then (-p1) . q1 else p1 . q1 else if p1*q1*prec>1.0 then return if negp then (-p0) . q0 else p0 . q0; n := 1.0/n; go to top end; symbolic procedure !*rn2ft u; % Converts the (tagged) rational u/v into a (tagged) floating point % number to the system precision. mkfloat rn2ft1(cadr u,cddr u,ft!-tolerance!*); symbolic procedure rn2ft1(u,v,prec); begin scalar negp,x,y,z; if v=0 then rederr "zero denominator" else if u=0 then return 0.0 else if v<0 then <<u := -u; v := -v>>; if u<0 then <<negp := t; u := -u>>; x := 1.0; y := 0; z := 0.0; repeat <<z := y + z; y := divide(u,v); u := 10*cdr y; y := x*car y; x := x/10>> until u*x < prec*z; z := y + z; return if negp then -z else z end; symbolic procedure ftminusp!: u; cdr u<0; symbolic procedure ftplus!:(u,v); % car u . (lambda x; if abs x<0.000001*abs cdr u then 0.0 else x) % (cdr u+cdr v); car u . (cdr u+cdr v); symbolic procedure fttimes!:(u,v); car u . (cdr u*cdr v); symbolic procedure ftdifference!:(u,v); car u .(cdr u-cdr v); symbolic procedure ftquotient!:(u,v); car u . (cdr u/cdr v); symbolic procedure ftzerop!: u; abs cdr u < ft!-tolerance!*; symbolic procedure ftonep!: u; abs(cdr u - 1.0) < ft!-tolerance!*; symbolic procedure ftprep!: u; cdr u; symbolic procedure floatprn u; prin2 cdr u; symbolic procedure ftintequiv u; % Converts floating point number U to integer equivalent if within % precision of system. begin scalar x; u := cdr u; return if abs(u-(x := fix u)) < ft!-tolerance!* then x else nil end; % The following square root function was written by Mary Ann Moore. symbolic procedure sqrt n; sqrt!-float float n; symbolic procedure sqrt!-float n; % Simple Newton-Raphson floating point square root calculator. begin scalar scale,ans; if n=0.0 then return 0.0 else if n<0.0 then rederr "SQRT!-FLOAT given negative argument"; scale := 1.0; % Detach the exponent by doing a sequence of multiplications % and divisions by powers of 2 until the remaining number is in % the range 1.0 to 4.0. On a binary machine the scaling should % not introduce any error at all; while n>256.0 do <<scale := scale*16.0; n := n/256.0>>; while n<1.0/256.0 do <<scale := scale/16.0; n := n*256.0>>; % Coarse scaled: now finish off the job. while n<1.0 do <<scale := scale/2.0; n := n*4.0>>; while n>4.0 do <<scale := scale*2.0; n := n/4.0>>; % 5 iterations get me as good a result as I can reasonably want % and it is cheaper to do 5 always than to test for stopping % criteria. ans := 2.0; for i:=1:5 do ans := (ans+n/ans)/2.0; return ans*scale end; initdmode 'float; comment *** Entry points for the bigfloat package ***; put('bigfloat,'simpfg,'((t (setdmode (quote bigfloat) t)) (nil (setdmode (quote bigfloat) nil)))); put('bigfloat,'tag,'!:bf!:); switch bigfloat; endmodule; module polrep; % Arithmetic operations on standard forms and quotients. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*asymp!* !*exp !*gcd !*lcm !*mcd !*sub2 asymplis!* dmode!*); global '(!*factor !*group ncmp!* powlis!* subfg!* wtl!*); symbolic smacro procedure subtrsq(u,v); addsq(u,negsq v); symbolic procedure addsq(u,v); %U and V are standard quotients. %Value is canonical sum of U and V; if null numr u then v else if null numr v then u else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1 else begin scalar x,y,z; if null !*exp then <<u := numr u ./ mkprod!* denr u; v := numr v ./ mkprod!* denr v>>; if !*lcm then x := gcdf!*(denr u,denr v) else x := gcdf(denr u,denr v); z := canonsq(quotf(denr u,x) ./ quotf(denr v,x)); y := addf(multf(denr z,numr u),multf(numr z,numr v)); if null y then return nil ./ 1; z := multf(denr u,denr z); if x=1 then return y ./ z; % ONEP x := gcdf(y,x); return if x=1 then y ./ z else canonsq(quotf(y,x) ./ quotf(z,x)) end; symbolic procedure multsq(u,v); %U and V are standard quotients. %Value is canonical product of U and V; if null numr u or null numr v then nil ./ 1 else if denr u=1 and denr v=1 then multf(numr u,numr v) ./ 1 else begin scalar x,y; x := gcdf(numr u,denr v); y := gcdf(numr v,denr u); return canonsq(multf(quotf(numr u,x),quotf(numr v,y)) ./ multf(quotf(denr u,y),quotf(denr v,x))) end; symbolic procedure negsq u; negf numr u ./ denr u; smacro procedure multpq(u,v); multsq(!*p2q u,v); symbolic procedure cancel u; %returns canonical form of non-canonical standard form U; if !*mcd or denr u=1 then multsq(numr u ./ 1,1 ./ denr u) else multsq(numr u ./ 1,simpexpt list(mk!*sq(denr u ./ 1),-1)); % ***** FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD FORMS ***** symbolic smacro procedure peq(u,v); %tests for equality of powers U and V; u = v; symbolic procedure addf(u,v); %U and V are standard forms. Value is standard form for U+V; if null u then v else if null v then u else if domainp u then addd(u,v) else if domainp v then addd(v,u) else if peq(lpow u,lpow v) then (lambda (x,y); if null x then y else lpow u .* x .+ y) (addf(lc u,lc v),addf(red u,red v)) else if ordpp(lpow u,lpow v) then lt u .+ addf(red u,v) else lt v .+ addf(u,red v); symbolic procedure addd(u,v); %U is a domain element, V a standard form. %Value is a standard form for U+V; if null v then u else if domainp v then adddm(u,v) else lt v .+ addd(u,red v); symbolic procedure adddm(u,v); %U and V are both non-zero domain elements. %Value is standard form for U+V; if atom u and atom v then (lambda x; if null dmode!* or not flagp(dmode!*,'convert) then !*n2f x else int!-equiv!-chk apply1(get(dmode!*,'i2d),x)) plus2(u,v) else dcombine(u,v,'plus); symbolic procedure domainp u; atom u or atom car u; symbolic procedure noncomf u; if domainp u then nil else noncomp mvar u or noncomf lc u or noncomf red u; symbolic procedure noncomp u; flagpcar(u,'noncom); symbolic procedure multf(u,v); %U and V are standard forms. %Value is standard form for U*V; begin scalar ncmp,x,y; a: if null u or null v then return nil else if u=1 then return v % ONEP else if v=1 then return u % ONEP else if domainp u then return multd(u,v) else if domainp v then return multd(v,u) else if not(!*exp or ncmp!* or wtl!* or x) then <<u := mkprod u; v := mkprod v; x := t; go to a>>; x := mvar u; y := mvar v; if (ncmp := noncomp y) and noncomp x then return multfnc(u,v) else if x eq y then <<x := mkspm(x,ldeg u+ldeg v); y := addf(multf(red u,v),multf(!*t2f lt u,red v)); return if null x or null(u := multf(lc u,lc v)) then <<!*asymp!* := t; y>> else if x=1 then addf(u,y) else if null !*mcd then addf(!*t2f(x .* u),y) else x .* u .+ y>> else if ordop(x,y) or ncmp and noncomf lc u then <<x := multf(lc u,v); y := multf(red u,v); return if null x then y else lpow u .* x .+ y>>; x := multf(u,lc v); y := multf(u,red v); return if null x then y else lpow v .* x .+ y end; symbolic procedure multfnc(u,v); %returns canonical product of U and V, with both main vars non- %commutative; begin scalar x,y; x := multf(lc u,!*t2f lt v); return addf((if not domainp x and mvar x eq mvar u then addf(if null (y := mkspm(mvar u,ldeg u+ldeg v)) then nil else if y = 1 then lc x else !*t2f(y .* lc x), multf(!*p2f lpow u,red x)) else !*t2f(lpow u .* x)), addf(multf(red u,v),multf(!*t2f lt u,red v))) end; symbolic procedure multd(u,v); %U is a domain element, V a standard form. %Value is standard form for U*V; if null v then nil else if domainp v then multdm(u,v) else lpow v .* multd(u,lc v) .+ multd(u,red v); symbolic procedure multdm(u,v); % U and V are both non-zero domain elements. % Value is standard form for U*V; if atom u and atom v then (lambda x; if null dmode!* or not flagp(dmode!*,'convert) then x else int!-equiv!-chk apply1(get(dmode!*,'i2d),x)) times2(u,v) else dcombine(u,v,'times); smacro procedure multpf(u,v); multf(!*p2f u,v); symbolic procedure mkprod u; begin scalar w,x,y,z,!*exp,!*sub2; if null u or kernlp u then return u; %first make sure there are no further simplifications; !*sub2 := t; if denr(x := subs2(u ./ 1)) = 1 and numr x neq u then <<u := numr x; if null u or kernlp u then return u>>; !*exp := t; w := ckrn u; u := quotf(u,w); x := expnd u; if null x or kernlp x then return multf(w,x); % After this point, U is not KERNLP. % The check below for *MCD was suggested by James Davenport. % Without it, on gcd; off mcd,exp; (x**2+2x+1)/x+1; loops % forever. if !*mcd and (!*factor or !*gcd) then y := fctrf x else <<y := ckrn x; x := quotf(x,y); y := list(y,x . 1)>>; if cdadr y>1 or cddr y then <<z := car y; for each j in cdr y do z := multf(mksp!*(car j,cdr j),z)>> else if not !*group and tmsf u>tmsf caadr y then z := multf(mksp!*(caadr y,cdadr y),car y) else z := mksp!*(u,1); return multf(w,z) end; symbolic procedure mksp!*(u,n); % Returns a standard form for U**N. If U is a kernel product, % direct exponentiation is used. Otherwise, U is first made % positive and then converted into a kernel. begin scalar b; if kernlp u then return exptf(u,n) else if minusf u then <<b := t; u := negf u>>; u := !*p2f mksp(u,n); return if b and not evenp n then negf u else u end; put('!*sq,'lengthfn,'!*sqlength); symbolic procedure !*sqlength u; (if denr car u=1 then x else x+termsf denr car u) where x = termsf numr car u; symbolic procedure terms u; % <<lprim "Please use LENGTH instead"; termsf numr simp!* u>>; termsf numr simp!* u; flag('(terms),'opfn); flag('(terms),'noval); symbolic procedure termsf u; % U is a standard form. % Value is number of terms in U (excluding kernel structure). begin integer n; while not domainp u do <<n := n + termsf lc u; u := red u>>; return if null u then n else n+1 end; symbolic procedure tmsf u; % U is a standard form. % Value is number of terms in U (including kernel structure). begin integer n; scalar x; % Integer declaration initializes N to 0. while not domainp u do <<n := n+(if sfp(x := mvar u) then tmsf x else 1)+tmsf!* lc u; if ldeg u neq 1 then if ldeg u=2 then n := n+1 else n := n+2; u := red u>>; % Previously, if U was non-zero, we used to add % one more here. return if null u then n else n+1 end; symbolic procedure tmsf!* u; if numberp u and abs fix u=1 then 0 else tmsf u; % Was tmsf u+1. symbolic procedure tms u; tmsf numr simp!* u; flag('(tms),'opfn); flag('(tms),'noval); symbolic procedure expnd u; if domainp u then u else addf(if not sfp mvar u or ldeg u<0 then multpf(lpow u,expnd lc u) else multf(exptf(expnd mvar u,ldeg u),expnd lc u), expnd red u); symbolic procedure mkprod!* u; if domainp u then u else mkprod u; symbolic procedure canprod(p,q); %P and Q are kernel product standard forms, value is P/Q; begin scalar v,w,x,y,z; if domainp q then return cancel(p ./ q); while not domainp p or not domainp q do if sfpf p then <<z := cprod1(mvar p,ldeg p,v,w); v := car z; w := cdr z; p := lc p>> else if sfpf q then <<z := cprod1(mvar q,ldeg q,w,v); w := car z; v := cdr z; q := lc q>> else if domainp p then <<y := lpow q . y; q := lc q>> else if domainp q then <<x := lpow p . x; p := lc p>> else <<x := lpow p . x; y := lpow q . y; p := lc p; q := lc q>>; v := reprod(v,reprod(x,p)); w := reprod(w,reprod(y,q)); if minusf w then <<v := negf v; w := negf w>>; w := cancel(v ./ w); v := numr w; if not domainp v and null red v and lc v=1 % ONEP and ldeg v=1 and sfp(x := mvar v) then v := x; return canonsq(v ./ denr w) end; symbolic procedure sfpf u; not domainp u and sfp mvar u; symbolic procedure sfp u; %determines if mvar U is a standard form; not atom u and not atom car u; symbolic procedure reprod(u,v); %U is a list of powers,V a standard form; %value is product of terms in U with V; <<while u do <<v := multpf(car u,v); u := cdr u>>; v>>; symbolic procedure cprod1(p,m,v,w); %U is a standard form, which occurs in a kernel raised to power M. %V is a list of powers multiplying P**M, W a list dividing it. %Value is a dotted pair of lists of powers after all possible kernels %have been cancelled; begin scalar z; z := cprod2(p,m,w,nil); w := cadr z; v := append(cddr z,v); z := cprod2(car z,m,v,t); v := cadr z; w := append(cddr z,w); if car z neq 1 then v := mksp(car z,m) . v; return v . w end; symbolic procedure cprod2(p,m,u,b); %P and M are as in CPROD1. U is a list of powers. B is true if P**M %multiplies U, false if it divides. %Value has three parts: the first is the part of P which does not %have any common factors with U, the second a list of powers (plus %U) which multiply U, and the third a list of powers which divide U; %it is implicit here that the kernel standard forms are positive; begin scalar n,v,w,y,z; while u and p neq 1 do <<if (z := gcdf(p,caar u)) neq 1 then <<p := quotf(p,z); y := quotf(caar u,z); if y neq 1 then v := mksp(y,cdar u) . v; if b then v := mksp(z,m+cdar u) . v else if (n := m-cdar u)>0 then w := mksp(z,n) . w else if n<0 then v := mksp(z,-n) . v>> else v := car u . v; u := cdr u>>; return (p . nconc!*(u,v) . w) end; symbolic procedure mkspm(u,p); %U is a unique kernel, P an integer; %value is 1 if P=0, NIL if U**P is 0, else standard power of U**P; % should we add a check for NOT(U EQ K!*) in first line? if p=0 then 1 else begin scalar x; if subfg!* and (x:= atsoc(u,asymplis!*)) and cdr x<=p then return nil; sub2chk u; return u .** p end; symbolic procedure sub2chk u; %determines if kernel U is such that a power substitution is %necessary; if subfg!* and(atsoc(u,powlis!*) or not atom u and car u memq '(expt sqrt)) then !*sub2 := t; symbolic procedure negf u; multd(-1,u); % ***** FUNCTIONS FOR DIVIDING STANDARD FORMS ***** symbolic procedure quotsq(u,v); multsq(u,invsq v); symbolic procedure quotf!*(u,v); if null u then nil else (lambda x; if null x then errach list("DIVISION FAILED",u,v) else x) quotf(u,v); symbolic procedure quotf(u,v); begin scalar xexp; xexp := !*exp; !*exp := t; u := quotf1(u,v); !*exp := xexp; return u end; symbolic procedure quotf1(p,q); %P and Q are standard forms %Value is the quotient of P and Q if it exists or NIL; if null p then nil else if p=q then 1 else if q=1 then p else if domainp q then quotfd(p,q) else if domainp p then nil else if mvar p eq mvar q then begin scalar u,v,w,x,y,z,z1; integer n; a:if idp(u := rank p) or idp(v := rank q) or u<v then return nil; %the above IDP test is because of the possibility of a free %variable in the degree position from LET statements; u := lt!* p; v := lt!* q; w := mvar q; x := quotf1(tc u,tc v); if null x then return nil; n := tdeg u-tdeg v; if n neq 0 then y := w .** n; p := addf(p,multf(if n=0 then q else multpf(y,q),negf x)); %leading terms of P and Q do not cancel if MCD is off; %however, there may be a problem with off exp; if p and (domainp p or mvar p neq w) then return nil else if n=0 then go to b; z := aconc!*(z,y .* x); %provided we have a non-zero power of X, terms %come out in right order; if null p then return if z1 then nconc!*(z,z1) else z; go to a; b: if null p then return nconc!*(z,x) else if !*mcd then return nil else z1 := x; go to a end else if ordop(mvar p,mvar q) then quotk(p,q) else nil; symbolic procedure quotfd(p,q); % P is a standard form, Q a domain element. % Value is P/Q if exact division is possible, or NIL otherwise. begin scalar x; return if p=q then 1 else if flagp(dmode!*,'field) and (x := !:recip q) then multd(x,p) else if domainp p then quotdd(p,q) else quotk(p,q) end; symbolic procedure quotdd(u,v); % U and V are domain elements. Value is U/V if division is exact, % NIL otherwise. if atom u then if atom v then if remainder(u,v)=0 then u/v else nil else quotdd(apply1(get(car v,'i2d),u),v) else if atom v then quotdd(u,apply1(get(car u,'i2d),v)) else dcombine(u,v,'quotient); symbolic procedure quotk(p,q); (lambda w; if w then if null red p then list (lpow p .* w) else (lambda y;if y then lpow p .* w .+ y else nil) quotf1(red p,q) else nil) quotf1(lc p,q); symbolic procedure rank p; %P is a standard form %Value is the rank of P; if !*mcd then ldeg p else begin integer m,n; scalar y; n := ldeg p; y := mvar p; a: m := ldeg p; if null red p then return n-m; p := red p; if degr(p,y)=0 then return if m<0 then if n<0 then -m else n-m else n; go to a end; symbolic procedure lt!* p; %Returns true leading term of polynomial P; if !*mcd or ldeg p>0 then car p else begin scalar x,y; x := lt p; y := mvar p; a: p := red p; if null p then return x else if degr(p,y)=0 then return (y . 0) .* p; go to a end; symbolic procedure remf(u,v); %returns the remainder of U divided by V; cdr qremf(u,v); put('remainder,'polyfn,'remf); symbolic procedure qremf(u,v); %returns the quotient and remainder of U divided by V; begin integer n; scalar x,y,z; if domainp v then return qremd(u,v); z := list nil; %final value; a: if domainp u then return praddf(z,nil . u) else if mvar u eq mvar v then if (n := ldeg u-ldeg v)<0 then return praddf(z,nil . u) else <<x := qremf(lc u,lc v); y := multpf(lpow u,cdr x); z := praddf(z,(if n=0 then car x else multpf(mvar u .** n,car x)) . y); u := if null car x then red u else addf(addf(u,multf(if n=0 then v else multpf(mvar u .** n,v), negf car x)), negf y); go to a>> else if not ordop(mvar u,mvar v) then return praddf(z,nil . u); x := qremf(lc u,v); z := praddf(z,multpf(lpow u,car x) . multpf(lpow u,cdr x)); u := red u; go to a end; symbolic procedure praddf(u,v); %U and V are dotted pairs of standard forms; addf(car u,car v) . addf(cdr u,cdr v); symbolic procedure qremd(u,v); %Returns a dotted pair of quotient and remainder of form U %divided by domain element V; if null u then u . u else if v=1 then list u else if flagp(dmode!*,'field) then list multd(!:recip v,u) else if domainp u then qremdd(u,v) else begin scalar x; x := qremf(lc u,v); return praddf(multpf(lpow u,car x) . multpf(lpow u,cdr x), qremd(red u,v)) end; symbolic procedure qremdd(u,v); %returns a dotted pair of quotient and remainder of non-invertable %domain element U divided by non-invertable domain element V; if atom u and atom v then dividef(u,v) else dcombine(u,v,'divide); symbolic procedure dividef(m,n); (lambda x; (if car x=0 then nil else car x). if cdr x=0 then nil else cdr x) divide(m,n); symbolic procedure lqremf(u,v); %returns a list of coeffs of powers of V in U, constant term first; begin scalar x,y; y := list u; while car(x := qremf(car y,v)) do y := car x . cdr x . cdr y; return reversip!* y end; symbolic procedure minusf u; %U is a non-zero standard form. %Value is T if U has a negative leading numerical coeff, %NIL otherwise; if null u then nil else if domainp u then if atom u then u<0 else apply1(get(car u,'minusp),u) else minusf lc u; symbolic procedure absf!* u; % Returns representation for absolute value of standard form U. (if domainp u then x else !*p2f mksp(list('abs,prepf x),1)) where x = absf u; symbolic procedure absf u; if minusf u then negf u else u; symbolic procedure canonsq u; % U is a standard quotient. % Value is a standard quotient in which the leading power % of the denominator has a positive numerical coefficient and the % denominator is normalized where possible. if denr u=1 then u % Used to be :ONEP else if null numr u then nil ./ 1 else begin scalar x,y; % Check for non-trivial GCD if GCD is off, since an additional % factor may have been formed. if null !*gcd and (x := gcdf(numr u,denr u)) neq 1 then u := quotf(numr u,x) ./ quotf(denr u,x); % See if we can remove numerical factor from denominator. x := lnc denr u; if x=1 then return u else if atom x then if minusp x then <<u := negf numr u ./ negf denr u; x := -x>> else nil else if apply1(get(car x,'minusp),x) then <<u := negf numr u ./ negf denr u; x:= apply2(get(car x,'difference), apply1(get(car x,'i2d),0), x)>>; if null dmode!* then return u else if flagp(dmode!*,'field) then << % This section could be better coded if we required conversion % from rational to all field domains, but for the time being % we'll limit ourselves to floats. if atom x then if dmode!* eq '!:ft!: then return if atom numr u and atom denr u then !*rn2ft mkrn(numr u,denr u) ./ 1 else <<y := !*rn2ft mkrn(1,x); multd(y,numr u) ./ multd(y,denr u)>> else x := apply1(get(dmode!*,'i2d),x); y := dcombine(1,x,'quotient); if null y then errach list('canonsq,x); return multd(y,numr u) ./ multd(y,denr u)>> else if numberp x or not (y:= get(dmode!*,'units)) then return u else return canonsq1(u,x,y) end; symbolic procedure canonsq1(u,v,w); begin scalar z; a: if null w then return u; z := quotf1(v,caar w); if null z or not fixp z then <<w := cdr w; go to a>>; z := multf(denr u,cdar w); w := multf(numr u,cdar w); if minusf z then <<w := negf w; z := negf z>>; return w ./ z end; symbolic procedure lnc u; % U is a standard form. Value is the leading numerical coefficient. if null u then 0 else if domainp u then u else lnc lc u; symbolic procedure invsq u; begin if null numr u then rederr "Zero denominator"; u := revpr u; if !*rationalize then u := gcdchk u; % Since result may not be in lowest terms. return canonsq u end; symbolic procedure gcdchk u; % Makes sure standard quotient u is in lowest terms. (if x neq 1 then quotf(numr u,x) ./ quotf(denr u,x) else u) where x = gcdf(numr u,denr u); endmodule; module gcdn; % gcd of integers. % Author: Anthony C. Hearn % Copyright (c) 1987 The RAND Corporation. All rights reserved. expr procedure gcdn(u,v); % { U and v are integers. Value is absolute value of gcd of u and v} if v = 0 then abs u else gcdn(v,remainder(u,v)); endmodule; module gcd; % Greatest common divisor routines. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*exp !*ezgcd !*gcd !*heugcd dmode!*); switch ezgcd,heugcd; symbolic procedure comfac p; % P is a non-atomic standard form % CAR of result is lowest common power of leading kernel in % every term in P (or NIL). CDR is gcd of all coefficients of % powers of leading kernel. % If field elements are involved, lnc is normalized to 1. % We need GCDF here since the same function is used by EZGCD. begin scalar x,y; if flagp(dmode!*,'field) and ((x := lnc p) neq 1) then p := multd(!:recip x,p); if null red p then return lt p; x := lc p; y := mvar p; a: p := red p; if degr(p,y)=0 then return nil . gcdf(x,p) else if null red p then return lpow p . gcdf(x,lc p) else x := gcdf(lc p,x); go to a end; symbolic procedure degr(u,var); if domainp u or not mvar u eq var then 0 else ldeg u; put('gcd,'polyfn,'gcdf!*); symbolic procedure gcdf!*(u,v); begin scalar !*gcd; !*gcd := t; return gcdf(u,v) end; symbolic procedure gcdf(u,v); %U and V are standard forms. %Value is the gcd of U and V, complete only if *GCD is true; begin scalar !*exp; !*exp := t; u := if domainp u or domainp v or not !*ezgcd then gcdf1(u,v) else ezgcdf(u,v); return if minusf u then negf u else u end; symbolic procedure gcdf1(u,v); begin scalar w; if null u then return v else if null v then return u else if u=1 or v=1 then return 1 % ONEP else if domainp u then return gcdfd(u,v) else if domainp v then return gcdfd(v,u) else if quotf1(u,v) then return v else if quotf1(v,u) then return u; w := gcdf2(u,v); if !*gcd and u and v and (null quotf1(u,w) or null quotf1(v,w)) then errach list("GCDF FAILED",prepf u,prepf v); %this probably implies that integer overflow occurred; return w end; symbolic procedure gcdf2(u,v); % U and V are both non-trivial forms. Value is their GCD; begin scalar w,x,y,z,z1; if !*gcd and length(z1 := kernord(u,v))>1 then <<w := setkorder z1; u := reorder u; v := reorder v>> else z1 := nil; if mvar u eq mvar v then <<x := comfac u; y := comfac v; z := gcdf1(cdr x,cdr y); if !*gcd then z := multf(gcdk(quotf1(u,comfac!-to!-poly x), quotf1(v,comfac!-to!-poly y)), z); if car x and car y then if pdeg car x>pdeg car y then z := multpf(car y,z) else z := multpf(car x,z)>> else if ordop(mvar u,mvar v) then z := gcdf1(cdr comfac u,v) else z := gcdf1(cdr comfac v,u); if z1 then <<setkorder w; z := reorder z>>; return z end; symbolic procedure gcdfd(u,v); %U is a domain element, V a form; %Value is gcd of U and V; % if not atom u and flagp(car u,'field) then 1 else gcdfd1(u,v); if flagp(dmode!*,'field) then 1 else gcdfd1(u,v); symbolic procedure gcdfd1(u,v); if null v then u else if domainp v then gcddd(u,v) else gcdfd1(gcdfd1(u,lc v),red v); symbolic procedure gcddd(u,v); %U and V are domain elements. If they are invertable, value is 1 %otherwise the gcd of U and V as a domain element; if u=1 or v=1 then 1 % else if atom u and atom v then gcdn(u,v) else if atom u then if atom v then gcdn(u,v) else if fieldp v then 1 else dcombine(u,v,'gcd) else if atom v then if flagp(car u,'field) then 1 else dcombine(u,v,'gcd) else if flagp(car u,'field) or flagp(car v,'field) then 1 else dcombine(u,v,'gcd); symbolic procedure gcdk(u,v); %U and V are primitive polynomials in the main variable VAR; %result is gcd of U and V; begin scalar lclst,var,w,x; if u=v then return u else if domainp u or degr(v,(var := mvar u))=0 then return 1 else if ldeg u<ldeg v then <<w := u; u := v; v := w>>; if quotf1(u,v) then return v else if !*heugcd and (x := heu!-gcd(u,v)) then return x else if ldeg v=1 or getd 'modular!-multicheck and modular!-multicheck(u,v,var) then return 1; a: w := remk(u,v); if null w then return v else if degr(w,var)=0 then return 1; lclst := addlc(v,lclst); if x := quotf1(w,lc w) then w := x else for each y in lclst do while (x := quotf1(w,y)) do w := x; u := v; v := prim!-part w; if degr(v,var)=0 then return 1 else go to a end; symbolic procedure addlc(u,v); if u=1 then v else (lambda x; if x=1 or x=-1 or not atom x and flagp(car x,'field) then v else x . v) lc u; symbolic procedure delall(u,v); if null v then nil else if u eq caar v then delall(u,cdr v) else car v . delall(u,cdr v); symbolic procedure kernord(u,v); <<u := kernord!-split(u,v); append(kernord!-sort car u,kernord!-sort cdr u)>>; symbolic procedure kernord!-split(u,v); % splits U and V into a set of powers of those kernels occurring in % one form and not the other, and those occurring in both; begin scalar x,y; u := powers u; v := powers v; for each j in u do if assoc(car j,v) then y := j . y else x := j . x; for each j in v do if assoc(car j,u) then y := j . y else x := j . x; return reversip x . reversip y end; symbolic procedure kernord!-sort u; % returns list of kernels ordered so that kernel with lowest maximum % power in U (a list of powers) is first, and so on; begin scalar x,y; while u do <<x := maxdeg(cdr u,car u); u := delall(car x,u); y := car x . y>>; return y end; symbolic procedure maxdeg(u,v); if null u then v else if cdar u>cdr v then maxdeg(cdr u,car u) else maxdeg(cdr u,v); symbolic procedure powers form; % returns a list of the maximum powers of each kernel in FORM. % order tends to be opposite to original order. powers0(form,nil); symbolic procedure powers0(form,powlst); if null form or domainp form then powlst else begin scalar x; if (x := atsoc(mvar form,powlst)) % then ldeg form>cdr x and rplacd(x,ldeg form) then (if ldeg form>cdr x then powlst := repasc(mvar form,ldeg form,powlst)) else powlst := (mvar form . ldeg form) . powlst; return powers0(red form,powers0(lc form,powlst)) end; put('lcm,'polyfn,'lcm!*); symbolic procedure lcm!*(u,v); begin scalar !*gcd; !*gcd := t; return lcm(u,v) end; symbolic procedure lcm(u,v); %U and V are standard forms. Value is lcm of U and V; if null u or null v then nil else if u=1 then v % ONEP else if v=1 then u % ONEP else multf(u,quotf(v,gcdf(u,v))); symbolic procedure remk(u,v); %modified pseudo-remainder algorithm %U and V are polynomials, value is modified prem of U and V; begin scalar f1,var,x; integer k,n; f1 := lc v; var := mvar v; n := ldeg v; while (k := degr(u,var)-n)>=0 do <<x := negf multf(lc u,red v); if k>0 then x := multpf(var .** k,x); u := addf(multf(f1,red u),x)>>; return u end; symbolic procedure prim!-part u; %returns the primitive part of the polynomial U wrt leading var; quotf1(u,comfac!-to!-poly comfac u); symbolic procedure comfac!-to!-poly u; if null car u then cdr u else list u; endmodule; module sub; % Functions for substituting in standard forms. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*nosubs asymplis!* dmode!*); global '(ncmp!*); % Simplification interface symbolic procedure simpsub u; begin scalar !*nosubs,w,x,z; a: if null cdr u then <<if getrtype car u or eqcar(car u,'equal) then typerr(car u,"scalar"); u := simp!* car u; z := reversip!* z; % to put replacements in same % order as input. return quotsq(subf(numr u,z),subf(denr u,z))>>; !*nosubs := t; % We don't want left side of eqns to change. w := reval car u; !*nosubs := nil; if getrtype w eq 'list then <<u := append(cdr w,cdr u); go to a>> else if not eqexpr w then errpri2(car u,t); x := cadr w; if null getrtype x then x := !*a2k x; z := (x . caddr w) . z; u := cdr u; go to a; end; put('sub,'simpfn,'simpsub); symbolic procedure subsq(u,v); quotsq(subf(numr u,v),subf(denr u,v)); symbolic procedure subf(u,l); begin scalar alglist!*,x; %domain may have changed, so next line uses simpatom; if domainp u then return !*d2q u else if ncmp!* and noncomexpf u then return subf1(u,l); x := reverse xn(for each y in l collect car y, kernord(u,nil)); x := setkorder x; u := subf1(reorder u,l); setkorder x; return reorder numr u ./ reorder denr u end; symbolic procedure noncomexpf u; not domainp u and (noncomp mvar u or noncomexpf lc u or noncomexpf red u); symbolic procedure subf1(u,l); %U is a standard form, %L an association list of substitutions of the form %(<kernel> . <substitution>). %Value is the standard quotient for substituted expression. %Algorithm used is essentially the straight method. %Procedure depends on explicit data structure for standard form; if domainp u then if atom u then if null dmode!* then u ./ 1 else simpatom u else if dmode!* eq car u then !*d2q u else simp prepf u else begin integer n; scalar kern,m,w,x,xexp,y,y1,z; z := nil ./ 1; a0: kern := mvar u; if m := assoc(kern,asymplis!*) then m := cdr m; a: if null u or (n := degr(u,kern))=0 then go to b else if null m or n<m then y := lt u . y; u := red u; go to a; b: if not atom kern and not atom car kern then kern := prepf kern; if null l then xexp := if kern eq 'k!* then 1 else kern else if (xexp := subsublis(l,kern)) = kern and not assoc(kern,asymplis!*) then go to f; c: w := 1 ./ 1; n := 0; if y and cdaar y<0 then go to h; if (x := getrtype xexp) then typerr(x,"substituted expression"); x := simp xexp; % SIMP!* here causes problem with HE package; x := reorder numr x ./ reorder denr x; % needed in case substitution variable is in XEXP; if null l and kernp x and mvar numr x eq kern then go to f else if null numr x then go to e; %Substitution of 0; for each j in y do <<m := cdar j; w := multsq(exptsq(x,m-n),w); n := m; z := addsq(multsq(w,subf1(cdr j,l)),z)>>; e: y := nil; if null u then return z else if domainp u then return addsq(subf1(u,l),z); go to a0; f: sub2chk kern; for each j in y do z := addsq(multpq(car j,subf1(cdr j,l)),z); go to e; h: %Substitution for negative powers; x := simprecip list xexp; j: y1 := car y . y1; y := cdr y; if y and cdaar y<0 then go to j; k: m := -cdaar y1; w := multsq(exptsq(x,m-n),w); n := m; z := addsq(multsq(w,subf1(cdar y1,l)),z); y1 := cdr y1; if y1 then go to k else if y then go to c else go to e end; symbolic procedure subsublis(u,v); % NOTE: This definition assumes that with the exception of *SQ and % domain elements, expressions do not contain dotted pairs. begin scalar x; return if x := assoc(v,u) then cdr x else if atom v then v else if not idp car v then for each j in v collect subsublis(u,j) else if flagp(car v,'subfn) then subsubf(u,v) else if get(car v,'dname) then v else if car v eq '!*sq then subsublis(u,prepsq cadr v) else for each j in v collect subsublis(u,j) end; symbolic procedure subsubf(l,expn); %Sets up a formal SUB expression when necessary; begin scalar x,y; for each j in cddr expn do if (x := assoc(j,l)) then <<y := x . y; l := delete(x,l)>>; expn := sublis(l,car expn) . for each j in cdr expn collect subsublis(l,j); %to ensure only opr and individual args are transformed; if null y then return expn; expn := aconc!*(for each j in reversip!* y collect list('equal,car j,aeval cdr j),expn); return mk!*sq if l then simpsub expn else !*p2q mksp('sub . expn,1) end; flag('(int df),'subfn); endmodule; module exptf; % Functions for raising canonical forms to a power. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*exp); symbolic procedure exptsq(u,n); begin scalar x; if n=1 then return u else if n=0 then return if null numr u then rederr " 0**0 formed" else 1 ./ 1 else if null numr u then return u else if n<0 then return simpexpt list(mk!*sq u,n) else if null !*exp then return mksfpf(numr u,n) ./ mksfpf(denr u,n) else if kernp u then return mksq(mvar numr u,n) else if domainp numr u then return multsq(!:expt(numr u,n) ./ 1, 1 ./ exptf(denr u,n)) else if denr u=1 then return exptf(numr u,n) ./ 1; x := u; while (n := n-1)>0 do x := multsq(u,x); return x end; symbolic procedure exptf(u,n); if domainp u then !:expt(u,n) else if !*exp or kernlp u then exptf1(u,n) else mksfpf(u,n); symbolic procedure exptf1(u,n); %iterative multiplication seems to be faster than a binary sub- %division algorithm, probably because multiplying a small polynomial %by a large one is cheaper than multiplying two medium sized ones; if n=0 then 1 else begin scalar x; x := u; while (n := n-1)>0 do x := multf(u,x); return x end; endmodule; module kernel; % Functions for operations on kernels. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(exlist!* kprops!*); symbolic procedure fkern u; %finds the unique "p-list" reference to the kernel U. The choice of %the search and merge used here has a strong influence on some %timings. The ordered list used here is also used by Prepsq* to %order factors in printed output, so cannot be unilaterally changed; begin scalar x,y; if atom u then return list(u,nil); y := if atom car u then get(car u,'klist) else exlist!*; if not (x := assoc(u,y)) then <<x := list(u,nil); y := ordad(x,y); if atom car u then <<kprops!* := union(list car u,kprops!*); put(car u,'klist,y)>> else exlist!* := y>>; return x end; symbolic procedure kernels u; % Returns list of kernels in standard form u. kernels1(u,nil); symbolic procedure kernels1(u,v); % We append to end of list to put kernels in the right order, even % though a cons on the front of the list would be faster. if domainp u then v else kernels1(lc u, kernels1(red u, if x memq v then v else append(v,list x))) where x=mvar u; % else kernels1(red u,kernels1(lc u,ordas(mvar u,v))); % else kernels1(lc u,kernels1(red u,ordas(mvar u,v))); % symbolic procedure ordas(a,l); % if null l then list a % else if a=car l then l % else if ordp(a,car l) then a . l % else car l . ordas(a,cdr l); symbolic procedure kernp u; % true if U is standard quotient representation for a kernel. denr u=1 and not domainp(u := numr u) and null red u and lc u=1 and ldeg u=1; % ONEP endmodule; module mksp; % Functions for making standard powers. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*nosubs !*sub2 asymplis!*); global '(!*resubs powlis!* subfg!* wtl!*); % exports mksfpf,mksp,mksq,to; % imports !*p2f,aconc,eqcar,exptf,exptsq,leq,mkprod!*,module,multsq, % ordad,over,simpcar,union; symbolic procedure getpower(u,n); %U is a list (<kernel> . <properties>), N a positive integer. %Value is the standard power of U**N; <<if eqcar(car u,'expt) and n>1 then !*sub2 := t; car u . n>>; % begin scalar v; % v := cadr u; % if null v then return caar rplaca(cdr u,list (car u . n)); % a: if n=cdar v then return car v % else if n<cdar v % then return car rplacw(v,(caar v . n) . (car v . cdr v)) % else if null cdr v % then return cadr rplacd(v,list (caar v . n)); % v := cdr v; % go to a % end; symbolic procedure mksp(u,p); %U is a (non-unique) kernel and P a non-zero integer %Value is the standard power for U**P; getpower(fkern u,p); symbolic procedure u to p; %U is a (unique) kernel and P a non-zero integer; %Value is the standard power of U**P; u . p; % getpower(fkern u,p); symbolic procedure mksfpf(u,n); %raises form U to power N with EXP off. Returns a form; % if domainp u then !:expt(u,n) % else if n>=0 and kernlp u % then if null red u and onep lc u then !*p2f mksp(mvar u,ldeg u*n) % else exptf1(u,n) % else if n=1 or null subfg!* then mksp!*(u,n) % else (lambda x; %if x and cdr x<=n then nil else mksp!*(u,n)) % assoc(u,asymplis!*); exptf(mkprod!* u,n); symbolic procedure mksq(u,n); %U is a kernel, N a non-zero integer; %Value is a standard quotient of U**N, after making any %possible substitutions for U; begin scalar x,y,z; if null subfg!* then go to a1 else if (y := assoc(u,wtl!*)) and null car(y := mksq('k!*,n*cdr y)) then return y else if not atom u then go to b else if null !*nosubs and (z:= get(u,'avalue)) then go to c; if idp u then flag(list u,'used!*); %tell system U used as algebraic var (unless it's a string); a: if !*nosubs or n=1 then go to a1 else if (z:= assoc(u,asymplis!*)) and cdr z<=n then return nil ./ 1 else if ((z:= assoc(u,powlis!*)) or not atom u and car u memq '(expt sqrt) and (z := assoc(cadr u,powlis!*))) and not(n*cadr z)<0 %implements explicit sign matching; then !*sub2 := t; a1: if null x then x := fkern u; x := !*p2f getpower(x,n) ./ 1; return if y then multsq(y,x) else x; b: if null !*nosubs and atom car u and (z:= assoc(u,get(car u,'kvalue))) then go to c else if not('used!* memq cddr (x := fkern u)) then aconc(x,'used!*); go to a; c: z := cdr z; d: %optimization is possible as shown if all expression %dependency is known; %if cdr z then return exptsq(cdr z,n); %value already computed; if null !*resubs then !*nosubs := t; x := simpcar z; !*nosubs := nil; %rplacd(z,x); %save simplified value; %subl!* := z . subl!*; return exptsq(x,n) end; endmodule; module order; % Functions for internal ordering of expressions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(kord!*); symbolic procedure ordad(a,u); if null u then list a else if ordp(a,car u) then a . u else car u . ordad(a,cdr u); symbolic procedure ordn u; if null u then nil else if null cdr u then u else if null cddr u then ord2(car u,cadr u) else ordad(car u,ordn cdr u); symbolic procedure ord2(u,v); if ordp(u,v) then list(u,v) else list(v,u); symbolic procedure ordp(u,v); %returns TRUE if U ordered ahead or equal to V, NIL otherwise. %an expression with more structure at a given level is ordered %ahead of one with less; if null u then null v else if null v then t else if atom u then if atom v then if numberp u then numberp v and not u<v else if numberp v then t else orderp(u,v) else nil else if atom v then t else if car u=car v then ordp(cdr u,cdr v) else ordp(car u,car v); symbolic procedure ordpp(u,v); % This used to check (incorrectly) for NCMP!*; if car u eq car v then cdr u>cdr v else ordop(car u,car v); symbolic procedure ordop(u,v); begin scalar x; x := kord!*; a: if null x then return ordp(u,v) else if u eq car x then return t else if v eq car x then return; x := cdr x; go to a end; endmodule; module reord; % Functions for reordering standard forms. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(kord!*); global '(ncmp!*); symbolic procedure reorder u; %reorders a standard form so that current kernel order is used; if domainp u then u else raddf(rmultpf(lpow u,reorder lc u),reorder red u); symbolic procedure raddf(u,v); %adds reordered forms U and V; if null u then v else if null v then u else if domainp u then addd(u,v) else if domainp v then addd(v,u) else if peq(lpow u,lpow v) then (lpow u .* raddf(lc u,lc v)) .+ raddf(red u,red v) else if ordpp(lpow u,lpow v) then lt u . raddf(red u,v) else lt v . raddf(u,red v); symbolic procedure rmultpf(u,v); %multiplies power U by reordered form V; if null v then nil else if domainp v or reordop(car u,mvar v) then !*t2f(u .* v) else (lpow v .* rmultpf(u,lc v)) .+ rmultpf(u,red v); symbolic procedure reordop(u,v); if ncmp!* and noncomp u and noncomp v then t else ordop(u,v); symbolic procedure korder u; <<kord!* := if u = '(nil) then nil else for each x in u collect !*a2k x; rmsubs()>>; rlistat '(korder); symbolic procedure setkorder u; begin scalar v; v := kord!*; kord!* := u; return v end; endmodule; module forall; % FOR ALL Command. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*sub2 alglist!* arbl!* asymplis!*); global '(!*match cursym!* erfg!* frasc!* frlis!* letl!* mcond!* powlis!* powlis1!* subfg!* wtl!*); letl!* := '(let match clear saveas such); %special delimiters; % Contains two RPLAC references commented out. remprop('forall,'stat); remprop('forall,'formfn); symbolic procedure forallstat; begin scalar arbl,conds; if cursym!* memq letl!* then symerr('forall,t); flag(letl!*,'delim); arbl := remcomma xread nil; if cursym!* eq 'such then <<if not scan() eq 'that then symerr('let,t); conds := xread nil>>; remflag(letl!*,'delim); if not cursym!* memq letl!* then symerr('let,t) else return list('forall,arbl,conds,xread1 t) end; symbolic procedure forall u; begin scalar x,y; x := for each j in car u collect newvar j; y := pair(car u,x); mcond!* := subla(y,cadr u); frasc!* := y; frlis!* := union(x,frlis!*); return eval caddr u end; symbolic procedure arbstat; <<lpriw("*****","ARB no longer supported"); symerr('if,t)>>; put('arb,'stat,'arbstat); symbolic procedure newvar u; if not idp u then typerr(u,"free variable") else if flagp(u,'reserved) then typerr(list("Reserved variable",u),"free variable") else intern compress append(explode '!=,explode u); symbolic procedure formforall(u,vars,mode); begin scalar arbl!*,x; u := cdr u; % vars := append(car u,vars); % semantics are different if null cadr u then x := t else x := formbool(cadr u,vars,mode); return list('forall,list('list,mkquote union(arbl!*,car u), mkquote x,mkquote form1(caddr u,vars,mode))) end; symbolic procedure def u; % Defines a list of operators. for each x in u do if not eqexpr x or not idlistp cadr x then errpri2(x,t) else <<mkop caadr x; forall list(cdadr x,t,list('let,mkarg(list x,nil)))>>; put('def,'stat,'rlis); deflist('((forall formforall)),'formfn); deflist('((forall forallstat)),'stat); flag ('(clear let match),'quote); symbolic procedure formlet1(u,vars,mode); 'list . for each x in u collect if eqexpr x then list('list,mkquote 'equal,form1(cadr x,vars,mode), !*s2arg(form1(caddr x,vars,mode),vars)) else errpri2(x,t); symbolic procedure !*s2arg(u,vars); %makes all NOCHANGE operators into their listed form; if atom u then u else if not idp car u or not flagp(car u,'nochange) then for each j in u collect !*s2arg(j,vars) else mkarg(u,vars); put('let,'formfn,'formlet); put('clear,'formfn,'formclear); put('match,'formfn,'formmatch); symbolic procedure formclear(u,vars,mode); list('clear,formclear1(cdr u,vars,mode)); symbolic procedure formclear1(u,vars,mode); 'list . for each x in u collect form1(x,vars,mode); symbolic procedure formlet(u,vars,mode); list('let,formlet1(cdr u,vars,mode)); symbolic procedure formmatch(u,vars,mode); list('match,formlet1(cdr u,vars,mode)); symbolic procedure let u; let0 u; % to distinguish between operator % and function. symbolic procedure let0 u; begin a: if null u or errorp errorset(list('let2,mkquote cadar u,mkquote caddar u,nil,t), t,!*backtrace) then go to b; u := cdr u; go to a; b: mcond!* := frasc!* := nil end; symbolic procedure let2(u,v,w,b); begin scalar flg,x,y,z; % FLG is set true if free variables are found; x := subla(frasc!*,u); if x neq u then if atom x then return errpri1 u else <<flg := t; u := x>>; x := subla(frasc!*,v); if x neq v then <<v := x; if eqcar(v,'!*sq!*) then v := prepsq!* cadr v>>; % to ensure no kernels are replaced by uneq copies % during pattern matching process; %check for unmatched free variables; x := smemql(frlis!*,mcond!*); y := smemql(frlis!*,u); if (z := setdiff(x,y)) or (z := setdiff(setdiff(smemql(frlis!*,v),x), setdiff(y,x))) then <<lprie ("Unmatched free variable(s)" . z); erfg!* := 'hold; return nil>> else if eqcar(u,'getel) then u := eval cadr u; a: x := u; if null x then <<u := 0; return errpri1 u>> else if numberp x then return errpri1 u else if idp x and flagp(x,'reserved) then rederr list(x,"is a reserved identifier") else if y := getrtype x then return if z := get(y,'typeletfn) then apply(z,list(x,v,y,b,getrtype v)) else typelet(x,v,y,b,getrtype v) else if y := getrtype v then return if z := get(y,'typeletfn) then apply(z,list(x,v,nil,b,y)) else typelet(x,v,nil,b,y) else if not atom x then if not idp car x then return errpri2(u,'hold) else if car x eq 'df then if null letdf(u,v,w,x,b) then nil else return nil else if getrtype car x then return let2(reval x,v,w,b) else if not get(car x,'simpfn) then <<redmsg(car x,"operator"); mkop car x; go to a>> else nil else if null b and null w then <<if (y := get(x,'rtype)) then <<remprop(x,'rtype); remprop(x,'rvalue)>> else remprop(x,'avalue); remflag(list x,'antisymmetric); remprop(x,'infix); % remprop(x,'klist); % commented out: the relevant objects may still exist. remprop(x,'op); remprop(x,'opmtch); remprop(x,'simpfn); remflag(list x,'symmetric); wtl!* := delasc(x,wtl!*); if flagp(x,'opfn) then <<remflag(list x,'opfn); remd x>>; rmsubs(); % since all kernel lists are gone. return nil>>; if eqcar(x,'expt) and caddr x memq frlis!* then letexprn(u,v,w,!*k2q x,b,flg); % special case of a non-integer exponent match; x := simp0 x; return if not domainp numr x then letexprn(u,v,w,x,b,flg) else errpri1 u end; symbolic procedure letexprn(u,v,w,x,b,flg); %replacement of scalar expressions; begin scalar y,z; if denr x neq 1 then return let2(let!-prepf numr x, list('times,let!-prepf denr x,v),w,b) else if red(x := numr x) then return let2(let!-prepf !*t2f lt x, list('difference,v,let!-prepf red x),w,b) else if null (y := kernlp x) then <<y := term!-split x; return let2(let!-prepf car y, list('difference,v,let!-prepf cdr y),w,b)>> else if y neq 1 then return let2(let!-prepf quotf!*(x,y), list('quotient,v,let!-prepf y),w,b); x := klistt x; y := list(w . (if mcond!* then mcond!* else t),v,nil); if cdr x then return <<rmsubs(); !*match:= xadd!*(x . y,!*match,b)>> else if null w and cdar x=1 % ONEP then <<x := caar x; if null flg then <<if atom x then if flagp(x,'used!*) then rmsubs() else nil else if 'used!* memq cddr fkern x then rmsubs(); setk1(x,v,b)>> else if atom x then return errpri1 u else <<if get(car x,'klist) then rmsubs(); put(car x, 'opmtch, xadd!*(cdr x . y,get(car x,'opmtch),b))>>>> else <<rmsubs(); if v=0 and null w and not flg then <<asymplis!* := xadd(car x,asymplis!*,b); powlis!* := xadd(caar x . cdar x . y,powlis!*,'replace)>> else if w or not cdar y eq t or frasc!* then powlis1!* := xadd(car x . y,powlis1!*,b) else if null b and (z := assoc(caar x,asymplis!*)) and z=car x then asymplis!* := delasc(caar x,asymplis!*) else <<powlis!* := xadd(caar x . cdar x . y,powlis!*,b); if b then asymplis!* := delasc(caar x,asymplis!*)>>>> end; rlistat '(clear let match); symbolic procedure term!-split u; % U is a standard form which is not a kernel list (i.e., kernlp % is false). Result is the dotted pair of the leading part of the % expression for which kernlp is true, and the remainder; begin scalar x; while null red u do <<x := lpow u . x; u := lc u>>; return tpowadd(x,!*t2f lt u) . tpowadd(x,red u) end; symbolic procedure tpowadd(u,v); <<for each j in u do v := !*t2f(j .* v); v>>; symbolic procedure simp0 u; begin scalar x,y,z; y := setkorder frlis!*; if eqcar(u,'!*sq) then return simp0 prepsq!* cadr u; x := subfg!* . !*sub2; subfg!* := nil; if atom u or idp car u and (flagp(car u,'simp0fn) or get(car u,'rtype)) then z := simp u else z := simpiden u; alglist!* := delasc(u,alglist!*); % Since we don't want to keep this value. subfg!* := car x; !*sub2 := cdr x; setkorder y; return z end; flag('(cons difference eps expt minus plus quotient times),'simp0fn); symbolic procedure let!-prepf u; subla(for each x in frasc!* collect (cdr x . car x),prepf u); symbolic procedure match u; <<for each x in u do let2(cadr x,caddr x,t,t); frasc!* := mcond!* := nil>>; symbolic procedure clear u; begin rmsubs(); for each x in u do <<let2(x,nil,nil,nil); let2(x,nil,t,nil)>>; mcond!* := frasc!* := nil end; symbolic procedure typelet(u,v,ltype,b,rtype); % General function for setting up rules for typed expressions. % LTYPE is the type of the left hand side U, RTYPE, that of RHS V. % B is a flag that is true if this is an update, nil for a removal. begin if null rtype then rtype := 'scalar; if ltype eq rtype then go to a else if null b then go to c else if ltype then typerr(list(ltype,u),rtype) else if not atom u then if arrayp car u then go to a else typerr(u,rtype); redmsg(u,rtype); put(u,'rtype,rtype); ltype := rtype; a: if b and (not atom u or flagp(u,'used!*)) then rmsubs(); c: if not atom u then if arrayp car u then setelv(u,if b then v else nil) else put(car u,'opmtch,xadd!*(cdr u . list(nil . (if mcond!* then mcond!* else t),v,nil), get(car u,'opmtch),b)) else if null b then <<remprop(u,'rvalue); remprop(u,'rtype); if ltype eq 'array then remprop(u,'dimension)>> else if get(u,'avalue) then typerr(list("VARIABLE",u),rtype) else put(u,'rvalue,v) end; symbolic procedure setk(u,v); begin scalar x; if not atom u and idp car u and (x := get(car u,'rtype)) and (x := get(x,'setelemfn)) then apply2(x,u,v) else let2(u,v,nil,t); return v end; symbolic procedure setk1(u,v,b); begin scalar x,y; if not atom u then go to c else if null b then go to b1 else if (x := get(u,'avalue)) then <<x := cdr x; go to a>>; x := nil . nil; put(u,'avalue,'scalar . x); a: rplacd(rplaca(x,v),nil); return v; b1: if not get(u,'avalue) then msgpri(nil,u,"not found",nil,nil) else remprop(u,'avalue); return; c: if not atom car u then rederr "Invalid syntax: improper assignment"; u := car u . revlis cdr u; if null b then go to b2 else if not (y := get(car u,'kvalue)) then go to e else if x := assoc(u,y) then go to d; x := nil . nil; aconc(y,u . x); go to a; d: x := cdr x; go to a; e: x := nil . nil; put(car u,'kvalue,list(u . x)); go to a; b2: if not(y := get(car u,'kvalue)) or not (x := assoc(u,y)) then msgpri(nil,u,"not found",nil,nil) else put(car u,'kvalue,delete(x,y)); return; end; symbolic procedure klistt u; if atom u then nil else caar u . klistt cdr carx(u,'list); symbolic procedure kernlp u; % Returns leading domain coefficient if U is a monomial product % of kernels, NIL otherwise. if domainp u then u else if null red u then kernlp lc u else nil; symbolic procedure xadd(u,v,b); %adds replacement U to table V, with new rule at head; begin scalar x; x := assoc(car u,v); if null x then if b and not(b eq 'replace) then v := u . v else nil else if b then <<v := delete(x,v); if not(b eq 'replace) then v := u . v>> else if cadr x=cadr u then v := delete(x,v); return v end; symbolic procedure xadd!*(u,v,b); %adds replacement U to table V, with new rule at head; %also checks boolean part for equality; begin scalar x; x := v; while x and not(car u=caar x and cadr u=cadar x) do x := cdr x; if x then v := delete(car x,v); if b then v := u . v; return v end; endmodule; module rmsubs; % Remove system wide standard quotient substitutions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(alglist!*); global '(!*sqvar!*); % Contains RPLACA update of *SQVAR*. !*sqvar!*:= list 't; %variable used by *SQ expressions to control %resimplification; symbolic procedure rmsubs; begin rplaca(!*sqvar!*,nil); !*sqvar!* := list t; % while kprops!* do % <<remprop(car kprops!*,'klist); %kprops!* := cdr kprops!*>>; % exlist!* := list '(!*); %This is too dangerous: someone else may have constructed a %standard form; alglist!* := nil end; endmodule; module algdcl; % Various declarations. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(frlis!* preclis!* ws); symbolic procedure formopr(u,vars,mode); if mode eq 'symbolic then mkprog(nil,list list('flag,mkquote cdr u,mkquote 'opfn)) else list('operator,mkarg(cdr u,vars)); put('operator,'formfn,'formopr); symbolic procedure operator u; for each j in u do mkop j; rlistat '(operator); symbolic procedure remopr u; % Remove all operator related properties from id u. begin remprop(u,'alt); remprop(u,'infix); remprop(u,'op); remprop(u,'prtch); remprop(u,'simpfn); remprop(u,'unary); remflag(list u,'linear); remflag(list u,'nary); remflag(list u,'opfn); remflag(list u,'antisymmetric); remflag(list u,'symmetric); remflag(list u,'right); preclis!* := delete(u,preclis!*) end; flag('(remopr),'eval); symbolic procedure den u; mk!*sq (denr simp!* u ./ 1); symbolic procedure num u; mk!*sq (numr simp!* u ./ 1); flag('(den num max min),'opfn); flag('(den num),'noval); put('saveas,'formfn,'formsaveas); symbolic procedure formsaveas(u,vars,mode); list('saveas,formclear1(cdr u,vars,mode)); symbolic procedure saveas u; let0 list list('equal,car u, if eqcar(ws,'!*sq) and smemql(for each x in frasc!* collect car x, cadr ws) then list('!*sq,cadr ws,nil) else ws); rlistat '(saveas); endmodule; end; |
Added r33/alg2.red version [9bdab630b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module opmtch; % Functions that apply basic pattern matching rules. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(frlis!* subfg!*); symbolic procedure emtch u; if atom u then u else (lambda x; if x then x else u) opmtch u; symbolic procedure opmtch u; begin scalar x,y,z; x := get(car u,'opmtch); if null x then return nil else if null subfg!* then return nil; %null(!*sub2 := t); z := for each j in cdr u collect emtch j; a: if null x then return nil; y := mcharg(z,caar x,car u); b: if null y then go to c else if eval subla(car y,cdadar x) then return subla(car y,caddar x); y := cdr y; go to b; c: x := cdr x; go to a end; symbolic procedure mcharg(u,v,w); %procedure to determine if an argument list matches given template; %U is argument list of operator W; %V is argument list template being matched against; %if there is no match, value is NIL, %otherwise a list of lists of free variable pairings; if null u and null v then list nil else begin integer m,n; m := length u; n := length v; if flagp(w,'nary) and m>2 then if m<6 and flagp(w,'symmetric) then return mchcomb(u,v,w) else if n=2 then <<u := cdr mkbin(w,u); m := 2>> else return nil; %we cannot handle this case; return if m neq n then nil else if flagp(w,'symmetric) then mchsarg(u,v,w) else if mtp v then list pair(v,u) else mcharg2(u,v,list nil,w) end; symbolic procedure mchcomb(u,v,op); begin integer n; n := length u - length v +1; if n<1 then return nil else if n=1 then return mchsarg(u,v,op) else if not smemqlp(frlis!*,v) then return nil; return for each x in comb(u,n) join mchsarg((op . x) . setdiff(u,x),v,op) end; symbolic procedure comb(u,n); %value is list of all combinations of N elements from the list U; begin scalar v; integer m; if n=0 then return list nil else if (m:=length u-n)<0 then return nil else for i := 1:m do <<v := nconc!*(v,mapcons(comb(cdr u,n-1),car u)); u := cdr u>>; return u . v end; symbolic procedure mcharg2(u,v,w,x); %matches compatible list U of operator X against template V. begin scalar y; if null u then return w; y := mchk(car u,car v); u := cdr u; v := cdr v; return for each j in y join mcharg2(u,updtemplate(j,v,x),msappend(w,j),x) end; symbolic procedure msappend(u,v); % Mappend u and v with substitution. for each j in u collect append(v,sublis(v,j)); symbolic procedure updtemplate(u,v,w); begin scalar x,y; return for each j in v collect if (x := subla(u,j)) = j then j else if (y := reval!-without(x,w)) neq x then y else x end; symbolic procedure reval!-without(u,v); % Evaluate U without rules for operator V. This avoids infinite % recursion with statements like % for all a,b let kp(dx a,kp(dx a,dx b)) = 0; kp(dx 1,dx 2); begin scalar x; x := get(v,'opmtch); remprop(v,'opmtch); u := errorset(list('reval,mkquote u),t,t); put(v,'opmtch,x); if errorp u then error1() else return car u end; symbolic procedure mchk(u,v); if u=v then list nil else if atom v then if v memq frlis!* then list list (v . u) else nil else if atom u %special check for negative number match; then if numberp u and u<0 then mchk(list('minus,-u),v) else nil else if car u eq car v then mcharg(cdr u,cdr v,car u) else nil; symbolic procedure mkbin(u,v); if null cddr v then u . v else list(u,car v,mkbin(u,cdr v)); symbolic procedure mtp v; null v or (car v memq frlis!* and not car v member cdr v and mtp cdr v); symbolic procedure mchsarg(u,v,w); reversip!* if mtp v then for each j in permutations v collect pair(j,u) else for each j in permutations u join mcharg2(j,v,list nil,w); symbolic procedure permutations u; if null u then list u else for each j in u join mapcons(permutations delete(j,u),j); flagop antisymmetric,symmetric; flag ('(plus times cons),'symmetric); endmodule; module prep; %Functions for converting canonical forms into prefix forms % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*intstr); symbolic procedure prepsqxx u; % This is a top level conversion function. It is not clear if we % need prepsqxx, prepsqx, prepsq!* and prepsq, but we keep them all % for the time being. negnumberchk prepsqx u; symbolic procedure negnumberchk u; if eqcar(u,'minus) and numberp cadr u then - cadr u else u; symbolic procedure prepsqx u; if !*intstr then prepsq!* u else prepsq u; symbolic procedure prepsq u; if null numr u then 0 else sqform(u,function prepf); symbolic procedure sqform(u,v); (lambda (x,y); if y=1 then x else list('quotient,x,y)) (apply1(v,numr u),apply1(v,denr u)); symbolic procedure prepf u; replus prepf1(u,nil); symbolic procedure prepf1(u,v); if null u then nil else if domainp u then list retimes(prepd u . exchk v) else nconc!*(prepf1(lc u,if mvar u eq 'k!* then v else lpow u . v), prepf1(red u,v)); symbolic procedure prepd u; if atom u then if u<0 then list('minus,-u) else u else if apply1(get(car u,'minusp),u) % then list('minus,prepd1 !:minus u) then (if null x then 0 else list('minus,x)) where x=prepd1 !:minus u % else if !:onep u then 1 else apply1(get(car u,'prepfn),u); symbolic procedure prepd1 u; if atom u then u else apply1(get(car u,'prepfn),u); symbolic procedure exchk u; exchk1(u,nil,nil,nil); symbolic procedure exchk1(u,v,w,x); % checks forms for kernels in EXPT. U is list of powers. V is used % to build up the final answer. W is an association list of % previous non-constant (non foldable) EXPT's, X is an association % list of constant (foldable) EXPT arguments. if null u then exchk2(append(x,w),v) else if eqcar(caar u,'expt) then begin scalar y,z; y := simpexpon list('times,cdar u,caddar car u); if numberp cadaar u % constant argument then <<z := assoc2(y,x); if z then rplaca(z,car z*cadaar u) else x := (cadaar u . y) . x>> else <<z := assoc(cadaar u,w); if z then rplacd(z,addsq(y,cdr z)) else w := (cadaar u . y) . w>>; return exchk1(cdr u,v,w,x) end else if cdar u=1 then exchk1(cdr u,sqchk caar u . v,w,x) else exchk1(cdr u,list('expt,sqchk caar u,cdar u) . v,w,x); symbolic procedure exchk2(u,v); if null u then v else exchk2(cdr u, ((if eqcar(x,'quotient) and caddr x = 2 then if cadr x = 1 then list('sqrt,caar u) else list('expt,list('sqrt,caar u),cadr x) else if x=0.5 then list('sqrt,caar u) else if x=1 then caar u else list('expt,caar u,x)) where x = prepsqx cdar u) . v); symbolic procedure assoc2(u,v); % Finds key U in second position of terms of V, or returns NIL. if null v then nil else if u = cdar v then car v else assoc2(u,cdr v); symbolic procedure replus u; if atom u then u else if null cdr u then car u else 'plus . u; symbolic procedure retimes u; % U is a list of prefix expressions. Value is prefix form for the % product of these; begin scalar bool,x; for each j in u do <<if j=1 then nil % ONEP else if eqcar(j,'minus) then <<bool := not bool; if cadr j neq 1 then x := cadr j . x>> % ONEP else if numberp j and minusp j then <<bool := not bool; if j neq -1 then x := (-j) . x>> else x := j . x>>; x := if null x then 1 else if cdr x then 'times . reverse x else car x; return if bool then list('minus,x) else x end; symbolic procedure sqchk u; if atom u then u else if car u eq '!*sq then prepsq cadr u else if car u eq 'expt and caddr u=1 then cadr u else if atom car u then u else prepf u; endmodule; module sqprint; % Routines for printing standard forms and quotients. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*eraise !*fort !*horner !*nat !*nero !*outp !*pri orig!* posn!* wtl!* ycoord!* ymax!* ymin!*); deflist ('((!*sq !*sqprint)),'prifn); symbolic procedure !*sqprint u; sqprint cadr u; symbolic procedure printsq u; begin terpri!* t; sqprint u; terpri!* u; return u end; symbolic procedure sqprint u; %mathprints the standard quotient U; begin scalar flg,z; z := orig!*; if !*nat and posn!*<20 then orig!* := posn!*; if !*pri or wtl!* then go to c else if cdr u neq 1 then go to b else xprinf(car u,nil,nil); a: return (orig!* := z); b: flg := not domainp numr u and red numr u; if flg then prin2!* "("; xprinf(car u,nil,nil); if flg then prin2!* ")"; prin2!* " / "; flg := not domainp denr u and red denr u; if flg then prin2!* "("; xprinf(cdr u,nil,nil); if flg then prin2!* ")"; go to a; c: if null !*horner or errorp(!*outp:=errorset(list('horner,mkquote u),nil,nil)) then !*outp := prepsq!* u else !*outp := prepsq car !*outp; maprin !*outp; go to a end; symbolic procedure printsf u; begin prinsf u; terpri!* nil; return u end; symbolic procedure prinsf u; if null u then prin2!* 0 else xprinf(u,nil,nil); symbolic procedure xprinf(u,v,w); %U is a standard form. %V is a flag which is true if a term has preceded current form. %W is a flag which is true if form is part of a standard term; %Procedure prints the form and returns NIL; begin a: if null u then return nil else if domainp u then return xprid(u,v,w); xprint(lt u,v); u := red u; v := t; go to a end; symbolic procedure xprid(u,v,w); %U is a domain element. %V is a flag which is true if a term has preceded element. %W is a flag which is true if U is part of a standard term. %Procedure prints element and returns NIL; begin if minusf u then <<oprin 'minus; u := !:minus u>> else if v then oprin 'plus; if not w or u neq 1 then if atom u then prin2!* u else maprin u end; symbolic procedure xprint(u,v); %U is a standard term. %V is a flag which is true if a term has preceded this term. %Procedure prints the term and returns NIL; begin scalar flg,w; flg := not domainp tc u and red tc u; if not flg then go to a else if v then oprin 'plus; prin2!* "("; a: xprinf(tc u,if flg then nil else v,not flg); if flg then prin2!* ")"; if not atom tc u or not abs tc u=1 then oprin 'times; w := tpow u; if atom car w then prin2!* car w else if not atom caar w or caar w eq '!*sq then go to c else if caar w eq 'plus then maprint(car w,100) else maprin car w; b: if cdr w=1 then return; if !*nat and !*eraise then <<ycoord!* := ycoord!*+1; if ycoord!*>ymax!* then ymax!* := ycoord!*>> else prin2!* get('expt,'prtch); prin2!* if numberp cdr w and minusp cdr w then list cdr w else cdr w; if !*nat and !*eraise then <<ycoord!* := ycoord!*-1; if ymin!*>ycoord!* then ymin!* := ycoord!*>>; return; c: prin2!* "("; if not atom caar w then xprinf(car w,nil,nil) else sqprint cadar w; prin2!* ")"; go to b end; symbolic procedure varpri(u,v,w); begin scalar x; %U is expression being printed %V is the original form that was evaluated. %W is an id that indicates if U is the first, only or last element % in the current set (or NIL otherwise). if null u then u := 0; if !*nero and u=0 then return nil; v := setvars v; if (x := getrtype u) and flagp(x,'sprifn) then return if null v then apply1(get(get(x,'tag),'prifn),u) else maprin list('setq,car v,u); if w memq '(first only) then terpri!* t; if !*fort then return fvarpri(u,v,w); if v then u := 'setq . aconc(v,u); maprin u; if null w or w eq 'first then return nil else if not !*nat then prin2!* "$"; terpri!*(not !*nat); return nil end; symbolic procedure setvars u; if atom u then nil else if car u memq '(setel setk) then eval cadr u . setvars caddr u else if car u eq 'setq then cadr u . setvars caddr u else nil; endmodule; module mprint; % Basic output package for symbolic expressions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*list !*ratpri); global '(!*eraise !*fort !*nat !*nero !*outp !*period !*pri !*revpri cardno!* fortwidth!* initl!* nat!*!* obrkp!* orig!* pline!* posn!* spare!* varnam!* wtl!* ycoord!* ymax!* ymin!*); switch list,ratpri,revpri; %Global variables initialized in this section; % SPARE!* should be set in the system dependent code module. !*eraise := t; !*nat := nat!*!* := t; cardno!*:=20; fortwidth!* := 70; obrkp!* := t; orig!*:=0; posn!* := 0; varnam!* := 'ans; ycoord!* := 0; ymax!* := 0; ymin!* := 0; flag ('(cardno!* fortwidth!*),'share); initl!* := append('(orig!* pline!*),initl!*); put('orig!*,'initl,0); flag('(linelength),'opfn); %to make it a symbolic operator; symbolic procedure mathprint l; begin terpri!* t; maprin l; terpri!* t end; symbolic procedure maprin u; maprint(u,0); symbolic procedure maprint(l,p); begin scalar x,y; if null l then return nil else if atom l then go to b else if stringp l then return prin2!* l else if not atom car l then maprint(car l,p) % else if x := get(car l,'specprn) % then return apply1(x,if flagp(x,'full) then l else cdr l) else if (x := get(car l,'prifn)) and not(apply1(x,l) eq 'failed) then return l else if x := get(car l,'infix) then go to a else prin2!* car l; prin2!* "("; obrkp!* := nil; if cdr l then inprint('!*comma!*,0,cdr l); obrkp!* := t; e: prin2!* ")"; return l; b: if numberp l then go to d; c: return prin2!* l; d: if not l<0 or p<get('minus,'infix) then go to c; prin2!* "("; prin2!* l; go to e; a: p := not x>p; if not p then go to g; y := orig!*; prin2!* "("; orig!* := if posn!*<18 then posn!* else orig!*+3; g: if car l eq 'expt then exptpri(x,cdr l) else inprint(car l,x,cdr l); if not p then return l; prin2!* ")"; orig!* := y; return l end; symbolic procedure exptpri(p,l); % Prints expression in an exponent notation. begin scalar !*list,bool,x; bool := !*nat and !*eraise; if flatsizec car l+flatsizec cadr l >(linelength nil-spare!*)-posn!* then terpri!* t; % to avoid breaking exponent over line. if bool and null atom car l and idp caar l and (x := get(caar l,'prifn)) and (get(x,'expt) eq 'inbrackets) % to avoid mix up of indices and exponents. then<<prin2!* "("; maprint(car l,p); prin2!* ")">> else maprint(car l,p); if bool then <<ycoord!* := ycoord!*+1; if ycoord!*>ymax!* then ymax!* := ycoord!*>> else prin2!* get('expt,'prtch); % If you want brackets around exponents, replace 0 by p in next % line. begin scalar !*ratpri; l := cadr l; if eqcar(l,'quotient) and eqcar(cadr l,'minus) then l := list('minus,list(car l,cadadr l,caddr l)) else l := negnumberchk l; maprint(l,if bool then 0 else p) end; if bool then <<ycoord!* := ycoord!*-1; if ymin!*>ycoord!* then ymin!* := ycoord!*>> end; symbolic procedure inprint(op,p,l); begin scalar x,y; if op eq 'plus and !*revpri then l := reverse l; % print sum arguments in reverse order. if get(op,'alt) then go to a else if op eq 'setq and not atom (x := car reverse l) and idp car x and (y := getrtype x) and (y := get(get(y,'tag),'setprifn)) then return apply2(y,car l,x); if null atom car l and idp caar l and !*nat and (x := get(caar l,'prifn)) and (get(x,op) eq 'inbrackets) % to avoid mix up of indices and exponents. then<<prin2!* "("; maprint(car l,p); prin2!* ")">> else maprint(car l,p); a0: l := cdr l; a: if null l then return nil else if atom car l or not(op eq get!*(caar l,'alt)) then <<oprin op; maprint(negnumberchk car l,p)>> % difficult problem of negative numbers needing to be in % prefix form for pattern matching. else maprint(car l,p); go to a0 end; symbolic procedure flatsizec u; if null u then 0 else if atom u then lengthc u else flatsizec car u + flatsizec cdr u + 1; symbolic procedure oprin op; (lambda x; if null x then <<prin2!* " "; prin2!* op; prin2!* " ">> else if !*fort then prin2!* x else if !*list and obrkp!* and op memq '(plus minus) then <<terpri!* t; prin2!* x>> else if flagp(op,'spaced) then <<prin2!* " "; prin2!* x; prin2!* " ">> else prin2!* x) get(op,'prtch); symbolic procedure prin2!* u; begin integer m,n; if !*fort then return fprin2 u; n := lengthc u; if n>(linelength nil-spare!*) then go to d; m := posn!*+n; a: if m>(linelength nil-spare!*) then go to c else if not !*nat then prin2 u else pline!* := (((posn!* . m) . ycoord!*) . u) . pline!*; b: return (posn!* := m); c: terpri!* t; if (m := posn!*+n)<=(linelength nil-spare!*) then go to a; d: %identifier longer than one line; if !*fort then rederr list(u,"too long for FORTRAN"); %let LISP print the atom; terpri!* nil; prin2t u; m := remainder(n,(linelength nil-spare!*)); go to b end; symbolic procedure terpri!* u; begin integer n; if !*fort then return fterpri(u) else if not !*nat then <<if u then terpri(); return nil>> else if not pline!* then go to b; n := ymax!*; pline!* := reverse pline!*; a: scprint(pline!*,n); terpri(); if n= ymin!* then go to b; n := n-1; go to a; b: if u then terpri(); c: pline!* := nil; posn!* := orig!*; ycoord!* := ymax!* := ymin!* := 0 end; symbolic procedure scprint(u,n); begin scalar m; posn!* := 0; a: if null u then return nil else if not(cdaar u=n) then go to b else if not((m:= caaaar u-posn!*)<0) then spaces m; prin2 cdar u; posn!* := cdaaar u; b: u := cdr u; go to a end; endmodule; module ratprin; % Printing standard quotients. % Author: Eberhard Schruefer. % Modifications by: Anthony C. Hearn. fluid '(!*list !*mcd !*ratpri dmode!*); global '(!*fort !*nat ycoord!* ymin!* ymax!* posn!* orig!* pline!* spare!*); switch ratpri; !*ratpri := t; % default value if this module is loaded. put('quotient,'prifn,'quotpri); symbolic procedure quotpri u; % *mcd is included here since it uses rational domain elements. begin scalar dmode; if null !*ratpri or null !*nat or !*fort or !*list or null !*mcd then return 'failed else if flagp(dmode!*,'ratmode) then <<dmode := dmode!*; dmode!* := nil>>; u := ratfunpri1 u; if dmode then dmode!* := dmode; return u end; symbolic procedure ratfunpri1 u; begin scalar pline,npline,dpline,x,y; integer ycoord,ymin,ymax,orig,posn,lenden,lennum, hightnum,hightden,orgnum,orgden,offsnum,ll; ll := linelength nil - spare!* - 2; if ((x := chk!-printlength(cadr u,orig!*,ll)) eq 'failed) or ((y := chk!-printlength(caddr u,orig!*,ll)) eq 'failed) then go to doesntfit %It does also not fit on a new line else if x>(ll-posn!*) or y>(ll-posn!*) then terpri!* t; %It fits on a new line ycoord := ycoord!*; ymin := ymin!*; ymax := ymax!*; posn := posn!*; orig := orig!*; pline := pline!*; pline!* := nil; ycoord!* := ymin!* := ymax!* := posn!* := orig!* := 0; maprin cadr u; npline := pline!*; lennum := posn!*; offsnum := 1 - ymin!*; hightnum := ymax!* - ymin!* + 1; pline!* := nil; ycoord!* := ymin!* := ymax!* := posn!* := orig!* := 0; maprin caddr u; dpline := pline!*; lenden := posn!*; hightden := ymax!* - ymin!* + 1; pline!* := nil; if lenden > lennum then orgnum := (lenden - lennum)/2 else orgden := (lennum - lenden)/2; pline!* := append(update!-pline(orgnum + posn + 1, offsnum + ycoord,npline), append(update!-pline(orgden + posn + 1, ycoord - ymax!* - 1, dpline),pline)); ymin!* := ycoord - hightden; ymax!* := ycoord + hightnum; if ymin!* > ymin then ymin!* := ymin; if ymax!* < ymax then ymax!* := ymax; ycoord!* := ycoord; posn!* := posn; orig!* := orig; for j := 1:(max(lenden,lennum)+2) do prin2!* "-"; return; doesntfit: u := cdr u; maprint(car u,get('quotient,'infix)); oprin 'quotient; maprint(negnumberchk cadr u,get('quotient,'infix)) end; symbolic procedure update!-pline(x,y,pline); for each j in pline collect (((caaar j + x) . (cdaar j + x)) . (cdar j + y)) . cdr j; symbolic procedure chk!-printlength(u,m,n); %This one should better be table driven. begin scalar l; return if atom u then if (l := lengthc u + m) > n then 'failed else l else if car u eq 'expt then if null((l := chk!-printlength(cadr u,m,n)) eq 'failed) and l<n then chk!-printlength(caddr u,l,n) else 'failed else if car u eq 'minus then if atom cadr u then if (l := 3 + lengthc cadr u + m) > n then 'failed else l else chk!-printlength(cadr u,m+5,n) else if car u eq 'plus then begin u := cdr u; if (l := chk!-printlength(car u,m,n)) eq 'failed then return 'failed; a: if null cdr(u := cdr u) then return chk!-printlength( if eqcar(car u,'minus) then cadar u else car u,3+l,n); if ((l := chk!-printlength( if eqcar(car u,'minus) then cadar u else car u,3+l,n)) eq 'failed) then return 'failed else go to a end else if car u eq 'times then begin u := cdr u; if (l := chk!-printlength(car u, m+if eqcar(car u,'plus) then 2 else 0,n)) eq 'failed then return 'failed; a: if null cdr(u := cdr u) then return chk!-printlength(car u, l+if eqcar(car u,'plus) then 3 else 1,n); if ((l := chk!-printlength(car u, l+if eqcar(car u,'plus) then 3 else 1,n)) eq 'failed) then return 'failed else go to a end else if car u eq 'quotient then begin scalar ld; u := cdr u; if (l := chk!-printlength(car u,m+2,n)) eq 'failed then return 'failed else if (ld := chk!-printlength(cadr u,m+2,n)) eq 'failed then return 'failed; return max(l,ld) end else if car u eq 'difference then begin u := cdr u; if (l := chk!-printlength(car u,m+3,n)) eq 'failed then return 'failed else return chk!-printlength(cadr u,m+l,n) end else if get(car u,'klist) then begin l := lengthc car u+2; u := cdr u; if (l := chk!-printlength(car u,m+l,n)) eq 'failed then return 'failed else if null cdr u then return l; a: if null cdr(u := cdr u) then return chk!-printlength(car u,1+l,n); if ((l := chk!-printlength(car u,1+l,n)) eq 'failed) then return 'failed else go to a end else if ((l := flatsizec u + m)) > n then 'failed else l end; endmodule; module fortpri; % FORTRAN output package for expressions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(scountr explis fbrkt fvar nchars svar); global '(!*fort !*nat !*nero !*outp !*period !*pri cardno!* fortwidth!* initl!* nat!*!* obrkp!* orig!* pline!* posn!* spare!* varnam!* wtl!* ycoord!* ymax!* ymin!*); %Global variables initialized in this section; % SPARE!* should be set in the system dependent code module. !*nat := nat!*!* := t; cardno!*:=20; fortwidth!* := 70; obrkp!* := t; orig!*:=0; posn!* := 0; varnam!* := 'ans; ycoord!* := 0; ymax!* := 0; ymin!* := 0; flag ('(cardno!* fortwidth!*),'share); initl!* := append('(orig!* pline!*),initl!*); put('orig!*,'initl,0); symbolic procedure varname u; %sets the default variable assignment name; varnam!* := car u; rlistat '(varname); symbolic procedure flength(u,chars); if chars<0 then chars else if atom u then chars-if numberp u then if fixp u then flatsizec u+1 else flatsizec u else flatsizec((lambda x; if x then x else u) get(u,'prtch)) else flength(car u,flenlis(cdr u,chars)-2); symbolic procedure flenlis(u,chars); if null u then chars else if chars<0 then chars else if atom u then flength(u,chars) else flenlis(cdr u,flength(car u,chars)); symbolic procedure fmprint(l,p); begin scalar x; if null l then return nil else if atom l then go to b else if stringp l then return fprin2 l else if not atom car l then fmprint(car l,p) % else if x := get(car l,'specprn) % then return apply1(x,cdr l) else if (x := get(car l,'prifn)) and not((x := apply1(x,l)) eq 'failed) then return x else if x := get(car l,'infix) then go to a else fprin2 car l; fprin2 "("; fbrkt := nil . fbrkt; % x := !*period; !*period := nil; % Turn off . inside an op exp if cdr l then fnprint('!*comma!*,0,cdr l); % !*period := x; e: fprin2 ")"; return fbrkt := cdr fbrkt; b: if numberp l then go to d; c: return fprin2 l; d: if not l<0 then go to c; fprin2 "("; fbrkt := nil . fbrkt; fprin2 l; go to e; a: p := not x>p; if p then <<fprin2 "("; fbrkt := nil . fbrkt>>; fnprint(car l,x,cdr l); if p then <<fprin2 ")"; fbrkt := cdr fbrkt>> end; symbolic procedure fnprint(op,p,l); begin if op eq 'expt then return fexppri(p,l) else if get(op,'alt) then go to a; fmprint(car l,p); a0: l := cdr l; a: if null l then return nil else if not atom car l and op eq get!*(caar l,'alt) then go to b; foprin op; b: fmprint(car l,p); go to a0 end; symbolic procedure fexppri(p,l); begin scalar pperiod; fmprint(car l,p); foprin 'expt; pperiod := !*period; if numberp cadr l then !*period := nil else !*period := t; fmprint(cadr l,p); !*period := pperiod end; symbolic procedure foprin op; (lambda x; if null x then fprin2 op else fprin2 x) get(op,'prtch); symbolic procedure fvarpri(u,v,w); %prints an assignment in FORTRAN notation; begin integer scountr,llength,nchars; scalar explis,fvar,svar; llength := linelength nil; if not posintegerp cardno!* then typerr(cardno!*,"FORTRAN card number"); if not posintegerp fortwidth!* then typerr(fortwidth!*,"FORTRAN line width"); linelength fortwidth!*; if stringp u then return <<fprin2 u; if w eq 'only then fterpri(t); linelength llength>>; if eqcar(u,'!*sq) then u := prepsq!* cadr u; scountr := 0; nchars := ((linelength nil-spare!*)-12)*cardno!*; %12 is to allow for indentation and end of line effects; svar := varnam!*; fvar := if null v then svar else car v; if posn!*=0 and w then fortpri(fvar,u,w) else fortpri(nil,u,w); % should mean expression preceded by a string. linelength llength end; symbolic procedure fortpri(fvar,xexp,w); begin scalar fbrkt; if flength(xexp,nchars)<0 then xexp := car xexp . fout(cdr xexp,car xexp,w); if fvar then <<posn!* := 0; fprin2 " "; fmprint(fvar,0); fprin2 "=">>; fmprint(xexp,0); if w then fterpri(w) end; symbolic procedure fout(args,op,w); begin integer ncharsl; scalar distop,x,z; ncharsl := nchars; if op memq '(plus times) then distop := op; while args do <<x := car args; if atom x and (ncharsl := flength(x,ncharsl)) or (null cdr args or distop) and (ncharsl := flength(x,ncharsl))>0 then z := x . z else if distop and flength(x,nchars)>0 then <<z := fout1(distop . args,w) . z; args := list nil>> else <<z := fout1(x,w) . z; ncharsl := flength(op,ncharsl)>>; ncharsl := flength(op,ncharsl); args := cdr args>>; return reversip!* z end; symbolic procedure fout1(xexp,w); begin scalar fvar; fvar := genvar(); explis := (xexp . fvar) . explis; fortpri(fvar,xexp,w); return fvar end; symbolic procedure fprin2 u; % FORTRAN output of U; begin integer m,n; n := flatsizec u; m := posn!*+n; if numberp u and fixp u and !*period then m := m+1; if m<(linelength nil-spare!*) then posn!* := m else <<terpri(); spaces 5; prin2 ". "; posn!* := n+7>>; prin2 u; if numberp u and fixp u and !*period then prin2 "." end; symbolic procedure fterpri(u); <<if not posn!*=0 and u then terpri(); posn!* := 0>>; symbolic procedure genvar; intern compress append(explode svar,explode(scountr := scountr + 1)); endmodule; module gint; % Support for gaussian integers (complex numbers). % Author: Eberhard Schruefer. global '(domainlist!*); fluid '(!*complex); switch complex; domainlist!* := union('(!:gi!:),domainlist!*); symbolic procedure setcmpxmode(u,bool); % Sets polynomial domain mode in complex case. begin scalar x,y; x := get(u,'tag); if u eq 'complex then if null dmode!* then return if null bool then nil else <<put('i,'idvalfn,'mkdgi); setdmode1('complex,bool)>> else if null bool then return if null !*complex then nil else if get(dmode!*,'dname) eq 'complex then <<remprop('i,'idvalfn); setdmode1('complex,nil)>> else <<remprop('i,'idvalfn); setdmode1(get(get(dmode!*,'realtype),'dname), t)>> else if dmode!* eq '!:gi!: then return nil else if not (y := get(dmode!*,'cmpxtype)) then dmoderr(dmode!*,x) else <<put('i,'idval,get(car y,'ivalue)); return setdmode1(get(car y,'dname),bool)>> else if null bool then <<put('i,'idvalfn,'mkdgi); return setdmode1('complex,t)>> else <<u := get(u,'tag); y := get(u,'cmpxtype); if null y then dmoderr(u,'!:gi!:); put('i,'idvalfn,get(car y,'ivalue)); return setdmode1(get(car y,'dname),bool)>> end; put('complex,'tag,'!:gi!:); put('!:gi!:,'dname,'complex); put('!:gi!:,'i2d,'!*i2gi); put('!:gi!:,'minusp,'giminusp!:); put('!:gi!:,'zerop,'gizerop!:); put('!:gi!:,'onep,'gionep!:); put('!:gi!:,'plus,'giplus!:); put('!:gi!:,'difference,'gidifference!:); put('!:gi!:,'times,'gitimes!:); put('!:gi!:,'quotient,'giquotient!:); put('!:gi!:,'divide,'gidivide!:); put('!:gi!:,'gcd,'gigcd!:); put('!:gi!:,'factorfn,'gifactor!:); put('!:gi!:,'rationalizefn,'girationalize!:); put('!:gi!:,'prepfn,'giprep!:); put('!:gi!:,'intequivfn,'gintequiv!:); put('!:gi!:,'specprn,'giprn!:); put('!:gi!:,'prifn,'giprn!:); put('!:gi!:,'cmpxfn,'mkgi); put('!:gi!:,'units,'(((!:gi!: 0 . 1) . (!:gi!: 0 . -1)) ((!:gi!: 0 . -1) . (!:gi!: 0 . 1)))); symbolic procedure !*i2gi u; '!:gi!: . (u . 0); symbolic procedure giminusp!: u; %*** this is rather a test for u being in a canonical form! ***; if cddr u = 0 then minusp cadr u else minusp cddr u; symbolic procedure gizerop!: u; cadr u = 0 and cddr u = 0; symbolic procedure gionep!: u; cadr u=1 and cddr u=0; symbolic procedure gintequiv!: u; if cddr u=0 then cadr u else nil; symbolic procedure mkdgi u; ('!:gi!: . (0 . 1)) ./ 1; symbolic procedure mkgi(re,im); '!:gi!: . (re . im); symbolic procedure giplus!:(u,v); mkgi(cadr u+cadr v,cddr u+cddr v); symbolic procedure gidifference!:(u,v); mkgi(cadr u-cadr v,cddr u-cddr v); symbolic procedure gitimes!:(u,v); (lambda r1,i1,r2,i2; mkgi(r1*r2-i1*i2,r1*i2+r2*i1)) (cadr u,cddr u,cadr v,cddr v); symbolic procedure giquotient!:(u,v); begin integer r1,i1,r2,i2,d; scalar rr,ii; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; d := r2*r2+i2*i2; rr := divide(r1*r2+i1*i2,d); ii := divide(i1*r2-i2*r1,d); return if cdr ii=0 and cdr rr=0 then mkgi(car rr,car ii) else '!:gi!: . (0 . 0) end; symbolic procedure gidivide!:(u,v); begin integer r1,i1,r2,i2,d,rr,ir,rq,iq; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; d := r2*r2+i2*i2; rq := r1*r2+i1*i2; iq := i1*r2-i2*r1; rq := car divide(2*rq+if rq<0 then -d else d,2*d); iq := car divide(2*iq+if iq<0 then -d else d,2*d); rr := r1-(rq*r2-iq*i2); ir := i1-(iq*r2+rq*i2); return mkgi(rq,iq) . mkgi(rr,ir) end; symbolic procedure giremainder(u,v); begin integer r1,i1,r2,i2,d,rr,ir,rq,iq; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; d := r2*r2+i2*i2; rq := r1*r2+i1*i2; iq := i1*r2-i2*r1; rq := car divide(2*rq+if rq<0 then -d else d,2*d); iq := car divide(2*iq+if iq<0 then -d else d,2*d); rr := r1-(rq*r2-iq*i2); ir := i1-(iq*r2+rq*i2); return '!:gi!: . (rr . ir) end; symbolic procedure gigcd!:(u,v); % Straightforward Euclidean algorithm. if gizerop!: v then fqa u else gigcd!:(v,giremainder(u,v)); symbolic procedure fqa u; %calculates the unique first-quadrant associate of u; if cddr u=0 then abs cadr u else if cadr u=0 then '!:gi!: . (0 . abs cddr u) else if (cadr u*cddr u)>0 then '!:gi!: . (abs cadr u . abs cddr u) else '!:gi!: . (abs cddr u . abs cadr u); symbolic procedure gifactor!: u; % B. Trager's algorithm. begin scalar x,y,norm,aftrs,ifctr,ftrs,mvu,dmode!*,!*exp,w,z; !*exp := t; ifctr := factorf fd2f u; dmode!* := '!:gi!:; w := car ifctr; if null(ifctr := cdr ifctr) then return list w; for each f in ifctr do begin integer s; %calculate a square free norm; scalar l; go to b; a: l := list(mvu . prepf addf(!*k2f mvu,multd(s,!*k2f 'i))); b: y := numr subf1(car f,l); if domainp y then <<w := multd(y,w); return>>; mvu := mvar y; if realp y then <<s := s-1; go to a>>; norm := multf(y,conj y); if not sqfrp norm then <<s := s-1; go to a>>; dmode!* := nil; ftrs := factorf norm; dmode!* := '!:gi!:; l := if s=0 then nil else list(mvu . prepf addf(!*k2f mvu, negf multd(s,!*k2f 'i))); for each j in cdr ftrs do <<x := gcdf!*(car j,y); y := quotf!*(y,x); z := if l then numr subf1(x,l) else x; aftrs := (z . cdr f) . aftrs>> end; return multd(car ftrs,w) . aftrs end; symbolic procedure gaussfactorize u; begin scalar ftrs,x,y,!*exp; integer n; !*exp := t; x := gifactor!: expnd !*a2f car u; y := if null cdr u then 'gfactor else cadr u; ftrs := (0 . car x) . nil; for each j in cdr x do for k := 1:cdr j do ftrs := ((n:=n+1) . mk!*sq(car j ./ 1)) . ftrs; return multiple!-result(ftrs,y) end; put('gfactorize,'simpfn,'gaussfactorize); symbolic procedure realp u; if domainp u then atom u or not get(car u,'cmpxfn) or cddr u = cddr apply1(get(car u,'i2d),1) else realp lc u and realp red u; symbolic procedure fd2f u; if atom u then u else if car u eq '!:gi!: then addf(!*n2f cadr u,multf(!*k2f 'i,!*n2f cddr u)) else addf(multf(!*p2f lpow u,fd2f lc u),fd2f red u); symbolic procedure sqfrp u; domainp gcdf!*(u,diff(u,mvar u)); symbolic procedure giprep!: u; %giprep1 cdr u; prepsq!* addsq(!*n2f cadr u ./ 1, multsq(!*n2f cddr u ./ 1, !*k2q 'i)); symbolic procedure giprep1 u; %not used now; if cdr u=0 then car u else if car u=0 then retimes list(cdr u,'i) else begin scalar gn; gn := gcdn(car u,cdr u); return retimes list(gn, replus list(car u/gn,retimes list(cdr u/gn,'i))) end; symbolic procedure giprn!: v; (lambda u; if atom u or (car u eq 'times) then maprin u else <<prin2!* "("; maprin u; prin2!* ")" >>) giprep!: v; symbolic procedure girationalize!: u; %Rationalizes standard quotient u over the gaussian integers. begin scalar x,y,z; y := denr u; z := conj y; if y=z then return u; x := multf(numr u,z); y := multf(y,z); return x ./ y end; %*** some utility functions ***; symbolic procedure repart u; begin scalar x; return if atom u then u else if domainp u and (x := get(car u,'cmpxfn)) then apply2(x,cadr u,0) else addf(multpf(lpow u,repart lc u),repart red u) end; symbolic procedure impart u; begin scalar x; return if atom u then nil else if domainp u and (x := get(car u,'cmpxfn)) then apply2(x,cddr u,0) else addf(multpf(lpow u,impart lc u),impart red u) end; symbolic procedure conj u; begin scalar x; return if atom u then u else if domainp u and (x := get(car u,'cmpxfn)) then apply2(x,cadr u,!:minus cddr u) else addf(multpf(lpow u,conj lc u),conj red u) end; deflist('((repart repart) (impart impart) (conj conj)),'polyfn); initdmode 'complex; endmodule; module gfloat; % Support for gaussian floats. % Authors: Barbara Gates and Eberhard Schruefer. global '(domainlist!* e!-value!* pi!-value!*); fluid '(!*complex!_float); % This module needs gint to be loaded too. domainlist!*:=union('(!:gf!:),domainlist!*); put('complex!_float,'tag,'!:gf!:); put('!:gf!:,'dname,'complex!_float); put('!:gf!:,'i2d,'!*i2gf); put('!:gf!:,'minusp,'gfminusp!:); put('!:gf!:,'zerop,'gfzerop!:); put('!:gf!:,'onep,'gfonep!:); put('!:gf!:,'plus,'gfplus!:); put('!:gf!:,'difference,'gfdifference!:); put('!:gf!:,'times,'gftimes!:); put('!:gf!:,'quotient,'gfquotient!:); put('!:gf!:,'prepfn,'gfprep!:); put('!:gf!:,'prifn,'gfprn!:); put('!:gf!:,'rationalizefn,'girationalize!:); put('!:rn!:,'!:gf!:,'rn2gf); put('!:ft!:,'!:gf!:,'ft2gf); put('!:gf!:,'!:ft!:,'gf2f); put('!:gf!:,'cmpxfn,'mkgf); put('!:gf!:,'ivalue,'mkdgf); put('!:gf!:,'realtype,'!:ft!:); flag('(!:gf!:),'field); symbolic procedure mkdgf u; ('!:gf!: . (0.0 . 1.0)) ./ 1; smacro procedure mkgf(rp,ip); '!:gf!: . (rp . ip); symbolic procedure !*i2gf u; '!:gf!: . (float u . 0.0); symbolic procedure rn2gf u; mkgf(cdr !*rn2ft u,0.0); symbolic procedure ft2gf u; mkgf(cdr u,0.0); symbolic procedure gf2f u; % if cddr u=0.0 then '!:ft!: . cadr u else if zerop cddr u then '!:ft!: . cadr u else rederr "Conversion to float requires zero imaginary part"; symbolic procedure gfminusp!: u; % This doesn't make much sense. % if abs cddr u<0.000001 then cadr u<0.0 else cddr u<0.0; if abs cddr u<0.000001 then minusp cadr u else minusp cddr u; symbolic procedure gfzerop!: u; % cadr u=0.0 and cddr u=0.0; zerop cadr u and zerop cddr u; symbolic procedure gfonep!: u; %cddr u =0.0 and ftonep!:('!:ft!: . cadr u); %this is too restrictive; ftonep!:('!:ft!: . (cadr u+cddr u)) and ftonep!:('!:ft!: . cadr u); symbolic procedure gfplus!:(u,v); mkgf(cadr u+cadr v,cddr u+cddr v); symbolic procedure gfdifference!:(u,v); mkgf(cadr u-cadr v,cddr u-cddr v); symbolic procedure gftimes!:(u,v); begin scalar r1,i1,r2,i2,rr,ii; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; rr := r1*r2-i1*i2; ii := r1*i2+r2*i1; return mkgf(rr,ii) end; symbolic procedure gfquotient!:(u,v); begin scalar r1,i1,r2,i2,rr,ii,d; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; d := r2*r2+i2*i2; rr := r1*r2+i1*i2; ii := i1*r2-i2*r1; return mkgf(rr/d,ii/d) end; symbolic procedure gfprep!: u; gfprep1 cdr u; %begin scalar dmode!*; %dmode!*:='!:ft!:; %return %prepsq!* addsq(('!:ft!: . cadr u) ./ 1, % multsq(('!:ft!: . cddr u) ./ 1,!*k2q 'i)) %end; symbolic procedure gfprep1 u; % if cdr u=0.0 then car u if zerop cdr u then car u % else if car u=0.0 then if ftonep!:('!:ft!: . cdr u) then 'i else if zerop car u then if ftonep!:('!:ft!: . cdr u) then 'i else list('times,cdr u,'i) else list('plus,car u,if ftonep!:('!:ft!: . cdr u) then 'i else list('times,cdr u,'i)); symbolic procedure gfprn!: u; (lambda v; if atom v or car v eq 'times or car v memq domainlist!* then maprin v else <<prin2!* "("; maprin v; prin2!* ")">>) gfprep1 cdr u; % *** Elementary functions. deflist('((e egf!*) (pi pigf!*)),'!:gf!:); symbolic procedure egf!*; mkgf(e!-value!*,0.0); symbolic procedure pigf!*; mkgf(pi!-value!*,0.0); deflist('((expt gfexpt) (sin gfsin) (cos gfcos) (tan gftan) (asin gfasin) (acos gfacos) (atan gfatan) (log gflog)),'!:gf!:); symbolic procedure gfexpt(u,v); begin scalar re1,im1,re2,im2,norm,ang,angr; re1 := cadr u; im1 := cddr u; re2 := cadr v; im2 := cddr v; norm := sqrt(re1*re1+im1*im1); ang := ftarg!: u; angr := im2*log norm+re2*ang; norm := exp(log norm*re2-im2*ang); return mkgf(norm*cos angr,norm*sin angr) end; symbolic procedure ftarg!: u; %Returns ftarg u in the range (-pi,+pi); % (lambda x,y; if y=0.0 then if x<0.0 then pi!-value!* (lambda x,y; if zerop y then if minusp x then pi!-value!* else 0.0 else % if x=0.0 then if y<0.0 then -pi!-value!*/2 else if zerop x then if minusp y then -pi!-value!*/2 else pi!-value!*/2 else % if x<0.0 and y<0.0 then atan(y/x)-pi!-value!* if minusp x and minusp y then atan(y/x)-pi!-value!* % else if x<0.0 and not(y<0.0) then else if minusp x and not minusp y then atan(y/x)+pi!-value!* else atan(y/x)) (cadr u,cddr u); put('ftarg!:,'!:gf!:,'ftarg!:); symbolic procedure gfsin u; mkgf(sin cadr u*cosh cddr u,cos cadr u*sinh cddr u); symbolic procedure gfcos u; mkgf(cos cadr u*cosh cddr u,-sin cadr u*sinh cddr u); symbolic procedure gftan u; begin scalar v; v := cos(2.0*cadr u)+cosh(2.0*cddr u); return mkgf(sin(2.0*cadr u)/v,sinh(2.0*cddr u)/v) end; symbolic procedure gfasin u; begin scalar a,b,c; a := 0.5*sqrt(expt(cadr u+1.0,2)+cddr u*cddr u); b := 0.5*sqrt(expt(cadr u-1.0,2)+cddr u*cddr u); c := a+b; b := a-b; a := c; c := a+sqrt(a*a-1.0); return mkgf(asin b,log c) end; symbolic procedure gfacos u; begin scalar a,b,c; a := 0.5*sqrt(expt(cadr u+1.0,2)+cddr u*cddr u); b := 0.5*sqrt(expt(cadr u-1.0,2)+cddr u*cddr u); c := a+b; b := a-b; a := c; c := a+sqrt(a*a-1.0); return mkgf(acos b,-1.0*log c) end; symbolic procedure gfatan u; gftimes!:(gflog(gfquotient!:( gfplus!:(!*i2gf 1,gftimes!:(mkgf(0.0,-1.0),u)), gfplus!:(!*i2gf 1,gftimes!:(mkgf(0.0,1.0),u)))), mkgf(0.0,0.5)); symbolic procedure gflog u; begin scalar norm; norm := sqrt(cadr u*cadr u+cddr u*cddr u); return mkgf(log norm,ftarg!: u) end; symbolic procedure sinh u; 0.5*(exp u-exp(-u)); symbolic procedure cosh u; 0.5*(exp u+exp(-u)); initdmode 'complex!_float; endmodule; module modular; % *** Tables for modular integers ***. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(domainlist!*); fluid '(!*modular current!-modulus alglist!* dmode!*); switch modular; domainlist!* := union('(!:mod!:),domainlist!*); put('modular,'tag,'!:mod!:); put('!:mod!:,'dname,'modular); flag('(!:mod!:),'field); flag('(!:mod!:),'convert); put('!:mod!:,'i2d,'!*i2mod); put('!:mod!:,'!:bf!:,'modcnv); put('!:mod!:,'!:ft!:,'modcnv); put('!:mod!:,'!:rn!:,'modcnv); put('!:mod!:,'minusp,'modminusp!:); put('!:mod!:,'plus,'modplus!:); put('!:mod!:,'times,'modtimes!:); put('!:mod!:,'difference,'moddifference!:); put('!:mod!:,'quotient,'modquotient!:); put('!:mod!:,'divide,'moddivide!:); put('!:mod!:,'gcd,'modgcd!:); put('!:mod!:,'zerop,'modzerop!:); put('!:mod!:,'onep,'modonep!:); put('!:mod!:,'factorfn,'factormod!:); put('!:mod!:,'prepfn,'modprep!:); put('!:mod!:,'prifn,'prin2); symbolic procedure !*i2mod u; %converts integer U to modular form; % if (u := general!-modular!-number u)=0 then nil else '!:mod!: . u; '!:mod!: . general!-modular!-number u; symbolic procedure modcnv u; rederr list("Conversion between modular integers and", get(car u,'dname),"not defined"); symbolic procedure modminusp!: u; nil; %what else can one do?; symbolic procedure !*modular2f u; % if u=0 then nil else if u=1 then 1 else '!:mod!: . u; '!:mod!: . u; symbolic procedure modplus!:(u,v); !*modular2f general!-modular!-plus(cdr u,cdr v); symbolic procedure modtimes!:(u,v); !*modular2f general!-modular!-times(cdr u,cdr v); symbolic procedure moddifference!:(u,v); !*modular2f general!-modular!-difference(cdr u,cdr v); symbolic procedure moddivide!:(u,v); !*i2mod 0 . u; symbolic procedure modgcd!:(u,v); !*i2mod 1; symbolic procedure modquotient!:(u,v); !*modular2f general!-modular!-times(cdr u, general!-modular!-reciprocal cdr v); symbolic procedure modzerop!: u; cdr u=0; symbolic procedure modonep!: u; cdr u=1; symbolic procedure factormod!: u; begin scalar alglist!*,dmode!*; % 1 is needed since factorize expects first factor to be a number. return pfactor(!*q2f resimp(u ./ 1),current!-modulus) end; symbolic procedure modprep!: u; cdr u; initdmode 'modular; % Modular routines are defined in the GENMOD module with the exception % of the following: symbolic procedure setmod u; % Returns value of CURRENT!-MODULUS on entry unless an error % occurs. It crudely distinguishes between prime moduli, for which % division is possible, and others, for which it possibly is not. % The code should really distinguish prime powers and composites as % well. begin scalar dmode!*; u := reval u; % dmode* is NIL, so this won't be reduced wrt % current modulus. if fixp u and u>0 then <<if primep u then flag('(!:mod!:),'field) else remflag('(!:mod!:),'field); return set!-general!-modulus u>> else if u=0 or null u then return current!-modulus else typerr(u,"modulus") end; flag('(setmod),'opfn); %to make it a symbolic operator; flag('(setmod),'noval); %A more general definition of general-modular-number. %symbolic procedure general!-modular!-number m; %returns normalized M; % (lambda n; %if n<0 then n+current!-modulus else n) % if atom m then remainder(m,current!-modulus) % else begin scalar x; % x := dcombine(m,current!-modulus,'divide); % return cdr x % end; endmodule; module facform; % Factored form representation for standard form polys. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*gcd dmode!*); global '(!*factor); comment In this module, we consider the manipulation of factored forms. These have the structure <monomial> . <form-power-list> where the monomial is itself a standard form (satisfying the KERNLP test) and a form-power is a dotted pair whose car is a standard form and cdr an integer>0. We have thus represented the form as a product of a monomial and powers of non-monomial factors; symbolic smacro procedure facmerge(u,v); %Returns the merge of the form_power_lists U and V; append(u,v); symbolic procedure fctrf u; %U is a standard form. Value is a standard factored form; %The function FACTORF is an assumed entry point to a more complete %factorization module which itself returns a form power list; begin scalar mv,x,y,!*gcd; !*gcd := t; if domainp u then return list u else if !*factor then return if dmode!* and (x := get(dmode!*,'factorfn)) then apply1(x,u) else factorf u; mv := mvar u; x := comfac u; u := quotf(u,comfac!-to!-poly x); y := fctrf cdr x; % factor the content. if car x then y := multpf(car x,car y) . cdr y; % merge monomials if domainp u then return multf(u,car y) . cdr y else if not(mvar u eq mv) then return car y . facmerge(fctrf1 u,cdr y) else if minusf u then <<u := negf u; y := negf car y . cdr y>>; return car y . facmerge(factor!-prim!-f u,cdr y); end; symbolic procedure fctrf1 u; 1 . factor!-prim!-f u; symbolic procedure factor!-prim!-f u; %U is a non-trivial form which is primitive in all its variables %and has a positive leading numerical coefficient. Result is a %form power list. (for each x in v conc factor!-prim!-sqfree!-f(car x,cdr x)) where v = sqfrf u; symbolic procedure factor!-prim!-sqfree!-f(u,n); for each x in prsqfrfacf u collect (x . n); symbolic procedure sqfrf u; %U is a non-trivial form which is primitive in all its variables %and has a positive leading numerical coefficient. %SQFRF performs square free factorization on U and returns a %form power list; begin integer k,n; scalar !*gcd,v,w,x,y,z; n := 1; x := mvar u; !*gcd := t; a: v := gcdf(u,diff(u,x)); k := degr(v,x); if k>0 then <<u := quotf(u,v); if flagp(dmode!*,'field) and ((y := lnc u) neq 1) then <<u := multd(!:recip y,u); v := multd(y,v)>>>>; if w then <<if u neq w then z := facmerge(list(quotf(w,u) . n),z); n := n+1>>; if k=0 then return facmerge(list(u . n),z); w := u; u := v; go to a end; symbolic procedure diff(u,v); %a polynomial differentation routine which does not check %indeterminate dependences; if domainp u then nil else addf(addf(multpf(lpow u,diff(lc u,v)), multf(lc u,diffp1(lpow u,v))), diff(red u,v)); symbolic procedure diffp1(u,v); if not car u eq v then nil else if cdr u=1 then 1 else multd(cdr u,!*p2f(car u .** (cdr u-1))); endmodule; module primfac; % Primitive square free polynomial factorization. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(dmode!* kernlist!*); symbolic procedure prsqfrfacf u; %U is a non-trivial form which is primitive in all its variables, %is square free, and has a positive leading numerical coefficient. % Result is a list of factors of u. % We order kernels in increasing powers unless kernlist!* has a % non-NIL value in which case we use that order (needed by SOLVE). % NOTE: For the time being, we bypass this code if the coefficient % domain is other than integer. begin scalar b,bool,v,w; if dmode!* then return list u; v := if kernlist!* then kernlist!* else reverse kernord!-sort powers u; % order highest power first. if cdr v then <<w := setkorder v; b := t; u := reorder u; if minusf u then <<bool := t; u := negf u>>>>; u := factor!-ordered!-sqfree!-prim!-f u; if b then <<setkorder w; u := for each x in u collect begin v := reorder x; if bool and minusf v then <<v := negf v; bool := nil>>; return v end>>; if bool then errach list("factor confusion",u); return u end; symbolic procedure factor!-ordered!-sqfree!-prim!-f pol; % U is a non-trivial form which is primitive in all its variables, % is square free, has a positive leading numerical coefficient, % and has a main variable of lowest degree in the form. % Result is a form power list. begin integer n; scalar q,res,w; if ldeg pol = 1 then return list factor!-coeffs pol else if univariatep pol then <<while car(q := linfacf pol) do <<res := car q . res; pol := cdr q>>; while car(q := quadfacf pol) do <<res := car q . res; pol := cdr q>>>>; if null pol then return res else if length(w := special!-case!-factor pol)>1 then return nconc!*(res, for each x in w conc factor!-ordered!-sqfree!-prim!-f x) else if ldeg pol < 4 or (n := degreegcd pol) = 1 then return pol . res; w := cdr sort(dfactors n,function lessp); % 1 is always first factor. a: if null w then return pol . res else if length (q := factor!-ordered!-sqfree!-prim!-f downpower(pol,car w))>1 then return nconc!*(res,for each x in q conc factor!-ordered!-sqfree!-prim!-f uppower(x,car w)); w := cdr w; go to a end; symbolic procedure downpower(pol,n); % Reduce the power of each term in pol wrt main variable by factor %n. downpower1(pol,mvar pol,n); symbolic procedure downpower1(pol,mv,n); if domainp pol or not(mvar pol eq mv) then pol else (mv .** (ldeg pol/n)) .* lc pol .+ downpower1(red pol,mv,n); symbolic procedure uppower(pol,n); % Raise the power of each term in pol wrt main variable by factor %n. uppower1(pol,mvar pol,n); symbolic procedure uppower1(pol,mv,n); if domainp pol or not(mvar pol eq mv) then pol else (mv .** (ldeg pol*n)) .* lc pol .+ downpower1(red pol,mv,n); symbolic procedure univariatep pol; % True if pol is not a domain element and is univariate with respect % to its main variable. not domainp pol and univariatep1(pol,mvar pol); symbolic procedure univariatep1(pol,mv); domainp pol or mvar pol eq mv and domainp lc pol and univariatep1(red pol,mv); symbolic procedure special!-case!-factor pol; (if degree = 2 then quadraticf pol else if degree= 3 then cubicf pol else if degree = 4 then quarticf pol else list pol) where degree = ldeg pol; symbolic procedure degreegcd pol; % Returns gcd of degrees of pol with respect to main variable. begin integer n; scalar mv; mv := mvar pol; n := ldeg pol; while n>1 and not domainp(pol := red pol) and mvar pol eq mv do n := gcdn(n,ldeg pol); return n end; symbolic procedure factor!-coeffs u; % factor the primitive, square free polynomial U wrt main variable. % dummy for now. u; endmodule; module specfac; % splitting of low degree polynomials. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. exports cubicf,quadraticf,quarticf; symbolic procedure coeffs pol; % extract coefficients of polynomial wrt its main variable and leading % degree. Result is a list of coefficients. begin integer degree,deg1; scalar cofs,mv; mv := mvar pol; degree := ldeg pol; while not domainp pol and mvar pol eq mv do <<deg1 := ldeg pol; for i:= 1:(degree-deg1-1) do cofs := 0 . cofs; cofs := lc pol . cofs; pol := red pol; degree := deg1>>; for i:=1:degree-1 do cofs := 0 . cofs; if null pol then pol := 0; return reversip(pol . cofs) end; symbolic procedure shift!-pol pol; % Shifts main variable, mv, of square free nth degree polynomial pol so % that coefficient of mv**(n-1) is zero. % Does not assume pol is univariate. begin scalar lc1,ld,mv,pol1,redp,shift,x; mv := mvar pol; ld := ldeg pol; redp := red pol; if domainp redp or not(mvar redp eq mv) or ldeg redp<(ld-1) then return list(pol,1,nil ./ 1); lc1 := lc pol; x := lc redp; shift := quotsq(!*f2q x,!*f2q multd(ld,lc1)); pol1 := subf1(pol,list(mv . mk!*sq addsq(!*k2q mv,negsq shift))); return list(numr pol1,denr pol1,shift) end; symbolic procedure quadraticf pol; % Finds factors of square free quadratic polynomial pol (if they exist). % Does not assume pol is univariate. % quadraticf2(car w,cadr w,caddr w,mvar pol) where w = coeffs pol; (if x eq 'failed then list pol else list(y .* car x .+ cadr x,y .* caddr x .+ cadddr x) where y = (mvar pol .** 1)) where x = quadraticf1(car w,cadr w,caddr w) where w = coeffs pol; symbolic procedure quadraticf1(a,b,c); begin scalar a1,denom,discrim,w; if b=0 then b := nil; discrim := addf(exptf(b,2),multd(-4,multf(a,c))); if null discrim then errach "discrim=0 in quadratic" else if minusf discrim then return 'failed; discrim:=rootxf(discrim,2); if discrim='failed then return discrim; denom := multd(4,a); a := multd(2,a); w := addf(b,discrim); c := addf(b,negf discrim); b := w; if (w := gcdf(a,b)) neq 1 then <<a1 := quotf(a,w); b := quotf(b,w); denom := quotf(denom,w)>>; if (w := gcdf(a,denom)) neq 1 and (w := gcdf(c,denom)) then <<a := quotf(a,w); c := quotf(c,w); denom := quotf(denom,w)>>; if denom neq 1 then errach "denominator not 1 in quadratic"; return list(a1,b,a,c) end; symbolic procedure rootxf(u,n); % find polynomial nth root of u or return "failed". begin scalar x,y,z; if domainp u then return if fixp u and (y := irootn(u,n))**n=u then y else 'failed; x := comfac u; u := quotf(u,comfac!-to!-poly x); z := 1; if car x then if cdr(y := divide(cdar x,n)) = 0 then z := multpf(caar x .** car y,z) else return 'failed; x := cdr x; if domainp x then if fixp x and (y := irootn(x,n))**n=x then z := multd(y,z) else return 'failed else if (y := rootxf(x,n)) eq 'failed then return y else z := multf(y,z); if u=1 then return z; x := sqfrf u; c: if null x then return z else if cdr(y := divide(cdar x,n)) = 0 then <<z := multf(exptf(caar x,car y),z); x := cdr x>> else return 'failed; go to c end; symbolic procedure cubicf pol; % split the cubic pol if a change of origin puts it in the form % (x-a)**3-b=0. begin scalar a,a0,b,neg,pol1; pol1 := shift!-pol pol; a := coeffs car pol1; % if cadr a neq 0 then rederr list(pol,"not correctly shifted") % cadr a neq 0 probably means there are some surds in the % coefficients that don't reduce to 0. if cadr a neq 0 then return list pol else if caddr a neq 0 then return list pol; % factorization not possible by this method a0 := cadddr a; a := car a; if minusf a0 then <<neg := t; a0 := negf a0>>; if (a := rootxf(a,3)) eq 'failed or (a0 := rootxf(a0,3)) eq 'failed then return list pol; if neg then a0 := negf a0; %now numr (a*(mv+shift)+a0) is a factor of pol; a := numr addsq(multsq(!*f2q a,addsq(!*k2q mvar pol,caddr pol1)), !*f2q a0); if null(b := quotf(pol,a)) then errach list(pol,"doesn't factor properly"); return a . quadraticf b end; symbolic procedure quarticf pol; %splits quartics that can be written in the form (x-a)**4+b*(x-a)**2+c. begin scalar a,a2,a0,b,pol1,x; pol1 := shift!-pol pol; a := coeffs car pol1; if cadr a neq 0 then rederr list(pol,"not correctly shifted") else if cadddr a neq 0 then return list pol; % factorization not possible by this method a2 := cddr a; a0 := caddr a2; a2 := car a2; a := car a; x := quadraticf1(a,a2,a0); if x eq 'failed then return list pol; a := exptsq(addsq(!*k2q mvar pol,caddr pol1),2); % (x+shift)**2 b := numr quotsq(addsq(multsq(!*f2q car x,a),!*f2q cadr x), !*f2q cadr pol1); % should be one factor; a := quotf(pol,b); if null a then errach list(pol,"doesn't factor properly"); return append(quadraticf a,quadraticf b) end; endmodule; module kronf; % Kronecker factorization of univariate forms. % Author: Anthony C. Hearn. % Based on code first written by Mary Ann Moore and Arthur C. Norman. % Copyright (c) 1987 The RAND Corporation. All rights reserved. exports linfacf,quadfacf; imports zfactor; % Note that only linear and quadratic factors are found here. symbolic procedure linfacf u; trykrf(u,'(0 1)); symbolic procedure quadfacf u; trykrf(u,'(-1 0 1)); symbolic procedure trykrf(u,points); % Look for factor of u by evaluation at points and interpolation. % Return (fac . cofac), with fac = nil if none found, % and cofac = nil if nothing worthwhile is left. begin scalar attempt,mv,values; if null u then return nil . nil else if length points > ldeg u then return u . nil; mv := mvar u; values := for each j in points collect subuf(j,u); if 0 member values then <<attempt := ((mv .** 1) .* 1) . -1; % mv - 1 return attempt . quotf(u,attempt)>>; values := for each j in values collect dfactors j; values := for each j in values collect append(j,for each k in j collect !:minus k); attempt := search4facf(u,values,nil); if null attempt then attempt := nil . u; return attempt end; symbolic procedure subuf(u,v); % Substitute integer u for main variable in univariate polynomial v. % Return an integer or a structured domain element. begin scalar z; if u=0 then u := nil; z := nil; while v do if domainp v then <<z := adddm!*(v,z); v := nil>> else <<if u then z := adddm!*(multdm!*(u**ldeg v,lc v),z); % we should do better here. v := red v>>; return if null z then 0 else z end; symbolic procedure adddm!*(u,v); % Adds two domain elements u and v, returning a standard form. if null u then v else if null v then u else adddm(u,v); symbolic procedure multdm!*(u,v); % Multiplies two domain elements u and v, returning a standard form. if null u or null v then nil else multdm(u,v); symbolic procedure dfactors n; % produces a list of all (positive) factors of the domain element n. begin scalar x; if n=0 then return list 0 else if !:minusp n then n := !:minus n; return if not atom n then if (x := get(car n,'factorfn)) then combinationtimes apply1(x,n) else list n else combinationtimes zfactor n end; symbolic procedure combinationtimes fl; if null fl then list 1 else begin scalar n,c,res,pr; n := caar fl; c := cdar fl; pr := combinationtimes cdr fl; while c>=0 do <<res := putin(expt(n,c),pr,res); c := c-1>>; return res end; symbolic procedure putin(n,l,w); if null l then w else putin(n,cdr l,(n*car l) . w); symbolic procedure search4facf(u,values,cv); % combinatorial search for factors. cv gets current value set. if null values then tryfactorf(u,cv) else begin scalar q,w; w := car values; loop: if null w then return nil; % no factor found q := search4facf(u,cdr values,car w . cv); if null q then <<w := cdr w; go to loop>>; return q end; symbolic procedure tryfactorf(u,cv); % Tests if cv represents a factor of u. % For the time being, does not work on structured domain elements. begin scalar w; if null atomlis cv then return nil; if null cddr cv then w := linethroughf(cadr cv,car cv,mvar u) else w := quadthroughf(caddr cv,cadr cv,car cv,mvar u); if w eq 'failed or null (u := quotf(u,w)) then return nil else return w . u end; symbolic procedure linethroughf(y0,y1,mv); begin scalar x; x := y1-y0; if x=0 then return 'failed else if x<0 then <<x:= -x; y0 := -y0>>; return if y0 = 0 or gcdn(x,y0) neq 1 then 'failed else (mv .** 1) .* x .+ y0 end; symbolic procedure quadthroughf(ym1,y0,y1,mv); begin scalar x,y,z; x := divide(ym1+y1,2); if cdr x=0 then x := car x-y0 else return 'failed; if x=0 then return 'failed; z := y0; y := divide(y1-ym1,2); if cdr y=0 then y := car y else return 'failed; if gcdn(x,gcdn(y,z)) neq 1 then return 'failed; if x<0 then <<x := -x; y := -y; z := -z>>; if z=0 then return 'failed else if y=0 then return ((mv .** 2) .* x) .+ z else return ((mv .** 2) .* x) .+ (((mv .** 1) .* y) .+ z) end; endmodule; module conj; % Rationalize denoms of standard quotients by conjugate % computation. % Author: Anthony C. Hearn. % Modifications by: Eberhard Schruefer. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*rationalize dmode!* kord!*); put('rationalize,'simpfg,'((t (rmsubs)) (nil (rmsubs)))); symbolic smacro procedure subtrf(u,v); % Returns u - v for standard forms u and v. addf(u,negf v); symbolic procedure rationalizesq u; % Rationalize the standard quotient u. begin scalar x; if x := get(dmode!*,'rationalizefn) then u := subs2 apply1(x,u); % We need the subs2 to get rid of surd powers. return if domainp denr u then u else if (x := rationalizef denr u) neq 1 then rationalizesq subs2q(multf(numr u,x) ./ multf(denr u,x)) else u end; symbolic procedure rationalizef u; % Look for I and sqrts, cbrts, quartics at present. begin scalar x,y; x := kernels u; a: if null x then return 1; y := car x; if y eq 'i or eqcar(y,'expt) and caddr y = '(quotient 1 2) then return conjquadratic(mkmain(u,y),y) else if eqcar(y,'expt) and caddr y = '(quotient 1 3) then return conjcubic(mkmain(u,y),y) else if eqcar(y,'expt) and caddr y = '(quotient 1 4) then return conjquartic(mkmain(u,y),y); x := cdr x; go to a end; symbolic procedure conjquadratic(u,v); if ldeg u = 1 then subtrf(multf(!*k2f v,reorder lc u),reorder red u) else errach list(ldeg u,"invalid power in rationalizef"); symbolic procedure conjcubic(u,v); begin scalar c1,c2,c3; if ldeg u = 2 then <<c1 := reorder lc u; if degr(red u,v) = 1 then <<c2 := reorder lc red u; c3 := reorder red red u>> else c3 := reorder red u>> else <<c2 := reorder lc u; c3 := reorder red u>>; return addf(multf(exptf(!*k2f v,2), subtrf(exptf(c2,2),multf(c1,c3))), addf(multf(!*k2f v,subtrf(multf(!*q2f simp cadr v, exptf(c1,2)), multf(c2,c3))), subtrf(exptf(c3,2),multf(!*q2f simp cadr v, multf(c1,c2))))) end; symbolic procedure conjquartic(u,v); begin scalar c1,c3,c4,q1,q2,q3,q4; if ldeg u = 3 then <<c1 := reorder lc u; if degr(red u,v) = 1 then <<c3 := reorder lc red u; c4 := reorder red red u>> else c4 := reorder red u>> else if ldeg u = 1 then <<c3 := reorder lc u; c4 := reorder red u>>; q1 := subtrf(addf(exptf(c3,3),multf(c1,exptf(c4,2))), multf(!*q2f simp cadr v,multf(c3,exptf(c1,2)))); q2 := negf addf(multf(!*q2f simp cadr v,multf(c4,exptf(c1,2))), multf(exptf(c3,2),c4)); q3 := addf(multf(c3,exptf(c4,2)), subtrf(multf(exptf(!*q2f simp cadr v,2),exptf(c1,3)), multf(!*q2f simp cadr v,multf(c1,exptf(c3,2))))); q4 := subtrf(multf(!*q2f simp cadr v, multf(multd(2,c1),multf(c3,c4))), exptf(c4,3)); return addf(multf(exptf(!*k2f v,3),q1), addf(multf(exptf(!*k2f v,2),q2), addf(multf(!*k2f v,q3),q4))) end; symbolic procedure mkmain(u,var); % Make kernel var the main variable of u. begin scalar kord!*; kord!* := list var; return reorder u end; endmodule; module diff; % Differentiation package. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(frlis!* mcond!* powlis!* subfg!* wtl!*); % Contains a reference to RPLACD (a table update), commented out. symbolic procedure simpdf u; %U is a list of forms, the first an expression and the remainder %kernels and numbers. %Value is derivative of first form wrt rest of list; begin scalar v,x,y; if null subfg!* then return mksq('df . u,1); v := cdr u; u := simp!* car u; a: if null v or null numr u then return u; x := if null y or y=0 then simp!* car v else y; if null kernp x then typerr(prepsq x,"kernel"); x := caaaar x; v := cdr v; if null v then go to c; y := simp!* car v; if null numr y then <<v := cdr v; y := nil; go to a>> else if not denr y=1 or not numberp numr y then go to c; v := cdr v; b: for i:=1:car y do u := diffsq(u,x); y := nil; go to a; c: u := diffsq(u,x); go to a end; put('df,'simpfn,'simpdf); symbolic procedure diffsq(u,v); %U is a standard quotient, V a kernel. %Value is the standard quotient derivative of U wrt V. %Algorithm: df(x/y,z)= (x'-(x/y)*y')/y; multsq(addsq(difff(numr u,v),negsq multsq(u,difff(denr u,v))), 1 ./ denr u); symbolic procedure difff(u,v); %U is a standard form, V a kernel. %Value is the standard quotient derivative of U wrt V; if domainp u then nil ./ 1 else addsq(addsq(multpq(lpow u,difff(lc u,v)), multsq(diffp(lpow u,v),lc u ./ 1)), difff(red u,v)); symbolic procedure diffp(u,v); %U is a standard power, V a kernel. %Value is the standard quotient derivative of U wrt V; begin scalar n,w,x,y,z; integer m; n := cdr u; %integer power; u := car u; %main variable; if u eq v and (w := 1 ./ 1) then go to e else if atom u then go to f %else if (x := assoc(u,dsubl!*)) and (x := atsoc(v,cdr x)) % and (w := cdr x) then go to e %deriv known; %DSUBL!* not used for now; else if (not atom car u and (w:= difff(u,v))) or (car u eq '!*sq and (w:= diffsq(cadr u,v))) then go to c %extended kernel found; else if (x:= get!*(car u,'dfn)) then nil else if car u eq 'plus and (w:=diffsq(simp u,v)) then go to c else go to h; %unknown derivative; y := x; z := cdr u; a: w := diffsq(simp car z,v) . w; if caar w and null car y then go to h; %unknown deriv; y := cdr y; z := cdr z; if z and y then go to a else if z or y then go to h; %arguments do not match; y := reverse w; z := cdr u; w := nil ./ 1; b: %computation of kernel derivative; if caar y then w := addsq(multsq(car y,simp subla(pair(caar x,z), cdar x)), w); x := cdr x; y := cdr y; if y then go to b; c: %save calculated deriv in case it is used again; %if x := atsoc(u,dsubl!*) then go to d %else x := u . nil; %dsubl!* := x . dsubl!*; d: %rplacd(x,xadd(v . w,cdr x,t)); e: %allowance for power; %first check to see if kernel has weight; if (x := atsoc(u,wtl!*)) then w := multpq('k!* .** (-cdr x),w); m := n-1; return if n=1 then w else if flagp(dmode!*,'convert) and null(n := int!-equiv!-chk apply1(get(dmode!*,'i2d),n)) then nil ./ 1 else multsq(!*t2q((u .** m) .* n),w); f: %check for possible unused substitution rule; if not depends(u,v) and (not (x:= atsoc(u,powlis!*)) or not car diffsq(simp cadddr x,v)) then return nil ./ 1; w := list('df,u,v); go to j; h: %final check for possible kernel deriv; if car u eq 'df then if depends(cadr u,v) then if assoc(w := list('df,cadr u,v), get('df,'kvalue)) then <<w := mksq(w,1); x := cddr u; while x do <<if cdr x and numberp cadr x then <<for i := 1:cadr x do w := diffsq(w,car x); x := cdr x>> else w := diffsq(w,car x); x := cdr x>>; go to e>> else w := 'df . cadr u . derad(v,cddr u) else return nil ./ 1 else if depends(u,v) then w := list('df,u,v) else return nil ./ 1; j: w := if x := opmtch w then simp x else mksq(w,1); go to e end; symbolic procedure derad(u,v); if null v then list u else if numberp car v then car v . derad(u,cdr v) else if u=car v then if cdr v and numberp cadr v then u . (cadr v + 1) . cddr v else u . 2 . cdr v else if ordp(u,car v) then u . v else car v . derad(u,cdr v); symbolic procedure letdf(u,v,w,x,b); begin scalar y,z; if atom cadr x then go to b else if not idp caadr x then typerr(caadr x,"operator") else if not get(caadr x,'simpfn) then <<redmsg(caadr x,"operator"); mkop caadr x>>; rmsubs(); if not mcond!* eq 't or not frlp cdadr x or null cddr x or cdddr x or not frlp cddr x or not idlistp cdadr x or repeats cdadr x or not caddr x member cdadr x then go to b; z := lpos(caddr x,cdadr x); if not get(caadr x,'dfn) then put(caadr x, 'dfn, nlist(nil,length cdadr x)); w := get(caadr x,'dfn); if length w neq length cdadr x then rederr list("Incompatible DF rule argument length for", caadr x); a: if null w or z=0 then return errpri1 u else if z neq 1 then <<y := car w . y; w := cdr w; z := z-1; go to a>> else if null b then y := append(reverse y,nil . cdr w) else y := append(reverse y,(cdadr x . v) . cdr w); return put(caadr x,'dfn,y); b: %check for dependency; if caddr x memq frlis!* then return nil else if idp cadr x and not(cadr x memq frlis!*) then depend1(cadr x,caddr x,t) else if not atom cadr x and idp caadr x and frlp cdadr x then depend1(caadr x,caddr x,t); return nil end; symbolic procedure frlp u; null u or (car u memq frlis!* and frlp cdr u); symbolic procedure lpos(u,v); if u eq car v then 1 else lpos(u,cdr v)+1; endmodule; module subs2q; % Routines for substituting for powers. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mcd !*structure !*sub2 alglist!* dmode!*); global '(!*resubs frlis!* powlis!* powlis1!* simpcount!* simplimit!*); comment If STRUCTURE is ON, then expressions like (a**(b/2))**2 are not simplified, to allow some attempt at a structure theorem use, especially in the integrator; symbolic procedure subs2q u; % Perform power substitutions on u. Check whether substitions % on numerator and denominator change these before doing % quotient (to avoid undoing rationalization of denominator). ((if denr x=1 and denr y=1 and numr x=v and numr y=w then u else quotsq(x,y)) where x=subs2f v, y=subs2f w) where v=numr u, w=denr u; symbolic procedure subs2f u; begin scalar x; if simpcount!*>simplimit!* then <<simpcount!* := 0; rederr "Simplification recursion too deep">>; simpcount!* := simpcount!*+1; !*sub2 := nil; x := subs2f1 u; if (!*sub2 or powlis1!*) and !*resubs then if numr x=u and denr x=1 then !*sub2 := nil else x := subs2q x; simpcount!* := simpcount!*-1; return x end; symbolic procedure subs2f1 u; if domainp u then !*d2q u else begin scalar kern,v,w,x,y,z; kern := mvar u; z := nil ./ 1; a: if null u or degr(u,kern)=0 then go to a1; y := lt u .+ y; u := red u; go to a; a1: x := powlis!*; a2: if null x then go to b else if caaar y = caar x then <<w := subs2p(caar y,cadar x,cadddr car x); go to e1>> % else if eqcar(kern,'sqrt) and cadr kern = caar x % then <<w := raddsq(subs2p(cadr kern . cdaar y, % cadar x,cadddr car x),2);% go to e1>>; else if eqcar(kern,'expt) and cadr kern = caar x and eqcar(caddr kern,'quotient) and cadr caddr kern = 1 and numberp caddr caddr kern then <<v := divide(cdaar y,caddr caddr kern); % if car v neq 0 then w := mksq(cadr kern,car v) % Use simp/exptsq to make sure I converted in complex mode. if car v neq 0 then w := exptsq(simp cadr kern,car v) else w := 1 ./ 1; if cdr v neq 0 then <<begin scalar alglist!*,dmode!*; % We must do exponent arithmetic in integer % mode. v := cancel(cdr v.caddr caddr kern) end; w := multsq(raddsq(subs2p(cadr kern . car v, cadar x,cadddr car x), cdr v),w)>>; go to e1>>; x := cdr x; go to a2; b: x := powlis1!*; l2: if null x then go to l3 else if w:= mtchp(caar y,caar x,caddar x,caadar x,cdadar x) then go to e1; x := cdr x; go to l2; l3: if eqcar(kern,'expt) and not !*structure then go to l1; z := addsq(multpq(caar y,subs2f1 cdar y),z); c: y := cdr y; if y then go to a1; d: return addsq(z,subs2f1 u); e1: z := addsq(multsq(w,subs2f1 cdar y),z); go to c; l1: if cdaar y=1 and not eqcar(cadr kern,'expt) % ONEP then w := mksq(kern,1) else w := simpexpt list(cadr kern, list('times,caddr kern,cdaar y)); z := addsq(multsq(w,subs2f1 cdar y),z); y := cdr y; if y then go to l1 else go to d; end; symbolic procedure subs2p(u,v,w); %U is a power, V an integer, and W an algebraic expression, such %that CAR U**V=W. Value is standard quotient for U with this %substitution; begin v := divide(cdr u,v); if car v=0 then return !*p2q u; w := exptsq(simp w,car v); return if cdr v=0 then w else multpq(car u .** cdr v,w) end; symbolic procedure raddsq(u,n); %U is a standard quotient, N and integer. Value is sq for U**(1/N); simpexpt list(mk!*sq u,list('quotient,1,n)); symbolic procedure mtchp(u,v,w,flg,bool); %U is a standard power, V a power to be matched against. %W is the replacement expression. %FLG is a flag which is T if an exact power match required. %BOOL is a boolean expression to be satisfied for substitution. %Value is the substitution standard quotient if a match found, %NIL otherwise; begin scalar x; x := mtchp1(u,v,flg,bool); a: if null x then return nil else if eval subla(car x,bool) then go to b; x := cdr x; go to a; b: v := divide(cdr u,subla(car x,cdr v)); w := exptsq(simp subla(car x,w),car v); if cdr v neq 0 then w := multpq(car u .** cdr v,w); return w end; symbolic procedure mtchp1(u,v,flg,bool); %U is a standard power, V a power to be matched against. %FLG is a flag which is T if an exact power match required. %BOOL is a boolean expression to be satisfied for substitution. %Value is a list of possible free variable pairings which %match conditions; begin scalar x; if u=v then return list nil else if not (x:= mchk!*(car u,car v)) then return nil else if cdr v memq frlis!* then if cdr u=1 then return nil % do not match a free power to 1 else return mapcons(x,cdr v . cdr u) else if (flg and not cdr u=cdr v) or (if !*mcd then cdr u<cdr v else (cdr u*cdr v)<0 or %implements explicit sign matching; abs cdr u<abs cdr v) then return nil else return x end; symbolic procedure mchk!*(u,v); begin scalar x; if x := mchk(u,v) then return x else if !*mcd or not (sfp u and sfp v) then return nil else return mchk(prepf u,prepf v) end; endmodule; module subs3q; % Routines for matching products. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mcd !*sub2); global '(!*match !*resubs mchfg!* powlis1!*); symbolic procedure subs3q u; %U is a standard quotient. %Value is a standard quotient with all product substitutions made; begin scalar x; x := mchfg!*; %save value in case we are in inner loop; mchfg!* := nil; u := quotsq(subs3f numr u,subs3f denr u); mchfg!* := x; return u end; symbolic procedure subs3f u; %U is a standard form. %Value is a standard quotient with all product substitutions made; subs3f1(u,!*match,t); symbolic procedure subs3f1(u,l,bool); %U is a standard form. %L is a list of possible matches. %BOOL is a boolean variable which is true if we are at top level. %Value is a standard quotient with all product substitutions made; begin scalar x,z; z := nil ./ 1; a: if null u then return z else if domainp u then return addsq(z,u ./ 1) else if bool and domainp lc u then go to c; x := subs3t(lt u,l); if not bool %not top level; or not mchfg!* then go to b; %no replacement made; mchfg!* := nil; if numr x = u and denr x = 1 then <<x := u ./ 1; go to b>> % also shows no replacement made (sometimes true with non % commuting expressions) else if null !*resubs then go to b else if !*sub2 or powlis1!* then x := subs2q x; %make another pass; x := subs3q x; b: z := addsq(z,x); u := cdr u; go to a; c: x := list lt u ./ 1; go to b end; symbolic procedure subs3t(u,v); % U is a standard term, V a list of matching templates. % Value is a standard quotient for the substituted term. begin scalar bool,w,x,y,z; x := mtchk(car u,if domainp cdr u then sizchk(v,1) else v); if null x then go to a %lpow doesn't match; else if null caar x then go to b; %complete match found; y := subs3f1(cdr u,x,nil); %check tc for match; if mchfg!* then return multpq(car u,y); a: return list u . 1; %no match; b: x := cddar x; %list(<subst value>,<denoms>); z := caadr x; %leading denom; mchfg!* := nil; %initialize for tc check; y := subs3f1(cdr u,!*match,nil); mchfg!* := t; if car z neq caar u then go to e else if z neq car u %powers don't match; then y := multpq(caar u .** (cdar u-cdr z),y); b1: y := multsq(simpcar x,y); x := cdadr x; if null x then return y; z := 1; %unwind remaining denoms; c: if null x then go to d; w:= if atom caar x or sfp caar x then caar x else revop1 caar x; % In the non-commutative case we have to be very careful about % order of terms in a product. Introducing negative powers % solves this problem. if noncomp w or not !*mcd then bool := t; z := list(mksp(w,if null bool then cdar x else -cdar x) . z); % kernel CAAR X is not unique here. Earlier versions used just % CAAR X, but this leads to sums of terms in the wrong order. % The code here is probably still not correct in all cases, and % may lead to unbounded calculations. Maybe SIMP should be used % instead of REVOP1, with appropriate adjustments in the code % to construct Z. x := cdr x; go to c; d: return if not bool then car y . multf(z,cdr y) else multf(z,car y) . cdr y; e: if simp car z neq simp caar u then errach list('subs3t,u,x,z); %maybe arguments were in different order, otherwise it's fatal; if cdr z neq cdar u then y:= multpq(caar u .** (cdar u-cdr z),y); go to b1 end; symbolic procedure sizchk(u,n); if null u then nil else if length caar u>n then sizchk(cdr u,n) else car u . sizchk(cdr u,n); symbolic procedure mtchk(u,v); %U is a standard power, V a list of matching templates. %If a match is made, value is of the form: %list list(NIL,<boolean form>,<subst value>,<denoms>), %otherwise value is an updated list of templates; begin scalar flg,v1,w,x,y,z; flg := noncomp car u; a0: if null v then return z; v1 := car v; w := car v1; a: if null w then go to d; x := mtchp1(u,car w,caadr v1,cdadr v1); b: if null x then go to c else if car (y := subla(car x,delete(car w,car v1)) . list(subla(car x,cadr v1), subla(car x,caddr v1), subla(car x,car w) . cadddr v1)) then z := y . z else if eval subla(car x,cdadr v1) then return list y; x := cdr x; go to b; c: if null flg then <<w := cdr w; go to a>> else if cadddr v1 and nocp w then go to e; d: z := append(z,list v1); e: v := cdr v; go to a0 end; symbolic procedure nocp u; null u or (noncomp caar u and nocp cdr u); endmodule; module extout; % Extended output package for expressions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mcd kord!*); global '(!*allfac !*div !*pri !*rat dnl!* factors!* ordl!* upl!* wtl!*); switch allfac,div,pri,rat; !*allfac := t; %factoring option for this package; !*pri := t; %to activate this package; % dnl!* := nil; %output control flag: puts powers in denom; % factors!* := nil; %list of output factors; % ordl!* := nil; %list of kernels introduced by ORDER statement; % upl!* := nil; %output control flag: puts denom powers in %numerator; % !*div := nil; %division option in this package; % !*rat := nil; %flag indicating rational mode for output; symbolic procedure factor u; factor1(u,t,'factors!*); symbolic procedure factor1(u,v,w); begin scalar x,y; y := eval w; for each j in u do <<x := !*a2k j; if v then y := aconc!*(delete(x,y),x) else if not x member y then msgpri(nil,j,"not found",nil,nil) else y := delete(x,y)>>; set(w,y) end; symbolic procedure remfac u; factor1(u,nil,'factors!*); rlistat '(factor remfac); symbolic procedure order u; <<rmsubs(); % Since order of terms in an operator argument can % affect simplification. if u and null car u and null cdr u then (ordl!* := nil) else for each x in u do <<if (x := !*a2k x) member ordl!* then ordl!* := delete(x,ordl!*); ordl!* := aconc!*(ordl!*,x)>>>>; rlistat '(order); symbolic procedure up u; factor1(u,t,'upl!*); symbolic procedure down u; factor1(u,t,'dnl!*); % RLISTAT '(UP DOWN); % omitted since not documented; symbolic procedure formop u; if domainp u then u else raddf(multop(lpow u,formop lc u),formop red u); symbolic procedure multop(u,v); if null kord!* then multpf(u,v) else if car u eq 'k!* then v else rmultpf(u,v); symbolic smacro procedure lcx u; %returns leading coefficient of a form with zero reductum, or an %error otherwise; cdr carx(u,'lcx); symbolic procedure quotof(p,q); %P is a standard form, Q a standard form which is either a domain %element or has zero reductum. %returns the quotient of P and Q for output purposes; if null p then nil else if p=q then 1 else if q=1 then p else if domainp q then quotofd(p,q) else if domainp p then mksp(mvar q,-ldeg q) .* quotof(p,lcx q) .+ nil else (lambda (x,y); if car x eq car y then (lambda (n,w,z); if n=0 then raddf(w,z) else ((car y .** n) .* w) .+ z) (cdr x-cdr y,quotof(lc p,lcx q),quotof(red p,q)) else if ordop(car x,car y) then (x .* quotof(lc p,q)) .+ quotof(red p,q) else mksp(car y,- cdr y) .* quotof(p,lcx q) .+ nil) (lpow p,lpow q); symbolic procedure quotofd(p,q); %P is a form, Q a domain element. Value is quotient of P and Q %for output purposes; if null p then nil else if domainp p then quotodd(p,q) else (lpow p .* quotofd(lc p,q)) .+ quotofd(red p,q); symbolic procedure quotodd(p,q); %P and Q are domain elements. Value is domain element for P/Q; if atom p and atom q then mkrn(p,q) else lowest!-terms(p,q); symbolic procedure lowest!-terms(u,v); %reduces compatible domain elements U and V to a ratio in lowest %terms. Value as a rational may contain domain arguments rather than %just integers; if u=v then 1 else if flagp(dmode!*,'field) or not atom u and flagp(car u,'field) or not atom v and flagp(car v,'field) then multdm(u,!:recip v) else begin scalar x; x := dcombine!*(u,v,'gcd); u := dcombine!*(u,x,'quotient); v := dcombine!*(v,x,'quotient); return if v=1 then u else '!:rn!: . (u . v) % :ONEP end; symbolic procedure dcombine!*(u,v,w); if atom u and atom v then apply2(w,u,v) else dcombine(u,v,w); symbolic procedure ckrn u; if flagp(dmode!*,'field) then begin scalar x; x := lnc u; return multf(x,ckrn1 quotfd(u,x)) end else ckrn1 u; symbolic procedure ckrn1 u; begin scalar x; if domainp u then return u; a: x := gck2(ckrn1 cdar u,x); if null cdr u then return if noncomp mvar u then x else list(caar u . x) else if domainp cdr u or not caaar u eq caaadr u then return gck2(ckrn1 cdr u,x); u := cdr u; go to a end; symbolic procedure gck2(u,v); %U and V are domain elements or forms with a zero reductum. %Value is the gcd of U and V; if null v then u else if u=v then u else if domainp u then if domainp v then if flagp(dmode!*,'field) then 1 else gcddd(u,v) else gck2(u,cdarx v) else if domainp v then gck2(cdarx u,v) else (lambda (x,y); if car x eq car y then list((if cdr x>cdr y then y else x) . gck2(cdarx u,cdarx v)) else if ordop(car x,car y) then gck2(cdarx u,v) else gck2(u,cdarx v)) (caar u,caar v); symbolic procedure cdarx u; cdr carx(u,'cdar); symbolic procedure prepsq!* u; begin scalar x; if null numr u then return 0 else if minusf numr u then return list('minus,prepsq!*(negf numr u ./ denr u)); x := kord!*; kord!* := append((for each j in factors!* join if not idp j then nil else for each k in get(j,'klist) collect car k), append(factors!*,ordl!*)); if kord!* neq x or wtl!* then u := formop numr u . formop denr u; u := if !*rat or (not flagp(dmode!*,'field) and !*div) or upl!* or dnl!* then replus prepsq!*1(numr u,denr u,nil) else sqform(u,function(lambda j; replus prepsq!*1(j,1,nil))); kord!* := x; return u end; symbolic procedure prepsq!*0(u,v); %U is a standard quotient, but not necessarily in lowest terms. %V a list of factored powers; %Value is equivalent list of prefix expressions (an implicit sum); begin scalar x; return if null numr u then nil else if (x := gcdf(numr u,denr u)) neq 1 then prepsq!*1(quotf(numr u,x),quotf(denr u,x),v) else prepsq!*1(numr u,denr u,v) end; symbolic procedure prepsq!*1(u,v,w); %U and V are the numerator and denominator expression resp, %in lowest terms. %W is a list of powers to be factored from U; begin scalar x,y,z; %look for "factors" in the numerator; if not domainp u and (mvar u member factors!* or (not atom mvar u and car mvar u member factors!*)) then return nconc!*( if v=1 then prepsq!*0(lc u ./ v,lpow u . w) else (begin scalar n,v1,z1; %see if the same "factor" appears in denominator; n := ldeg u; v1 := v; z1 := !*k2f mvar u; while (z := quotfm(v1,z1)) do <<v1 := z; n := n-1>>; return prepsq!*0(lc u ./ v1, if n>0 then (mvar u .** n) . w else if n<0 then mksp(list('expt,mvar u,n),1) . w else w) end), prepsq!*0(red u ./ v,w)); %now see if there are any remaining "factors" in denominator %(KORD!* contains all potential kernel factors); if not domainp v then for each j in kord!* do begin integer n; scalar z1; n := 0; z1 := !*k2f j; while z := quotfm(v,z1) do <<n := n-1; v := z>>; if n<0 then w := mksp(list('expt,j,n),1) . w end; %now all "factors" have been removed; if kernlp u then <<u := mkkl(w,u); w := nil>>; if dnl!* then <<x := if null !*allfac then 1 else ckrn u; z := ckrn!*(x,dnl!*); x := quotof(x,z); u := quotof(u,z); v := quotof(v,z)>>; y := ckrn v; if upl!* then <<z := ckrn!*(y,upl!*); y := quotof(y,z); u := quotof(u,z); v := quotof(v,z)>>; if null !*div then y := 1; u := canonsq (u . quotof(v,y)); % if !*gcd then u := cancel u; u := quotof(numr u,y) ./ denr u; if null !*allfac then x := 1 else x := ckrn numr u; if null x then x := 1; % Probably means a large float whose inverse appears as 0. if !*allfac and x neq car u then go to b else if w then <<w := exchk w; go to c>>; d: u := prepsq u; return if eqcar(u,'plus) then cdr u else list u; b: if x=1 and null w then go to d; % ONEP u := quotof(numr u,x) ./ denr u; w := prepf mkkl(w,x); if u = (1 ./ 1) then return list w else if eqcar(w,'times) then w := cdr w else w := list w; c: return list retimes aconc!*(w,prepsq u) end; symbolic procedure ckrn!*(u,v); if null u then errach 'ckrn!* else if domainp u then 1 else if caaar u member v then list (caar u . ckrn!*(cdr carx(u,'ckrn),v)) else ckrn!*(cdr carx(u,'ckrn),v); symbolic procedure mkkl(u,v); if null u then v else mkkl(cdr u,list (car u . v)); symbolic procedure quotfm(u,v); begin scalar !*mcd; !*mcd := t; return quotf(u,v) end; endmodule; module depend; % Defining and checking expression dependency. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(depl!* frlis!*); % DEPL* is a list of dependencies among kernels; symbolic procedure depend u; for each x in cdr u do depend1(car u,x,t); symbolic procedure nodepend u; <<rmsubs(); for each x in cdr u do depend1(car u,x,nil)>>; rlistat '(depend nodepend); symbolic procedure depend1(u,v,bool); begin scalar y,z; u := !*a2k u; v := !*a2k v; if u eq v then return nil; y := assoc(u,depl!*); % if y then if bool then rplacd(y,union(list v,cdr y)) % else if (z := delete(v,cdr y)) then rplacd(y,z) if y then if bool then depl!*:= repasc(car y,union(list v,cdr y),depl!*) else if (z := delete(v,cdr y)) then depl!* := repasc(car y,z,depl!*) else depl!* := delete(y,depl!*) else if null bool then lprim list(u,"has no prior dependence on",v) else depl!* := list(u,v) . depl!* end; symbolic procedure depends(u,v); if null u or numberp u or numberp v then nil else if u=v then u else if atom u and u memq frlis!* then t %to allow the most general pattern matching to occur; else if (lambda x; x and ldepends(cdr x,v)) assoc(u,depl!*) then t else if not atom u and idp car u and get(car u,'dname) then nil else if not atom u and (ldepends(cdr u,v) or depends(car u,v)) then t else if atom v or idp car v and get(car v,'dname) then nil % else dependsl(u,cdr v); else nil; symbolic procedure ldepends(u,v); % Allow for the possibility that U is an atom. if null u then nil else if atom u then depends(u,v) else depends(car u,v) or ldepends(cdr u,v); symbolic procedure dependsl(u,v); v and (depends(u,car v) or dependsl(u,cdr v)); symbolic procedure freeof(u,v); not(smember(v,u) or v member assoc(u,depl!*)); symbolic operator freeof; flag('(freeof),'boolean); % infix freeof; % precedence freeof,lessp; %put it above all boolean operators; endmodule; module str; % Routines for structuring expressions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(scountr svar svarlis); global '(!*fort !*nat !*savestructr varnam!*); switch savestructr; % ***** two essential uses of RPLACD occur in this module. symbolic procedure structr u; begin scalar scountr,fvar,svar,svarlis; %SVARLIS is a list of elements of form: %(<unreplaced expression> . <newvar> . <replaced exp>); scountr :=0; fvar := svar := varnam!*; if cdr u then <<fvar := svar := cadr u; if cddr u then fvar := caddr u>>; u := aeval car u; if flagpcar(u,'struct) then u := car u . (for each j in cdr u collect for each k in j collect struct!*sq k) else if getrtype u then typerr(u,"STRUCTR argument") else u := struct!*sq u; if null !*fort then <<varpri(u,nil,'only); if not flagpcar(u,'struct) then terpri(); if scountr=0 then return nil else <<if null !*nat then terpri(); prin2t " where">>>> else svarlis := reversip!* svarlis; for each x in svarlis do <<terpri!* t; if null !*fort then prin2!* " "; varpri(cddr x,list('setq,cadr x,mkquote cddr x),t)>>; if !*fort then fvarpri(u,list fvar,t); if !*savestructr then <<if arrayp svar then <<put(svar,'array, mkarray(list(scountr+1),'algebraic)); put(svar,'dimension,list(scountr+1))>>; for each x in svarlis do setk2(cadr x,mk!*sq !*k2q car x)>> end; rlistat '(structr); symbolic procedure setk2(u,v); if atom u then setk1(u,v,t) else setelv(u,v); symbolic procedure struct!*sq u; if eqcar(u,'!*sq) then mk!*sq(structf numr cadr u ./ structf denr cadr u) else u; symbolic procedure structf u; if null u then nil else if domainp u then u else begin scalar x,y; x := mvar u; if sfp x then if y := assoc(x,svarlis) then x := cadr y else x := structk(prepsq!*(structf x ./ 1), structvar(),x) else if not atom x and not atomlis cdr x then if y := assoc(x,svarlis) then x := cadr y else x := structk(x,structvar(),x); return x .** ldeg u .* structf lc u .+ structf red u end; symbolic procedure structk(u,id,v); begin scalar x; if x := subchk1(u,svarlis,id) then rplacd(x,(v . id . u) . cdr x) else if x := subchk2(u,svarlis) then svarlis := (v . id . x) . svarlis else svarlis := (v . id . u) . svarlis; return id end; symbolic procedure subchk1(u,v,id); begin scalar w; while v do <<smember(u,cddar v) and <<w := v; rplacd(cdar v,subst(id,u,cddar v))>>; v := cdr v>>; return w end; symbolic procedure subchk2(u,v); begin scalar bool; for each x in v do smember(cddr x,u) and <<bool := t; u := subst(cadr x,cddr x,u)>>; if bool then return u else return nil end; symbolic procedure structvar; begin scountr := scountr + 1; return if arrayp svar then list(svar,scountr) else intern compress append(explode svar,explode scountr) end; endmodule; module coeff; % Routines for finding coefficients of forms. % Author: Anthony C. Hearn. % Modifications by: F. Kako (including introduction of COEFFN). % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*ratarg hipow!* lowpow!* wtl!*); switch ratarg; flag ('(hipow!* lowpow!*),'share); symbolic procedure coeffeval u; begin integer n; n := length u; if n<2 or n>3 then rederr "COEFF called with wrong number of arguments" else return coeff1(car u,cadr u, if null cddr u then nil else caddr u) end; put('coeff,'psopfn,'coeffeval); symbolic procedure coeff1(u,v,w); % Finds the coefficients of V in U and returns results in W; begin scalar bool,x,y,z; v := !*a2k v; u := simp!* u; bool := !*ratarg or freeof(prepf denr u,v); if null bool then u := !*q2f u; x := setkorder list v; if null bool then <<y := reorder u; u := 1>> else <<y := reorder numr u; u := denr u>>; setkorder x; if null y then go to a; while not domainp y and mvar y=v do <<z := (ldeg y . !*ff2a(lc y,u)) . z; y := red y>>; if null y then go to b; a: z := (0 . !*ff2a(y,u)) . z; b: lowpow!* := caar z; z := reverse z; hipow!* := caar z; z := multiple!-result(z,w); return if null w then z else hipow!* end; symbolic procedure coeffn(u,v,n); % Returns n-th coefficient of U. begin scalar bool,x,y; n := reval n; if not fixp n or minusp n then typerr(n,"COEFFN index"); v := !*a2k v; u := simp!* u; bool := !*ratarg or freeof(prepf denr u,v); if null bool then u := !*q2f u; x := setkorder list v; if null bool then <<y := reorder u; u := 1>> else <<y := reorder numr u; u := denr u>>; setkorder x; if null y then return nil; b: if domainp y or mvar y neq v then return if n=0 then !*ff2a(y,u) else 0 else if n=ldeg y then return !*ff2a(lc y,u) else if n>ldeg y then return 0 else <<y := red y; go to b>> end; flag('(coeffn),'opfn); flag('(coeffn),'noval); endmodule; module weight; % Asymptotic command package. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(asymplis!*); global '(wtl!*); flag('(k!*),'reserved); % Asymptotic list and weighted variable association lists. symbolic procedure weight u; begin scalar y,z; rmsubs(); for each x in u do if not eqexpr x then errpri2(x,'hold) else <<y := !*a2k cadr x; z := reval caddr x; if not (numberp z and fixp z and z>0) then typerr(z,"weight"); wtl!* := (y . z) . delasc(y,wtl!*)>> end; symbolic procedure wtlevel u; begin integer n; scalar x; n := reval car u; if not(numberp n and fixp n and not n<0) then errpri2(n,'hold); n := n+1; x := atsoc('k!*,asymplis!*); if n=cdr x then return nil else if n<=cdr x then rmsubs(); asymplis!* := ('k!* . n) . delasc('k!*,asymplis!*) end; rlistat '(weight wtlevel); algebraic let k!***2=0; endmodule; module linop; % Linear operator package. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*intstr); symbolic procedure linear u; for each x in u do if not idp x then typerr(x,'operator) else flag(list x,'linear); rlistat '(linear); put('linear,'simpfg,'((rmsubs))); symbolic procedure formlnr u; begin scalar x,y,z; x := car u; if null cdr u or null cddr u then rederr list("Linear operator", x,"called with too few arguments"); y := cadr u; z := !*a2k caddr u . cdddr u; return if y = 1 then u else if not depends(y,car z) then list('times,y,x . 1 . z) else if atom y then u else if car y eq 'plus then 'plus . for each j in cdr y collect formlnr(x . j. z) else if car y eq 'minus then list('minus,formlnr(x . cadr y . z)) else if car y eq 'difference then list('difference,formlnr(x . cadr y . z), formlnr(x . caddr y . z)) else if car y eq 'times then formlntms(x,cdr y,z,u) else if car y eq 'quotient then formlnquot(x,cdr y,z,u) else if car y eq 'recip and not depends(cadr y,car z) then list('quotient,x . 1 . z,cadr y) else if y := expt!-separate(y,car z) then list('times,car y,x . cdr y . z) else u end; symbolic procedure formseparate(u,v); %separates U into two parts, and returns a dotted pair of them: those %which are not commutative and do not depend on V, and the remainder; begin scalar w,x,y; for each z in u do if not noncomp z and not depends(z,v) then x := z . x else if (w := expt!-separate(z,v)) then <<x := car w . x; y := cdr w . y>> else y := z . y; return reversip!* x . reversip!* y end; symbolic procedure expt!-separate(u,v); %determines if U is an expression in EXPT that can be separated into %two parts, one that does not depend on V and one that does, %except if there is no non-dependent part, NIL is returned; if not eqcar(u,'expt) or depends(cadr u,v) or not eqcar(caddr u,'plus) then nil else expt!-separate1(cdaddr u,cadr u,v); symbolic procedure expt!-separate1(u,v,w); begin scalar x; x := formseparate(u,w); return if null car x then nil else list('expt,v,replus car x) . if null cdr x then 1 else list('expt,v,replus cdr x) end; symbolic procedure formlntms(u,v,w,x); %U is a linear operator, V its first argument with TIMES removed, %W the rest of the arguments and X the whole expression. %Value is the transformed expression; begin scalar y; y := formseparate(v,car w); return if null car y then x else 'times . aconc!*(car y, if null cddr y then formlnr(u . cadr y . w) else u . ('times . cdr y) . w) end; symbolic procedure formlnquot(fn,quotargs,rest,whole); %FN is a linear operator, QUOTARGS its first argument with QUOTIENT %removed, REST the remaining arguments, WHOLE the whole expression. %Value is the transformed expression; begin scalar x; return if not depends(cadr quotargs,car rest) then list('quotient,formlnr(fn . car quotargs . rest), cadr quotargs) else if not depends(car quotargs,car rest) and car quotargs neq 1 then list('times,car quotargs, formlnr(fn . list('recip,cadr quotargs) . rest)) else if eqcar(car quotargs,'plus) then 'plus . for each j in cdar quotargs collect formlnr(fn . ('quotient . j . cdr quotargs) . rest) else if eqcar(car quotargs,'minus) then list('minus,formlnr(fn . ('quotient . cadar quotargs . cdr quotargs) . rest)) else if eqcar(car quotargs,'times) and car(x := formseparate(cdar quotargs,car rest)) then 'times . aconc!*(car x, formlnr(fn . list('quotient,mktimes cdr x, cadr quotargs) . rest)) else if eqcar(cadr quotargs,'times) and car(x := formseparate(cdadr quotargs,car rest)) then list('times,list('recip,mktimes car x), formlnr(fn . list('quotient,car quotargs,mktimes cdr x) . rest)) else if x := expt!-separate(car quotargs,car rest) then list('times,car x,formlnr(fn . list('quotient,cdr x,cadr quotargs) . rest)) else if x := expt!-separate(cadr quotargs,car rest) then list('times,list('recip,car x), formlnr(fn . list('quotient,car quotargs,cdr x) . rest)) else if (x := reval!* cadr quotargs) neq cadr quotargs then formlnquot(fn,list(car quotargs,x),rest,whole) else whole end; symbolic procedure mktimes u; if null cdr u then car u else 'times . u; symbolic procedure reval!* u; %like REVAL, except INTSTR is always ON; begin scalar !*intstr; !*intstr := t; return reval u end; endmodule; module polyop; % Functions for algebraic mode operations on polynomials. % Author: Anthony C. Hearn. % Modified by: F. Kako. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*ratarg); symbolic procedure deg(u,kern); begin scalar x,y; u := simp!* u; y := denr u; tstpolyarg(y,u); u := numr u; kern := !*a2k kern; if domainp u then return 0 else if mvar u eq kern then return !*f2a ldeg u; x := setkorder list kern; u := reorder u; if not(mvar u eq kern) then u := nil else u := ldeg u; setkorder x; return !*f2a u end; symbolic procedure lcof(u,kern); begin scalar x,y; u := simp!* u; y := denr u; tstpolyarg(y,u); u := numr u; kern := !*a2k kern; if domainp u then return u else if mvar u eq kern then return !*ff2a(lc u,y); x := setkorder list kern; u := reorder u; if mvar u eq kern then u := lc u; setkorder x; return if null u then 0 else !*ff2a(u,y) end; symbolic procedure lterm(u,kern); begin scalar x,y; u := simp!* u; y := denr u; tstpolyarg(y,u); u := numr u; kern := !*a2k kern; if domainp u then return nil else if mvar u eq kern then return !*ff2a(lt u .+ nil,y); x := setkorder list kern; u := reorder u; if not(mvar u eq kern) then u := nil else u := lt u .+ nil; setkorder x; u := reorder u; return if null u then 0 else !*ff2a(u,y) end; symbolic procedure !*lterm u; lt u .+ nil; symbolic procedure mainvar u; if domainp(u := numr simp!* u) then 0 else if sfp(u := mvar u) then prepf u else u; symbolic procedure reduct(u,kern); begin scalar x,y; u := simp!* u; y := denr u; tstpolyarg(y,u); u := numr u; kern := !*a2k kern; if domainp u then return !*ff2a(u,y) else if mvar u eq kern then return !*ff2a(cdr u,y); x := setkorder list kern; u := reorder u; if mvar u eq kern then u := cdr u else u := nil; setkorder x; u := reorder u; return !*ff2a(u,y) end; symbolic procedure tstpolyarg(y,u); null !*ratarg and y neq 1 and typerr(prepsq u,"polynomial"); symbolic operator deg,lcof,lterm,mainvar,reduct; endmodule; module elem; % Simplification rules for elementary functions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*!*sqrt !*keepsqrts); global '(e!-value!* pi!-value!* subfg!*); % No references to RPLAC-based functions in this module. algebraic; comment RULE FOR I**2; remflag('(i),'reserved); let i**2= -1; flag('(e i nil pi t),'reserved); comment LOGARITHMS; operator log; let log(e)= 1, log(1)= 0; for all x let log(e**x)=x; % The next set of rules are not implemented yet. %for all x,y let log(x*y) = log x + log y, log(x/y) = log x - log y; for all x let df(log(x),x) = 1/x; comment TRIGONOMETRICAL FUNCTIONS; symbolic procedure simptrig u; % This is a basic simplification function for trigonometrical % functions. The prefix expression U is of the form (<trig-function> % <argument>). It is assumed that the trig-function is either even % or odd, with even the default (and the odd case a flag "odd"). % The value is a standard quotient for the simplified expression. % Note: we must use PREPSQXX and not PREPSQ* here, since the REVOP1 % in SUBS3T uses PREPSQXX, and terms must be consistent to prevent a % loop in the pattern matcher. begin scalar bool,fn,x,z; fn := car u; u := cdr u; if null u or cdr u then rederr list("Wrong number of arguments to",fn); u := simp!* car u; if null numr u and flagp(fn,'odd) and not flagp(fn,'nonzero) then return nil ./ 1; x := list(fn,prepsqxx u); if subfg!* and (z := opmtch x) then return simp z else if minusf numr u and (flagp(fn,'odd) and (bool := t) or flagp(fn,'even)) then <<x := list(fn,prepsqxx(u := (negf numr u ./ denr u))); if subfg!* and (z := opmtch x) then <<x := simp z; return if bool then negsq x else x>>>>; if z := domainvalchk(fn,list u) then x := z else x := mksq(x,1); return if bool then negsq x else x end; deflist('((acos simptrig) (asin simptrig) (atan simptrig) (acosh simptrig) (asinh simptrig) (atanh simptrig) (cos simptrig) (sin simptrig) (tan simptrig) (sec simptrig) (csc simptrig) (cot simptrig)(acot simptrig)(coth simptrig)(acoth simptrig) (cosh simptrig) (sinh simptrig) (tanh simptrig) ),'simpfn); % The following declaration causes the simplifier to pass the full % expression (including the function) to SIMPTRIG. flag ('(acos asin atan acosh asinh atanh cos sin tan cosh sinh tanh csc sec cot acot coth acoth), 'full); flag('(asin atan asinh atanh sin tan csc sinh tanh cot coth), 'odd); flag('(cos sec cosh acosh),'even); flag('(cot coth),'nonzero); %flag('(asin atan asinh atanh sin tan sinh tanh cot acot coth acoth), % 'odd); %flag('(cos sec),'even); %flag('(cot),'nonzero); % In the following rules, it is not necessary to let f(0)=0, when f % is odd, since SIMPTRIG already does this. let cos(0)= 1, cos(pi/6)=sqrt 3/2, sin(pi/6)= 1/2, cos(pi/4)=sqrt 2/2, sin(pi/4)=sqrt 2/2, cos(pi/3) = 1/2, sin(pi/3) = sqrt(3)/2, cos(pi/2)= 0, sin(pi/2)= 1, sin(pi)= 0, cos(pi)=-1, cosh 0=1, acos(0)= pi/2, acos(1)=0; for all x let cos acos x=x, sin asin x=x, tan atan x=x, cosh acosh x=x, sinh asinh x=x, tanh atanh x=x, cot acot x=x, coth acoth x=x; for all x let acos(-x)=pi-acos(x); for all n such that numberp n and fixp n let sin(n*pi)=0, cos(n*pi) = (-1)**n; for all n such that numberp n and fixp n let cos((n*pi)/2)= 0; for all n such that numberp n and fixp n let sin((n*pi)/2) = if remainder(abs n,4)<2 then 1 else -1; for all n such that numberp n and fixp n let cos((n*pi)/3)= (if n=4 or remainder(abs n+2,6)>3 then -1 else 1)/2; for all n such that numberp n and fixp n let sin((n*pi)/3)= (if remainder(abs n,6)<3 then 1 else -1)*sqrt(3)/2; for all n such that numberp n and fixp n let cos((n*pi)/4)= (if remainder(abs n+2,8)<4 then 1 else -1)*sqrt(2)/2; for all n such that numberp n and fixp n let sin((n*pi)/4)= (if remainder(abs n,8)<4 then 1 else -1)*sqrt(2)/2; for all n such that numberp n and fixp n let cos((n*pi)/6)= (if remainder(abs n+2,12)<6 then 1 else -1)*sqrt(3)/2; for all n such that numberp n and fixp n let sin((n*pi)/6)= (if remainder(abs n,12)<6 then 1 else -1)/2; % ***** Differentiation rules *****. for all x let df(acos(x),x)= -sqrt(1-x**2)/(1-x**2), df(asin(x),x)= sqrt(1-x**2)/(1-x**2), df(atan(x),x)= 1/(1+x**2), df(acosh(x),x)= sqrt(x**2-1)/(x**2-1), df(asinh(x),x)= sqrt(x**2+1)/(x**2+1), df(atanh(x),x)= 1/(1-x**2), df(cos x,x)= -sin(x), df(sin(x),x)= cos(x), df(tan x,x)=1+tan x**2, df(sinh x,x)=cosh x, df(cosh x,x)=sinh x, df(tanh x,x)=1-tanh x**2, df(cot x,x)=-1-cot x**2, df(coth x,x)=1-coth x**2; let e**(i*pi/2) = i, e**(i*pi) = -1, e**(3*i*pi/2)=-i; %for all x let e**log x=x; % Requires every power to be checked. for all x,y let df(x**y,x)= y*x**(y-1), df(x**y,y)= log x*x**y; comment SQUARE ROOTS; deflist('((sqrt simpsqrt)),'simpfn); %for all x let sqrt x**2=x; % !*!*sqrt: used to indicate that SQRTs have been used. % !*keepsqrts: causes SQRT rather than EXPT to be used. symbolic procedure mksqrt u; if not !*keepsqrts then list('expt,u,list('quotient,1,2)) else <<if null !*!*sqrt then <<!*!*sqrt := t; algebraic for all x let sqrt x**2=x>>; list('sqrt,u)>>; for all x let df(sqrt x,x)=sqrt x/(2*x); comment ERF, EXP, EXPINT AND DILOG; operator erf,exp,expint,dilog; let erf 0=0; let dilog(0)=pi**2/6; for all x let erf(-x)=-erf x; for all x let df(erf x,x)=2*sqrt(pi)*e**(-x**2)/pi; for all x let exp(x)=e**x; for all x let df(expint(x),x)=e**x/x; for all x let df(dilog x,x)=-log x/(x-1); comment Supply missing argument and simplify 1/4 roots of unity; let e**(i*pi/2) = i, e**(i*pi) = -1, e**(3*i*pi/2)=-i; symbolic; % Floating point interface for elementary functions. % Perhaps this belongs in the floating point module. deflist('((exp !*exp!*) (expt !*expt!*) (log !*log!*) (sin !*sin!*) (cos !*cos!*) (tan !*tan!*) (asin !*asin!*) (acos !*acos!*) (atan !*atan!*) (sqrt !*sqrt!*) (e !*e!*) (pi !*pi!*)), '!:ft!:); symbolic procedure !*acos!* u; mkfloat acos cdr u; symbolic procedure !*asin!* u; mkfloat asin cdr u; symbolic procedure !*atan!* u; mkfloat atan cdr u; symbolic procedure !*cos!* u; mkfloat cos cdr u; symbolic procedure !*exp!* u; mkfloat exp cdr u; symbolic procedure !*expt!*(u,v); mkfloat if fixp v then expt(u,v) else exp(cdr v*log cdr u); symbolic procedure !*log!* u; mkfloat log cdr u; symbolic procedure !*sin!* u; mkfloat sin cdr u; symbolic procedure !*tan!* u; mkfloat tan cdr u; symbolic procedure !*e!*; mkfloat e!-value!*; symbolic procedure !*pi!*; mkfloat pi!-value!*; endmodule; module nssimp; % Simplification functions for non-scalar quantities. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*div frlis!* subfg!*); % Several inessential uses of ACONC, NCONC, and MAPping "JOIN". Latter % not yet changed. symbolic procedure nssimp(u,v); %U is a prefix expression involving non-commuting quantities. %V is the type of U. Result is an expression of the form % SUM R(I)*PRODUCT M(I,J) where the R(I) are standard %quotients and the M(I,J) non-commuting expressions; %N. B: the products in M(I,J) are returned in reverse order %(to facilitate, e.g., matrix augmentation); begin scalar w,x,y,z; u := dsimp(u,v); a: if null u then return z; w := car u; c: if null w then go to d else if numberp car w or not(eqcar(car w,'!*div) or getrtype car w eq v) then x := aconc!*(x,car w) else y := aconc!*(y,car w); w := cdr w; go to c; d: if null y then go to er; e: z := addns(((if null x then 1 ./ 1 else simptimes x) . y),z); u := cdr u; x := y:= nil; go to a; er: y := v; if idp car x then if not flagp(car x,get(y,'fn)) then redmsg(car x,y) else rederr list(y,x,"not set") else if w := get(get(y,'tag),'i2d) then <<y := list apply1(w,1); go to e>> %to allow a scalar to be a 1 by 1 matrix; else msgpri(list("Missing",y,"in"),car x,nil,nil,t); put(car x,y,y); y := list car x; x := cdr x; go to e end; symbolic procedure dsimp(u,v); %result is a list of lists representing a sum of products; %N. B: symbols are in reverse order in product list; if numberp u then list list u else if atom u then (if x and subfg!* then dsimp(x,v) else if flagp(u,'share) then dsimp(eval u,v) else <<flag(list u,'used!*); list list u>>) where x= get(u,'rvalue) else if car u eq 'plus then for each j in cdr u join dsimp(j,v) else if car u eq 'difference then nconc!*(dsimp(cadr u,v), dsimp('minus . cddr u,v)) else if car u eq 'minus then dsimptimes(list(-1,carx(cdr u,'dsimp)),v) else if car u eq 'times then dsimptimes(cdr u,v) else if car u eq 'quotient then dsimptimes(list(cadr u,list('recip,carx(cddr u,'dsimp))),v) else if not getrtype u eq v then list list u else if car u eq 'recip then list list list('!*div,carx(cdr u,'dsimp)) else if car u eq 'expt then (lambda z; if not numberp z or not fixp z then errpri2(u,t) else if z<0 then list list list('!*div,'times . nlist(cadr u,-z)) else if z=0 then list list list('!*div,cadr u,1) else dsimptimes(nlist(cadr u,z),v)) reval caddr u else if flagp!*!*(car u,'noncommuting) then list list u else if arrayp car u then dsimp(getelv u,v) else (lambda x; if x then dsimp(x,v) else (lambda y; if y then dsimp(y,v) else list list u) opmtch revop1 u) opmtch u; symbolic procedure dsimptimes(u,v); if null u then errach 'dsimptimes else if null cdr u then dsimp(car u,v) else (lambda j; for each k in dsimptimes(cdr u,v) join mappend(j,k)) dsimp(car u,v); symbolic procedure addns(u,v); if null v then list u else if cdr u=cdar v then (lambda x; % if null car x then cdr v else; (x . cdr u) . cdr v) addsq(car u,caar v) else if ordp(cdr u,cdar v) then u . v else car v . addns(u,cdr v); symbolic procedure getelx u; %to take care of free variables in LET statements; if smemqlp(frlis!*,cdr u) then nil else if null(u := getelv u) then 0 else reval u; endmodule; module camlsp; % Definitions needed to run Cambridge LISP modules % supported in REDUCE under Standard LISP. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. % remprop('error,'newnam); % putd('!%error,'expr,cdr getd 'error); % symbolic macro procedure !%error u; % if null cddr u then list('error,50,cadr u) else 'error . cdr u; % put('error,'newnam,'!%error); % remprop('errorset,'newnam); % putd('!%errorset,'expr,cdr getd 'errorset); % symbolic macro procedure !%errorset u; % if null cdddr u then list('errorset,cadr u,caddr u,'!*backtrace) % else 'errorset . cdr u; % put('errorset,'newnam,'!%errorset); smacro procedure gcd(u,v); gcdn(u,v); % symbolic smacro procedure gensym1 u; gensym(); symbolic smacro procedure iadd1 u; add1 u; infix iequal; symbolic smacro procedure u iequal v; eqn(u,v); infix irem; symbolic smacro procedure u irem v; remainder(u,v); symbolic smacro procedure isub1 u; sub1 u; symbolic procedure printc u; prin2t u; % Cannot be smacro because of FUNCTION PRINTC in INTBASISREDUCTION % and NORMALBASIS in full integrator. symbolic smacro procedure readclock; time(); symbolic smacro procedure reversewoc u; reversip u; symbolic smacro procedure princ u; prin2 u; symbolic procedure superprint u; prettyprint u; % Cannot be smacro because of FUNCTION SUPERPRINT in COATESMATRIX % and JHDSOLVE. symbolic smacro procedure unglobal u; nil; comment The following three smacros can be used if there is a reason for not using actual vectors; %smacro procedure mkvect n; %mknill(n+1); %smacro procedure putv(u,n,v); %car rplaca(pnth(u,n+1),v); %smacro procedure getv(u,n); %nth(u,n+1); endmodule; module part; % Access and updates parts of an algebraic expression. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure revalpart u; begin scalar !*intstr,expn,v; !*intstr := t; % To make following result in output form. expn := reval car u; !*intstr := nil; v := cdr u; while v do begin scalar x,y; if atom expn then parterr(expn,car v) else if not numberp(x := reval car v) then msgpri("Invalid argument",car v,"to part",nil,t) else if x=0 then return <<expn := car expn; v := nil>> else if x<0 then <<x := -x; y := reverse cdr expn>> else y := cdr expn; if length y<x then parterr(expn,car v) else expn := nth(y,x); v := cdr v end; return expn end; put('part,'psopfn,'revalpart); symbolic procedure revalsetpart u; %Simplifies a SETPART expression; begin scalar !*intstr,x,y; x := reverse cdr u; !*intstr := t; y := reval car u; !*intstr := nil; return revalsetp1(y,reverse cdr x,reval car x) end; symbolic procedure revalsetp1(expn,ptlist,rep); if null ptlist then rep else if atom expn then msgpri("Expression",expn, "does not have part",car ptlist,t) else begin scalar x; if not numberp(x := reval car ptlist) then msgpri("Invalid argument",car ptlist,"to part",nil,t) else return if x=0 then rep . cdr expn else if x<0 then car expn . reverse ssl(reverse cdr expn, -x,cdr ptlist,rep,expn . car ptlist) else car expn . ssl(cdr expn,x,cdr ptlist, rep,expn . car ptlist) end; symbolic procedure ssl(expn,indx,ptlist,rep,rest); if null expn then msgpri("Expression",car rest,"does not have part",cdr rest,t) else if indx=1 then revalsetp1(car expn,ptlist,rep) . cdr expn else car expn . ssl(cdr expn,indx-1,ptlist,rep,rest); put('part,'setqfn,'setpart!*); put('setpart!*,'psopfn,'revalsetpart); symbolic procedure arglength u; begin scalar !*intstr,x; if null u then return 0; !*intstr := t; x := reval u; return if atom x then -1 else length cdr x end; flag('(arglength),'opfn); flag('(arglength),'noval); endmodule; end; |
Added r33/algint.red version [d4b67d0f80].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 | module afactor; % Author: James H. Davenport. fluid '(!*galois !*noextend !*sqfree afactorvar listofnewsqrts monicpart); global '(!*trfield); exports afactor; imports exptf,ordop,!*multf,addf,makemainvar,algebraicsf,divsf,contents; imports quotf!*,negf,sqfr!-norm2,prepf,gcdinonevar,algint!-subf,!*q2f; imports jfactor,printsf; % internal!-fluid '(monicpart); symbolic procedure afactor(u,v); % Factorises U over the algebraics as a polynomial in V (=afactorvar). begin scalar afactorvar,!*noextend,!*sqfree; % !*sqfree is known to be square free (from sqfr-norm). !*noextend:=t; % else we get recursion. afactorvar:=v; if !*trfield then << princ "We must factorise the following over: "; for each u in listofnewsqrts do <<princ u; princ " " >>; terpri(); printsf u >>; v:=algfactor u; if !*trfield then << printc "factorises as "; mapc(v,function printsf) >>; return v end; symbolic procedure algfactor2(f,a); if null a then for each u in jfactor(f,mvar f) collect numr u else if algebraicsf f then algfactor3(f,a) else begin scalar w; if !*trfield then << princ "to be factorized over "; for each u in a do << princ u; princ " " >>; terpri(); printsf f >>; if (!*galois neq 2) and (numberp red f) and (not numberp argof car a) then return algfactor2(f,cdr a); % assumes we need never express a root of a number in terms of % non-numbers. w:=algfactor2(f,nil); if null cdr w then return algfactor3(f,a) else return 'partial.w end; symbolic procedure algfactor3(f,a); begin scalar ff,w,gg,h,p; w:=sqfr!-norm2(f,mvar f,car a); !*sqfree:=car w; w:=cdr w; ff:=algfactor2(!*sqfree,cdr a); if car ff eq 'partial then << p:='partial; ff:=cdr ff >>; if null cdr ff then return list f; %does not factor. a:=car a; gg:=cadr w; w:=list list(afactorvar,'plus,afactorvar,prepf car w); h:=for each u in ff collect (!*q2f algint!-subf(gcdinonevar(u,gg,afactorvar),w)); if p eq 'partial then h:=p.h; return h end; symbolic procedure algfactor u; begin scalar a,aa,z,w,monicpart; z:= makemainvar(u,afactorvar); if ldeg z iequal 1 then return list u; z:=lc z; if z iequal 1 then go to monic; if algebraicsf z then u:=!*multf(u,numr divsf(1,z)); % this de-algebraicises the top coefficient. u:=quotf!*(u,contents(u,afactorvar)); z:=makemainvar(u,afactorvar); if lc z neq 1 then if lc z iequal -1 then u:=negf u else << w:=lc z; u:=makemonic z >>; monic: aa:=listofnewsqrts; if algebraicsf u then go to normal; a:=cdr aa; % we need not try for the first one, since algfactor2 % will do this for us. z:=t; while a and z do begin scalar alg,v; alg:=car a; a:=cdr a; v:=algfactor3(u,list alg); if null cdr v then return; if car v eq 'partial then v:=cdr v; % we do not mind if the factorisation is only partial. a:=mapcan(v,function algfactor); z:=nil end; monicpart:=w; if null z then if null w then return a else return mapcar(a,function demonise); normal: z:=algfactor2(u,aa); monicpart:=w; if null cdr z or (car z neq 'partial) then if null w then return z else return mapcar(z,function demonise); % does not factor. if null w then return mapcan(cdr z,function algfactor) else return for each u in z conc algfactor demonise u; end; symbolic procedure demonise u; % Replaces afactorvar by afactorvar*monicpart in u. if atom u then u else if afactorvar eq mvar u then addf(demonise red u, !*multf(lt u .+ nil,exptf(monicpart,ldeg u))) else if ordop(afactorvar,mvar u) then u else addf(demonise red u, !*multf(!*p2f lpow u,demonise lc u)); symbolic procedure makemonic u; % U is a makemainvar'd polynomial. begin scalar v,w,x,xx; v:=mvar u; x:=lc u; xx:=1; w:=!*p2f lpow u;% the monic term. u:=red u; for i:=(isub1 ldeg w) step -1 until 1 do begin if atom u then go to next; if mvar u neq v then go to next; if ldeg u iequal i then w:=addf(w,!*multf(lc u, !*multf(!*p2f lpow u,xx))); u:=red u; next: xx:=!*multf(x,xx) end; w:=addf(w,!*multf(u,xx)); return w end; % unfluid '(monicpart); endmodule; module algfn; % Author: James H. Davenport. % Check if an expression is in a pure algebraic extension of % Q(all "constants")(var). exports algfnpl,algebraicsf; imports simp,interr,dependsp,dependspl; symbolic procedure algfnp(pf,var); if atom pf then t else if not atom car pf then interr "Not prefix form" else if car pf eq '!*sq then algfnsq(cadr pf,var) else if car pf eq 'expt then if not algint!-ratnump caddr pf then (not dependsp(cadr pf,var)) and (not dependsp(caddr pf,var)) else algfnp(cadr pf,var) else if not memq(car pf,'(minus plus times quotient sqrt)) % JPff fiddle then not dependspl(cdr pf,var) else algfnpl(cdr pf,var); symbolic procedure algfnpl(p!-list,var); null p!-list or algfnp(car p!-list,var) and algfnpl(cdr p!-list,var); symbolic procedure algfnsq(sq,var); algfnsf(numr sq,var) and algfnsf(denr sq,var); symbolic procedure algfnsf(sf,var); atom sf or algfnp(mvar sf,var) and algfnsf(lc sf,var) and algfnsf(red sf,var); symbolic procedure algint!-ratnump q; if atom q then numberp q else car q eq 'quotient and (numberp cadr q) and (numberp caddr q); symbolic procedure algebraicsf u; if atom u then nil else algebraicp mvar u or algebraicsf lc u or algebraicsf red u; symbolic procedure algebraicp u; if atom u then nil else if car u eq 'expt then 1 neq denr simp caddr u else car u eq 'sqrt; endmodule; module algnums; % Author: James H. Davenport. exports denr!-algno; symbolic procedure denr!-algno u; % Returns the true denominator of the algebraic number u. begin scalar sqlist,n,m,u!*!*j,d,isub1n; u!*!*j:=1 ./ 1; sqlist:=sqrtsinsq(u,nil); sqlist:=multbyallcombinations(list(1 ./ 1), for each u in sqlist collect !*kk2q u); n:=0; sqlist:=for each u in sqlist collect (numr u) . (n:=iadd1 n); % format is of an associtaion list. n:=length sqlist; m:=mkvect n; isub1n:=isub1 n; for i:=0:n do putv(m,i,mkvect2(n,nil ./ 1)); putv(getv(m,0),cdr assoc(1,sqlist),1 ./ 1); % initial matrix is now set up. for j:=1:n do begin scalar v,w; u!*!*j:=!*multsq(u!*!*j,u); dump!-sqrts!-coeffs(u!*!*j,sqlist,getv(m,j)); v:=firstlinearrelation(m,n); if null v then return; if last!-non!-zero v > j then return; if (w:=getv(v,j)) neq (1 ./ 1) then << w:=!*invsq w; for i:=0:j do putv(v,i,!*multsq(w,getv(v,i))) >>; m:=v; n:=j; return end; % Now m is a monic polynomial, minimal for u, of degree n. d:=1; for i:=0:isub1 n do begin scalar v,prime; v:=denr getv(m,i); prime:=2; loop: if v = 1 then return; if not zerop cdr divide(v,prime) then prime:=nextprime(prime) else << d:=d*prime; for i:=0:n do putv(v,i,multsq(getv(v,i),1 ./ (prime ** (n-i)) )) >>; go to loop; end; return d; end; symbolic procedure dump!-sqrts!-coeffs(u,sqlist,vec); begin scalar w; dump!-sqrts!-coeffs2(numr u,sqlist,vec,1); u:=1 ./ denr u; if denr u neq 1 then for i:=0:upbv vec do if numr(w:=getv(vec,i)) then putv(vec,i,!*multsq(u,w)); end; symbolic procedure dump!-sqrts!-coeffs2(u,sqlist,vec,sqrtssofar); if null u then nil else if numberp u then putv(vec,cdr assoc(sqrtssofar,sqlist),u) else << dump!-sqrts!-coeffs2(red u,sqlist,vec,sqrtssofar); dump!-sqrts!-coeffs2(lc u,sqlist,vec,!*multf(sqrtssofar, !*k2f mvar u)) >>; symbolic procedure last!-non!-zero vec; begin scalar n; for i:=0:upbv vec do if numr getv(vec,i) then n:=i; return n end; endmodule; module antisubs; % Author: James H. Davenport. exports antisubs; imports purge,interr,dependsp; symbolic procedure antisubs(place,x); % Produces the inverse substitution to a substitution list. begin scalar answer,w; while place and (x=caar place) do<< w:=cdar place; % w is the substitution rule. if atom w then if w neq x then interr "False atomic substitution" else nil else answer:=(x.anti2(w,x)).answer; place:=cdr place>>; if null answer then answer:=(x.x).answer; return answer end; symbolic procedure anti2(eexpr,x); %Produces the function inverse to the eexpr provided. if atom eexpr then if eexpr eq x then x else interr "False atom" else if car eexpr eq 'plus then deplus(cdr eexpr,x) else if car eexpr eq 'minus then subst(list('minus,x),x,anti2(cadr eexpr,x)) else if car eexpr eq 'quotient then if dependsp(cadr eexpr,x) then if dependsp(caddr eexpr,x) then interr "Complicated division" else subst(list('times,caddr eexpr,x),x,anti2(cadr eexpr,x)) else if dependsp(caddr eexpr,x) then subst(list('quotient,cadr eexpr,x),x, anti2(caddr eexpr,x)) else interr "No division" else if car eexpr eq 'expt then if caddr eexpr iequal 2 then subst(list('sqrt,x),x,anti2(cadr eexpr,x)) else interr "Unknown root" else if car eexpr eq 'times then detimes(cdr eexpr,x) else if car eexpr eq 'difference then deplus(list(cadr eexpr,list('minus,caddr eexpr)),x) else interr "Unrecognised form in antisubs"; symbolic procedure detimes(p!-list,var); % Copes with lists 'times. begin scalar u,v; u:=deplist(p!-list,var); v:=purge(u,p!-list); if null v then v:=var else if null cdr v then v:=list('quotient,var,car v) else v:=list('quotient,var,'times.v); if (null u) or (cdr u) then interr "Weird multiplication"; return subst(v,var,anti2(car u,var)) end; symbolic procedure deplist(p!-list,var); % Returns a list of those elements of p!-list which depend on var. if null p!-list then nil else if dependsp(car p!-list,var) then (car p!-list).deplist(cdr p!-list,var) else deplist(cdr p!-list,var); symbolic procedure deplus(p!-list,var); % Copes with lists 'plus. begin scalar u,v; u:=deplist(p!-list,var); v:=purge(u,p!-list); if null v then v=var else if null cdr v then v:=list('plus,var,list('minus,car v)) else v:=list('plus,var,list('minus,'plus.v)); if (null u) or (cdr u) then interr "Weird addition"; return subst(v,var,anti2(car u,var)) end; endmodule; module coates; % Author: James H. Davenport. fluid '(intvar magiclist nestedsqrts previousbasis sqrt!-intvar taylorasslist thisplace); global '(!*tra !*trmin coates!-fdi); exports coates,makeinitialbasis,checkpoles,multbyallcombinations; symbolic procedure coates(places,mults,x); begin scalar u,tt; tt:=readclock(); u:=coates!-hpfsd(places,mults); if !*tra or !*trmin then printc list ('coates,'time,readclock()-tt,'milliseconds); return u end; symbolic procedure coates!-real(places,mults); begin scalar thisplace,u,v,save; if !*tra or !*trmin then << princ "Find function with zeros of order:"; printc mults; if !*tra then princ " at "; terpri!*(t); if !*tra then mapc(places,function printplace) >>; % v:=placesindiv places; % V is a list of all the substitutors in PLACES; % u:=mkunique sqrtsintree(v,intvar,nil); % if !*tra then << % princ "Sqrts on this curve:"; % terpri!*(t); % superprint u >>; % algnos:=mkunique mapcar(places,function basicplace); % if !*tra then << % printc "Algebraic numbers where residues occur:"; % superprint algnos >>; v:=mults; for each uu in places do << if (car v) < 0 then u:=(rfirstsubs uu).u; v:=cdr v >>; thisplace:=list('quotient,1,intvar); if member(thisplace,u) then << v:= finitise(places,mults); % returns list (places,mults,power of intvar to remove. u:=coates!-real(car v,cadr v); if atom u then return u; return multsq(u,!*p2q mksp(intvar,caddr v)) >>; % It is not sufficient to check the current value of U in FRACTIONAL... % as we could have zeros over infinity JHD 18/8/86; for each uu in places do if rfirstsubs uu = thisplace then u:=append(u,mapcar(cdr uu,function car)); coates!-fdi:=fractional!-degree!-at!-infinity u; % Do we need to blow everything up by a factor of two (or more) % to avoid fractional powers at infinity? if coates!-fdi iequal 1 then return coatesmodule(places,mults,intvar); if !*tra then fdi!-print(); places:=mapcar(places,function fdi!-upgrade); save:=taylorasslist; u:=coatesmodule(places, mapcar(mults,function (lambda u;u*coates!-fdi)), intvar); taylorasslist:=save; % u:=fdi!-revertsq u; % That previous line is junk, I think (JHD 22.8.86) % just because we blew up the places doesn't mean that % we should deflate the function, because that has already been done. return u end; symbolic procedure coatesmodule(places,mults,x); begin scalar pzero,mzero,u,v,basis,sqrts,magiclist,mpole,ppole; % MAGICLIST holds the list of extra unknowns created in JHDSOLVE % which must be found in CHECKPOLES (calling FINDMAGIC). sqrts:=sqrtsinplaces places; if !*tra then << princ "Sqrts on this curve:"; superprint sqrts >>; u:=places; v:=mults; while u do << if 0<car v then << mzero:=(car v).mzero; pzero:=(car u).pzero >> else << mpole:=(car v).mpole; ppole:=(car u).ppole >>; u:=cdr u; v:=cdr v >>; % ***time-hack-2***; if previousbasis then basis:=previousbasis else basis:=mkvec makeinitialbasis ppole; u:=completeplaces(ppole,mpole); basis:=integralbasis(basis,car u,cdr u,x); basis:=normalbasis(basis,x,0); u:=coatessolve(mzero,pzero,basis,nil); % The NIL is the list of special constraints needed % to force certain poles to occur in the answer. if atom u then return u; v:= checkpoles(list u,places,mults); if null v then return 'failed; if not magiclist then return u; u:=removecmsq substitutesq(u,v); % Apply the values from FINDMAGIC. if !*tra or !*trmin then << printc "These values give the function"; printsq u >>; magiclist:=nil; if checkpoles(list u,places,mults) then return u else interr "Inconsistent checkpoles" end; symbolic procedure makeinitialbasis places; begin scalar u; u:=multbyallcombinations(list(1 ./ 1), for each u in getsqrtsfromplaces places collect !*kk2q u); if !*tra then << printc "Initial basis for the space m(x)"; mapc(u,function printsq) >>; return u end; symbolic procedure multbyallcombinations(u,l); % Produces a list of all elements of u, % each multiplied by every combination of elements of l. if null l then u else multbyallcombinations(nconc(multsql(car l,u),u),cdr l); symbolic procedure checkpoles(basis,places,mults); % Checks that the BASIS really does have all the % poles in (PLACES.MULTS). begin scalar u,v,l; go to outer2; outer: places:=cdr places; mults:=cdr mults; outer2: if null places then return if magiclist then findmagic l else t; if 0 leq car mults then go to outer; u:=basis; inner: if null u then << if !*tra then << princ "The answer from the linear equations did"; printc " not have the poles at:"; printplace car places >>; return nil >>; v:=taylorform xsubstitutesq(car u,car places); if taylorfirst v=car mults then << if magiclist then l:=taylorevaluate(v,car mults) . l; go to outer >>; if taylorfirst v < car mults then interr "Extraneous pole introduced"; u:=cdr u; go to inner end; symbolic procedure coates!-hpfsd(oplaces,omults); begin scalar mzero,pzero,mpole,ppole,fun,summzero,answer,places,mults; places:=oplaces; mults:=omults; % Keep originals in case need to use COATES!-REAL directly. summzero:=0; % holds the sum of all the mzero's. while places do << if 0<car mults then << summzero:=summzero + car mults; mzero:=(car mults).mzero; pzero:=(car places).pzero >> else << mpole:=(car mults).mpole; ppole:=(car places).ppole >>; places:=cdr places; mults:=cdr mults >>; if summzero > 2 then begin % We want to combine a zero/pole pair % so as to reduce the total index before calling coates!-real % on the remaining zeros/poles. scalar nplaces,nmults,f,multiplicity,newpole,sqrts,fz,zfound,mult1; sqrts:=getsqrtsfromplaces ppole; if !*tra or !*trmin then << princ "Operate on divisor:"; printc append(mzero,mpole); printc "at"; mapc(pzero,function printplace); mapc(ppole,function printplace) >>; iterate: nplaces:=list car pzero; multiplicity:=car mzero; nmults:=list 1; if cdr ppole then << nplaces:=(car ppole) . ( (cadr ppole) . nplaces); multiplicity:=min(multiplicity,- car mpole,- cadr mpole); nmults:=(-1) .((-1) . nmults) >> else << nplaces:=(car ppole) . nplaces; multiplicity:=min(multiplicity,(- car mpole)/2); nmults:=(-2) . nmults >>; previousbasis:=nil; f:=coates!-real(nplaces,nmults); if atom f then << if !*tra or !*trmin then printc "Failure: must try whole divisor"; return coates!-real(oplaces,omults) >>; % newpole:=removezero(findzeros(f,sqrts),car pzero). fz:=findzeros(f,sqrts); zfound:=assoc(car pzero,fz); if not zfound then interr "Didn't seem to find the zeros we looked for"; if cdr zfound > car mzero then interr "We found too many zeros"; fz:=delete(zfound,fz); if !*tra or !*trmin then << printc "Replaced by the pole"; if fz then prettyprint fz else <<terpri(); prin2t "The zero we were already looking for">>; princ multiplicity; printc " times" >>; mult1:=car mzero - multiplicity * cdr zfound; if mult1 < 0 then << printc "A zero has turned into a pole"; multiplicity:= car mzero / cdr zfound ; mult1:=remainder(car mzero, cdr zfound); >>; if zerop mult1 then << mzero:=cdr mzero; pzero:=cdr pzero >> else rplaca(mzero,mult1); if null cdr ppole then << if zerop (car mpole + 2*multiplicity) then << ppole:=cdr ppole; mpole:=cdr mpole >> else rplaca(mpole,car mpole + 2 * multiplicity) >> else << if zerop (cadr mpole + multiplicity) then << ppole:=(car ppole) . (cddr ppole); mpole:=(car mpole) . (cddr mpole) >> else rplaca(cdr mpole,cadr mpole + multiplicity); if zerop (car mpole + multiplicity) then << ppole:=cdr ppole; mpole:=cdr mpole >> else rplaca(mpole,car mpole + multiplicity) >>; while fz do << newpole:=caar fz; mult1:=multiplicity*(cdar fz); if newpole member pzero then begin scalar m,p; while newpole neq car pzero do << m:=(car mzero).m; mzero:=cdr mzero; p:=(car pzero).p; pzero:=cdr pzero >>; if mult1 < car mzero then << mzero:=(car mzero - mult1) . cdr mzero; mzero:=nconc(m,mzero); pzero:=nconc(p,pzero); return >>; if mult1 > car mzero then << ppole:=newpole.ppole; mpole:=(car mzero - mult1) . mpole >>; mzero:=nconc(m,cdr mzero); pzero:=nconc(p,cdr pzero) end else if newpole member ppole then begin scalar m,p; m:=mpole; p:=ppole; while newpole neq car p do << p:=cdr p; m:=cdr m >>; rplaca(m,car m - mult1) end else << mpole:=nconc(mpole,list(-mult1)); ppole:=nconc(ppole,list newpole) >>; fz:=cdr fz >>; f:=mk!*sq f; if multiplicity > 1 then answer:=list('expt,f,multiplicity).answer else answer:=f.answer; summzero:=0; for each x in mzero do summzero:=summzero+x; if !*tra then << princ "Function is now: "; printc append(mzero,mpole); printc "at"; mapc(pzero,function printplace); mapc(ppole,function printplace) >>; if summzero > 2 then go to iterate; end; fun:=coates!-real(nconc(pzero,ppole), nconc(mzero,mpole)); if null answer then return fun else answer:=(mk!*sq fun).answer; return !*k2q('times.answer); % This is not valid, but we hope that it will be unpicked; % (e.g. by SIMPLOG) before too much damage is caused. end; symbolic procedure removezero(l,place); if place member l then (lambda u; if null cdr u then car u else interr "Removezero") delete(place,l) else interr "Error in removezeros"; symbolic procedure findzeros(sq,sqrts); begin scalar u,potentials,answer,n; u:=denr sqrt2top invsq sq; potentials:=for each v in jfactor(u,intvar) collect begin scalar w,place; w:=makemainvar(numr v,intvar); if ldeg w neq 1 then interr "Can't cope"; if red w then place:=list(intvar,'plus,intvar,prepsq(negf red w ./ lc w)) else place:=intvar . intvar; % This IF .. ELSE .. added JHD 3 Sept 1980. return place end; potentials:=list(intvar,'quotient,1,intvar).potentials; for each place in potentials do begin scalar slist,nestedsqrts; place:=list place; newplace place; u:=substitutesq(sq,place); while involvesq(u,sqrt!-intvar) do begin scalar z; z:=list list(intvar,'expt,intvar,2); place:=nconc(place,z); newplace place; u:=substitutesq(u,z); end; slist:=sqrtsinsq(u,intvar); for each v in sqrts do slist:=union(slist,sqrtsinsq(xsubstitutesq(!*kk2q v,place), intvar)); slist:=sqrtsign(slist,intvar); for each s in slist do if (n:=taylorfirst taylorform substitutesq(u,s)) > 0 then answer:=(append(place,s).n).answer; return answer; end; if null answer then interr "No zero found"; return answer end; endmodule; module coatesid; % Author: James H. Davenport. fluid '(intvar magiclist nnn taylorasslist taylorvariable); global '(!*tra); exports coatessolve,vecprod,coates!-lineq; imports !*invsq,!*multsq,negsq,!*addsq,swap,check!-lineq,non!-null!-vec, printsq,sqrt2top,mapvec,mksp,vecsort,addsq,mkilist,mkvec,mapply, taylorformp,xsubstitutesq,taylorform,taylorevaluate,multsq, invsq,removecmsq; symbolic procedure coatessolve(mzero,pzero,basis,normals); begin scalar m,n,rightside,nnn; % if null normals % then normals:=list mkilist(basis,1 ./ 1); % This provides the default normalisation, % viz merely a de-homogenising constraint; % No it doesn't - JHD May 1983 and August 1986. % This may be precisely the wrong constraint, as can be seen from % the example of SQRT(X**2-1). Fixed 19/8/86 to amend COATESMATRIX % to insert a normalising constraint if none is provided. nnn:=max(length normals,1); basis:=mkvec basis; m:=coatesmatrix(mzero,pzero,basis,normals); n:=upbv m; rightside:=mkvect n; for i:=0:n do putv(rightside,n-i,(if i < nnn then 1 else nil) ./ 1); n:=coates!-lineq(m,rightside); if n eq 'failed then return 'failed; n:=removecmsq vecprod(n,basis); if !*tra then << printc "Answer from linear equation solving is "; printsq n >>; return n end; symbolic procedure coatesmatrix(mzero,pzero,basis,normals); % NORMALS is a list of the normalising constraints % that we must apply. Thypically, this is NIL, and we have to % invent one - see the code IF NULL NORMALS ... begin scalar ans,n1,n2,j,w,save,nextflag,save!-taylors,x!-factors, normals!-ok,temp; save!-taylors:=mkvect isub1 length pzero; save:=taylorasslist; normals!-ok:=nil; n1:=upbv basis; n2:=isub1 mapply(function plus2,mzero) + max(length normals,1); % the number of constaints in all (counting from 0). taylorvariable:=intvar; if !*tra then << printc "Basis for the functions with precisely the correct poles"; mapvec(basis,function printsq) >>; ans:=mkvect n2; for i:=0:n2 do putv(ans,i,mkvect n1); for i:=0:n1 do begin scalar xmz,xpz,k; xmz:=mzero; k:=j:=0; xpz:=pzero; while xpz do << newplace basicplace car xpz; if nextflag then w:=taylorformp list('binarytimes, getv(save!-taylors,k), getv(x!-factors,k)) else if not !*tra then w:=taylorform xsubstitutesq(getv(basis,i),car xpz) else begin scalar flg,u,slists; u:=xsubstitutesq(getv(basis,i),basicplace car xpz); slists:=extenplace car xpz; for each w in sqrtsinsq(u,intvar) do if not assoc(w,slists) then flg:=w.flg; if flg then << printc "The following square roots were not expected"; mapc(flg,function superprint); printc "in the substitution"; superprint car xpz; printsq getv(basis,i) >>; w:=taylorform xsubstitutesq(u,slists) end; putv(save!-taylors,k,w); k:=iadd1 k; for l:=0 step 1 until isub1 car xmz do << astore(ans,j,i,taylorevaluate(w,l)); j:=iadd1 j >>; if null normals and j=n2 then << temp:=taylorevaluate(w,car xmz); astore(ans,j,i,temp); % The defaults normalising condition is that the coefficient % after the last zero be a non-zero. % Unfortunately this too may fail (JHD 21.3.87) - check for it later normals!-ok:=normals!-ok or numr temp >>; xpz:=cdr xpz; xmz:=cdr xmz >>; nextflag:=(i < n1) and (getv(basis,i) = multsq(!*kk2q intvar,getv(basis,i+1))); if nextflag and null x!-factors then << x!-factors:=mkvect upbv save!-taylors; xpz:=pzero; k:=0; xmz:=invsq !*kk2q intvar; while xpz do << putv(x!-factors,k,taylorform xsubstitutesq(xmz,car xpz)); xpz:=cdr xpz; k:=iadd1 k >> >> end; if null normals and null normals!-ok then << if !*tra then printc "Our default normalisation condition was vacuous"; astore(ans,n2,n1,1 ./ 1)>>; while normals do << w:=car normals; for k:=0:n1 do << astore(ans,j,k,car w); w:=cdr w >>; j:=iadd1 j; normals:=cdr normals >>; tayshorten save; return ans end; symbolic procedure printmatrix(ans,n2,n1); if !*tra then << printc "Equations to be solved:"; for i:=0:n2 do begin if null getv(ans,i) then return; princ "Row number "; princ i; for j:=0:n1 do printsq getv(getv(ans,i),j) end >>; symbolic procedure vecprod(u,v); begin scalar w,n; w:=nil ./ 1; n:=upbv u; for i:=0:n do w:=addsq(w,!*multsq(getv(u,i),getv(v,i))); return w end; symbolic procedure coates!-lineq(m,rightside); begin scalar nnn,n; nnn:=desparse(m,rightside); if nnn eq 'failed then return 'failed; m:=car nnn; if null m then << n:=cddr nnn; goto vecprod >>; rightside:=cadr nnn; nnn:=cddr nnn; n:=check!-lineq(m,rightside); if n eq 'failed then return n; n:=jhdsolve(m,rightside,non!-null!-vec nnn); if n eq 'failed then return n; for i:=0:upbv n do if (m:=getv(nnn,i)) then putv(n,i,m); vecprod: for i:=0:upbv n do if null getv(n,i) then putv(n,i,nil ./ 1); return n end; symbolic procedure jhdsolve(m,rightside,ignore); % Returns answer to m.answer=rightside. % Matrix m not necessarily square. begin scalar n1,n2,ans,u,row,swapflg,swaps; % The SWAPFLG is true if we have changed the order of the % columns and need later to invert this via SWAPS. n1:=upbv m; for i:=0:n1 do if (u:=getv(m,i)) then (n2:=upbv u); printmatrix(m,n1,n2); swaps:=mkvect n2; for i:=0:n2 do putv(swaps,i,n2-i); % We have the SWAPS vector, which should be a vector of indices, % arranged like this because VECSORT sorts in decreasing order. for i:=0:isub1 n1 do begin scalar k,v,pivot; tryagain: row:=getv(m,i); if null row then go to interchange; % look for a pivot in row. k:=-1; for j:=0:n2 do if numr (pivot:=getv(row,j)) then << k:=j; j:=n2 >>; if k neq -1 then goto newrow; if numr getv(rightside,i) then << m:='failed; i:=sub1 n1; %Force end of loop. go to finished >>; % now interchange i and last element. interchange: swap(m,i,n1); swap(rightside,i,n1); n1:=isub1 n1; if i iequal n1 then goto finished else goto tryagain; newrow: if i neq k then << swapflg:=t; swap(swaps,i,k); % record what we have done. for l:=0:n1 do swap(getv(m,l),i,k) >>; % place pivot on diagonal. pivot:=sqrt2top negsq !*invsq pivot; for j:=iadd1 i:n1 do begin u:=getv(m,j); if null u then return; v:=!*multsq(getv(u,i),pivot); if numr v then << putv(rightside,j, !*addsq(getv(rightside,j),!*multsq(v,getv(rightside,i)))); for l:=0:n2 do putv(u,l,!*addsq(getv(u,l),!*multsq(v,getv(row,l)))) >> end; finished: end; if m eq 'failed then go to failed; % Equations were inconsistent. while null (row:=getv(m,n1)) do n1:=isub1 n1; u:=nil; for i:=0:n2 do if numr getv(row,i) then u:='t; if null u then if numr getv(rightside,n1) then go to failed else n1:=isub1 n1; % Deals with a last equation which is all zero. if n1 > n2 then go to failed; % Too many equations to satisfy. ans:=mkvect n2; n2:=n2 - ignore; if n1 < n2 then << if !*tra then << printc "The equations do not completely determine the functions"; printc "Matrix:"; mapvec(m,function superprint); printc "Right-hand side:"; superprint rightside >>; for i:=iadd1 n1:n2 do << u:=gensym(); magiclist:=u.magiclist; putv(ans,i,!*kk2q u) >>; if !*tra then printc "If in doubt consult an expert">>; % now to do the back-substitution. for i:=n1 step -1 until 0 do begin row:=getv(m,i); if null row then return; u:=getv(rightside,i); for j:=iadd1 i:n2 do u:=!*addsq(u,!*multsq(getv(row,j),negsq getv(ans,j))); putv(ans,i,!*multsq(u,sqrt2top !*invsq getv(row,i))) end; if swapflg then vecsort(swaps,list ans); return ans; failed: if !*tra then printc "Unable to force correct zeroes"; return 'failed end; symbolic procedure desparse(matrx,rightside); begin scalar vec,changed,n,m,zero,failed; zero := nil ./ 1; n:=upbv matrx; m:=upbv getv(matrx,0); vec:=mkvect m; % for i:=0:m do putv(vec,i,zero); %%% initialize - ach changed:=t; while changed and not failed do begin changed:=nil; for i:=0:n do if changed or failed then i:=n % and hence quit the loop. else begin scalar nzcount,row,pivot; row:=getv(matrx,i); if null row then return; nzcount:=0; for j:=0:m do if numr getv(row,j) then << nzcount:=iadd1 nzcount; pivot:=j >>; if nzcount = 0 then if null numr getv(rightside,i) then return putv(matrx,i,nil) else return (failed:='failed); if nzcount > 1 then return nil; nzcount:=getv(rightside,i); if null numr nzcount then << putv(vec,pivot,zero); go to was!-zero >>; nzcount:=!*multsq(nzcount,!*invsq getv(row,pivot)); putv(vec,pivot,nzcount); nzcount:=negsq nzcount; for i:=0:n do if (row:=getv(matrx,i)) then if numr (row:=getv(row,pivot)) then putv(rightside,i,!*addsq(getv(rightside,i), !*multsq(row,nzcount))); was!-zero: for i:=0:n do if (row:=getv(matrx,i)) then putv(row,pivot,zero); changed:=t; putv(matrx,i,nil); swap(matrx,i,n); swap(rightside,i,n); end; end; if failed then return 'failed; changed:=t; for i:=0:n do if getv(matrx,i) then changed:=nil; if changed then matrx:=nil; % We have completely solved the equations by these machinations. return matrx.(rightside.vec) end; symbolic procedure astore(a,i,j,val); putv(getv(a,i),j,val); endmodule; module findmagc; % Author: James H. Davenport. fluid '(magiclist); global '(!*tra); symbolic procedure findmagic l; begin scalar p,n,pvec,m,intvec,mcount,temp; % L is a list of things which must be made non-zero by means of % a suitable choice of values for the variables in MAGICLIST; l:=for each u in l collect << mapc(magiclist,function (lambda v; if involvesf(denr u,v) then interr "Hard findmagic")); numr u >>; if !*tra then << printc "We must make the following non-zero:"; mapc(l,function printsf); princ "by suitable choice of "; printc magiclist >>; % Strategy is random choice in a space which has only finitely % many singular points; p:=0; n:=isub1 length magiclist; pvec:=mkvect n; putv(pvec,0,2); for i:=1:n do putv(pvec,i,nextprime getv(pvec,isub1 i)); % Tactics are based on Godel (is this a mistake ??) and let P run % through numbers and take the prime factorization of them; intvec:=mkvect n; loop: p:=iadd1 p; if !*tra then << princ "We try the number "; printc p >>; m:=p; for i:=0:n do << mcount:=0; while zerop cdr (temp:=divide(m,getv(pvec,i)) ) do << mcount:=iadd1 mcount; m:=car temp >>; putv(intvec,i,mcount) >>; if m neq 1 then go to loop; if !*tra then << printc "which corresponds to "; superprint intvec >>; m:=nil; temp:=magiclist; for i:=0:n do << m:=((car temp).getv(intvec,i)).m; temp:=cdr temp >>; % M is the list of substitutions corresponding to this value of P; temp:=l; loop2: if null numr algint!-subf(car temp,m) then go to loop; temp:=cdr temp; if temp then go to loop2; if !*tra then << printc "which corresponds to the values:"; superprint m >>; return m end; endmodule; module findres; % Author: James H. Davenport. fluid '(!*gcd basic!-listofallsqrts basic!-listofnewsqrts intvar listofallsqrts listofnewsqrts nestedsqrts sqrt!-intvar taylorvariable); global '(!*tra !*trmin); exports find!-residue,findpoles; imports sqrt2top,jfactor,prepsq,printplace,simpdf,involvesf,simp; imports stt,interr,mksp,negf,multf,addf,let2,substitutesq,subs2q,quotf; imports printsq,clear,taylorform,taylorevaluate,involvesf,!*multsq; imports sqrtsave,sqrtsinsq,sqrtsign; symbolic procedure find!-residue(simpdl,x,place); % evaluates residue of simpdl*dx at place given by x=place(y). begin scalar deriv,nsd,poss,slist; listofallsqrts:=basic!-listofallsqrts; listofnewsqrts:=basic!-listofnewsqrts; deriv:=simpdf(list(place,x)); if involvesf(numr deriv,intvar) then return residues!-at!-new!-point(simpdl,x,place); if eqcar(place,'quotient) and (cadr place iequal 1) then goto place!-correct; place:=simp list('difference,intvar,place); if involvesq(place,intvar) then interr "Place wrongly formatted"; place:=list('plus,intvar,prepsq place); place!-correct: if car place eq 'plus and caddr place = 0 then place:=list(x.x) else place:=list(x.place); % the substitution required. nsd:=substitutesq(simpdl,place); deriv:=!*multsq(nsd,deriv); % differential is deriv * dy, where x=place(y). if !*tra then << printc "Differential after first substitution is "; printsq deriv >>; while involvesq(deriv,sqrt!-intvar) do << sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,place); nsd:=list(list(x,'expt,x,2)); deriv:=!*multsq(substitutesq(deriv,nsd),!*kk2q x); % derivative of x**2 is 2x, but there's a jacobian of 2 to % consider. place:=nconc(place,nsd) >>; % require coeff x**-1 in deriv. nestedsqrts:=nil; slist:=sqrtsinsq(deriv,x); if !*tra and nestedsqrts then printc "We have nested square roots"; slist:=sqrtsign(slist,intvar); % The reversewoc is to ensure that the simpler sqrts are at % the front of the list. % Slist is a list of all combinations of signs of sqrts. taylorvariable:=x; for each branch in slist do << nsd:=taylorevaluate(taylorform substitutesq(deriv,branch),-1); if numr nsd then poss:=(append(place,branch).nsd).poss >>; poss:=reversewoc poss; if null poss then go to finished; % poss is a list of all possible residues at this place. if !*tra then << princ "Residues at "; printplace place; printc " are "; mapc(poss, function (lambda u; << printplace car u; printsq cdr u >>)) >>; finished: sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,place); return poss end; symbolic procedure residues!-at!-new!-point(func,x,place); begin scalar place2,tempvar,topterm,a,b,xx; if !*tra then << printc "Find residues at all roots of"; superprint place >>; place2:=numr simp place; topterm:=stt(place2,x); if car topterm = 0 then interr "Why are we here?"; tempvar:=gensym(); place2:=addf(place2, multf(!*p2f mksp(x,car topterm),negf cdr topterm)); % The remainder of PLACE2. let2(list('expt,tempvar,car topterm), subst(tempvar,x,prepsq(place2 ./ cdr topterm)), nil,t); place2:=list list(x,'plus,x,tempvar); !*gcd:=nil; % No unnecessary work: only factors of X worry us. func:=subs2q substitutesq(func,place2); !*gcd:=t; xx:=!*k2f x; while (a:=quotf(numr func,xx)) and (b:=quotf(denr func,xx)) do func:=a ./ b; if !*tra then << printc "which gives rise to "; printsq func >>; if null a then b:=quotf(denr func,xx); % because B goes back to the last time round that WHILE loop. if b then go to hard; if !*tra then printc "There were no residues"; clear tempvar; return nil; % *** thesis remark *** % This test for having an X in the denominator only works % because we are at a new place, and hence (remark of Trager) % if we have a residue at one place over this point, we must have one % at them all, since the places are indistinguishable; hard: taylorvariable:=x; func:=taylorevaluate(taylorform func,-1); printsq func; interr "so far" end; symbolic procedure findpoles(simpdl,x); begin scalar simpdl2,poles; % finds possible poles of simpdl * dx. simpdl2:=sqrt2top simpdl; poles:=jfactor(denr simpdl2,x); poles:=mapcar(poles,function prepsq); % what about the place at infinity. poles:=list('quotient,1,x).poles; if !*tra or !*trmin then << printc "Places at which poles could occur "; for each u in poles do printplace list(intvar.u) >>; return poles end; endmodule; module finitise; % Author: James H. Davenport. fluid '(intvar); global '(!*tra); exports finitise; imports newplace,getsqrtsfromplaces,interr,completeplaces2,sqrtsign; imports mkilist,extenplace; symbolic procedure finitise(places,mults); begin scalar placesmisc,multsmisc,m,n,sqrts; scalar places0,mults0,placesinf,multsinf; newplace list (intvar.intvar); % fix the disaster with 1/sqrt(x**2-1) % (but with no other 1/sqrt(x**2-k). sqrts:=getsqrtsfromplaces places; placesmisc:=places; multsmisc:=mults; n:=0; while placesmisc do << if eqcar(rfirstsubs car placesmisc,'quotient) and (n > car multsmisc) then << n:=car multsmisc; m:=multiplicity!-factor car placesmisc >>; placesmisc:=cdr placesmisc; multsmisc:=cdr multsmisc >>; if n = 0 then interr "Why did we call finitise ??"; % N must be corrected to allow for our representation of % multiplicities at places where X is not the local parameter. n:=divide(n,m); if not zerop cdr n and !*tra then printc "Cannot get the poles moved precisely because of ramification"; if (cdr n) < 0 then n:=(-1) + car n else n:=car n; % The above 3 lines (as a replacement for the line below) % inserted JHD 06 SEPT 80. % n:=car n; % ***** not true jhd 06 sept 80 *****; % This works because, e.g., DIVIDE(-1,2) is -1 remainder 1. % Note that N is actually negative. % We now wish to divide by X**N, thus increasing % the degrees of all infinite places by N and % decreasing the degrees of all places lying over 0. while places do << if atom rfirstsubs car places then << places0:=(car places).places0; mults0:=(car mults).mults0 >> else if car rfirstsubs car places eq 'quotient then << placesinf:=(car places).placesinf; multsinf:=(car mults).multsinf >> else << placesmisc:=(car places).placesmisc; multsmisc:=(car mults).multsmisc >>; places:=cdr places; mults:=cdr mults >>; if places0 then << places0:=completeplaces2(places0,mults0,sqrts); mults0:=cdr places0; places0:=car places0; m:=multiplicity!-factor car places0; mults0:=for each u in mults0 collect u+n*m >> else << places0:=for each u in sqrtsign(sqrts,intvar) collect (intvar.intvar).u; mults0:=mkilist(places0,n * (multiplicity!-factor car places0))>>; placesinf:=completeplaces2(placesinf, multsinf, for each u in extenplace car placesinf collect lsubs u); multsinf:=cdr placesinf; placesinf:=car placesinf; while placesinf do << m:=multiplicity!-factor car placesinf; if (car multsinf) neq n*m then << placesmisc:=(car placesinf).placesmisc; multsmisc:=(car multsinf -n*m).multsmisc >>; % This test ensures that we do not add places % with a multiplicity of zero. placesinf:=cdr placesinf; multsinf:=cdr multsinf >>; return list(nconc(places0,placesmisc), nconc(mults0,multsmisc), -n) end; symbolic procedure multiplicity!-factor place; begin scalar n; n:=1; for each u in place do if (lsubs u eq intvar) and eqcar(rsubs u,'expt) then n:=n*(caddr rsubs u); return n end; endmodule; module fixes; % Author: James H. Davenport. fluid '(!*nosubs asymplis!* dmode!*); global '(ncmp!*); % The standard version of SUBF messes with the order of variables before % calling SUBF1, something we can't afford, so we define a new version. symbolic procedure algint!-subf(a,b); algint!-subf1(a,b); symbolic procedure algint!-subsq(u,v); quotsq(algint!-subf(numr u,v),algint!-subf(denr u,v)); symbolic procedure algint!-subf1(u,l); %U is a standard form, %L an association list of substitutions of the form %(<kernel> . <substitution>). %Value is the standard quotient for substituted expression. %Algorithm used is essentially the straight method. %Procedure depends on explicit data structure for standard form; if domainp u then if atom u then if null dmode!* then u ./ 1 else simpatom u else if dmode!* eq car u then !*d2q u else simp prepf u else begin integer n; scalar kern,m,w,x,xexp,y,y1,z; z := nil ./ 1; a0: kern := mvar u; if m := assoc(kern,asymplis!*) then m := cdr m; a: if null u or (n := degr(u,kern))=0 then go to b else if null m or n<m then y := lt u . y; u := red u; go to a; b: if not atom kern and not atom car kern then kern := prepf kern; if null l then xexp := if kern eq 'k!* then 1 else kern else if (xexp := algint!-subsublis(l,kern)) = kern and not assoc(kern,asymplis!*) then go to f; c: w := 1 ./ 1; n := 0; if y and cdaar y<0 then go to h; if (x := getrtype xexp) then typerr(x,"substituted expression"); x := simp xexp; % SIMP!* here causes problem with HE package; x := reorder numr x ./ reorder denr x; % needed in case substitution variable is in XEXP; if null l and kernp x and mvar numr x eq kern then go to f else if null numr x then go to e; %Substitution of 0; for each j in y do <<m := cdar j; w := multsq(exptsq(x,m-n),w); n := m; z := addsq(multsq(w,algint!-subf1(cdr j,l)),z)>>; e: y := nil; if null u then return z else if domainp u then return addsq(algint!-subf1(u,l),z); go to a0; f: sub2chk kern; for each j in y do z := addsq(multpq(car j,algint!-subf1(cdr j,l)),z); go to e; h: %Substitution for negative powers; x := simprecip list xexp; j: y1 := car y . y1; y := cdr y; if y and cdaar y<0 then go to j; k: m := -cdaar y1; w := multsq(exptsq(x,m-n),w); n := m; z := addsq(multsq(w,algint!-subf1(cdar y1,l)),z); y1 := cdr y1; if y1 then go to k else if y then go to c else go to e end; symbolic procedure algint!-subsublis(u,v); begin scalar x; return if x := assoc(v,u) then cdr x else if atom v then v else if car v eq '!*sq then list('!*sq,algint!-subsq(cadr v,u),caddr v) % Previous two lines added by JHD 7 July 1982. % without them, CDRs in SQ expressions buried inside; % !*SQ forms are lost; else if flagp!*!*(car v,'subfn) then algint!-subsubf(u,v) else for each j in v collect algint!-subsublis(u,j) end; symbolic procedure algint!-subsubf(l,expn); %Sets up a formal SUB expression when necessary; begin scalar x,y; for each j in cddr expn do if (x := assoc(j,l)) then <<y := x . y; l := delete(x,l)>>; expn := sublis(l,car expn) . for each j in cdr expn collect algint!-subsublis(l,j); %to ensure only opr and individual args are transformed; if null y then return expn; expn := aconc!*(for each j in reversip!* y collect list('equal,car j,aeval cdr j),expn); return mk!*sq if l then algint!-simpsub expn else !*p2q mksp('sub . expn,1) end; symbolic procedure algint!-simpsub u; begin scalar !*nosubs,w,x,z; a: if null cdr u then <<if getrtype car u or eqcar(car u,'equal) then typerr(car u,"scalar"); u := simp!* car u; z := reversip!* z; % to put replacements in same % order as input. return quotsq(algint!-subf(numr u,z), algint!-subf(denr u,z))>>; !*nosubs := t; % We don't want left side of eqns to change. w := reval car u; !*nosubs := nil; if getrtype w eq 'list then <<u := append(cdr w,cdr u); go to a>> else if not eqexpr w then errpri2(car u,t); x := cadr w; if null getrtype x then x := !*a2k x; z := (x . caddr w) . z; u := cdr u; go to a; end; endmodule; module fracdi; % Author: James H. Davenport. fluid '(basic!-listofallsqrts basic!-listofnewsqrts expsub intvar sqrt!-intvar); global '(coates!-fdi); exports fdi!-print,fdi!-revertsq,fdi!-upgrade, fractional!-degree!-at!-infinity; % internal!-fluid '(expsub); symbolic procedure fdi!-print(); << princ "We substitute"; princ intvar; princ "**"; princ coates!-fdi; princ " for "; princ intvar; printc " in order to avoid fractional degrees at infinity" >>; symbolic procedure fdi!-revertsq u; if coates!-fdi iequal 1 then u else (fdi!-revert numr u) ./ (fdi!-revert denr u); symbolic procedure fdi!-revert u; if not involvesf(u,intvar) then u else addf(fdi!-revert red u, !*multf(fdi!-revertpow lpow u, fdi!-revert lc u)); symbolic procedure fdi!-revertpow pow; if not dependsp(car pow,intvar) then (pow .* 1) .+ nil else if car pow eq intvar then begin scalar v; v:=divide(cdr pow,coates!-fdi); if zerop cdr pow then return (mksp(intvar,car pow) .* 1) .+ nil else interr "Unable to revert fdi"; end else if eq(car pow,'sqrt) then simpsqrt2 fdi!-revert !*q2f simp argof car pow else interr "Unrecognised term to revert"; symbolic procedure fdi!-upgrade place; begin scalar ans,u,expsub,n; n:=coates!-fdi; for each u in place do if eqcar(u:=rsubs u,'expt) then n:=n / caddr u; % if already upgraded, we must take account of this. if n = 1 then return place; expsub:=list(intvar,'expt,intvar,n); ans:=nconc(basicplace place,list expsub); expsub:=list expsub; % this prevents later nconc from causing trouble. u:=extenplace place; while u do begin scalar v,w,rfu; v:=fdi!-upgr2 lfirstsubs u; if v iequal 1 then return (u:=cdr u); if eqcar(rfu:=rfirstsubs u,'minus) then w:=argof rfu else if eqcar(rfu,'sqrt) then w:=rfu else interr "Unknown place format"; w:=fdi!-upgr2 w; if w iequal 1 then interr "Place collapses under rewriting"; if eqcar(rfu,'minus) then ans:=nconc(ans,list list(v,'minus,w)) else ans:=nconc(ans,list(v.w)); u:=cdr u; return end; sqrtsave(basic!-listofallsqrts, basic!-listofnewsqrts, basicplace ans); return ans end; symbolic procedure fdi!-upgr2 u; begin scalar v,mv; v:=substitutesq(simp u,expsub); if denr v neq 1 then goto error; v:=numr v; loop: if atom v then return v; if red v then go to error; mv:=mvar v; if (not dependsp(mv,intvar)) or (mv eq intvar) then << v:=lc v; goto loop >>; if eqcar(mv,'sqrt) then if sqrtsinsf(lc v,nil,intvar) then go to error else return mv else go to error; error: printc "*** Format error ***"; princ "unable to go x:=x**"; printc coates!-fdi; superprint u; rederr "Failure to make integral at infinity" end; symbolic procedure fractional!-degree!-at!-infinity sqrts; if sqrts then lcmn(fdi2 car sqrts,fractional!-degree!-at!-infinity cdr sqrts) else 1; symbolic procedure fdi2 u; % Returns the denominator of the degree of x at infinity % in the sqrt expression u. begin scalar n; u:=substitutesq(simp u,list list(intvar,'quotient,1,intvar)); n:=0; while involvesq(u,sqrt!-intvar) do << n:=iadd1 n; u:=substitutesq(u,list list(intvar,'expt,intvar,2)) >>; return (2**n) end; symbolic procedure lcmn(i,j); i*j/gcdn(i,j); % unfluid '(expsub); endmodule; module genus; % Author: James H. Davenport. fluid '(!*galois gaussiani intvar listofallsqrts listofnewsqrts nestedsqrts previousbasis sqrt!-intvar sqrt!-places!-alist sqrtflag sqrts!-in!-integrand taylorasslist taylorvariable); global '(!*tra !*trmin); symbolic procedure simpgenus u; begin scalar intvar,sqrt!-intvar,taylorvariable,taylorasslist; scalar listofnewsqrts,listofallsqrts,sqrt!-places!-alist; scalar list!-of!-all!-sqrts,list!-of!-new!-sqrts; scalar sqrtflag,sqrts!-in!-integrand,tt,u,simpfn; tt:=readclock(); sqrtflag:=t; taylorvariable:=intvar:=car u; simpfn:=get('sqrt,'simpfn); put('sqrt,'simpfn,'proper!-simpsqrt); sqrt!-intvar:=mvar !*q2f simpsqrti intvar; listofnewsqrts:= list mvar gaussiani; % Initialise the SQRT world. listofallsqrts:= list (argof mvar gaussiani . gaussiani); u:=for each v in cdr u collect simp!* v; sqrts!-in!-integrand:=sqrtsinsql(u,intvar); u:=!*n2sq length differentials!-1 sqrts!-in!-integrand; put('sqrt,'simpfn,simpfn); printc list('time,'taken,readclock()-tt,'milliseconds); return u end; put('genus,'simpfn,'simpgenus); symbolic procedure differentials!-1 sqrtl; begin scalar asqrtl,faclist,places,v,nestedsqrts,basis, u,n,hard!-ones,sqrts!-in!-problem; % HARD!-ONES A list of all the factors of our equations which do % not factor, and therefore such that we can divide the whole of % our INTBASIS by their product in order to get the true INTBASIS, % since these ones can cause no complications. asqrtl:=for each u in sqrtl collect !*q2f simp argof u; if !*tra or !*trmin then << printc "Find the differentials of the first kind on curve defined by:"; mapc(asqrtl,function printsf) >>; for each s in asqrtl do << faclist:=for each u in jfactor(s,intvar) collect numr u; if !*tra then << princ intvar; printc " is not a local variable at the roots of:"; mapc(faclist,function printsf) >>; for each uu in faclist do << v:=stt(uu,intvar); if 1 neq car v then hard!-ones:=uu.hard!-ones else << u:=addf(uu,(mksp(intvar,1) .* (negf cdr v)) .+ nil) ./ cdr v; % U is now the value at which this SQRT has a zero. u:=list(list(intvar,'difference,intvar,prepsq u), list(intvar,'expt,intvar,2)); for each w in sqrtsign(for each w in union(delete(s,asqrtl), delete(uu,faclist)) conc sqrtsinsq(simpsqrtsq multsq(substitutesq(w ./ 1,u), 1 ./ !*p2f mksp(intvar,2)), intvar), intvar) do places:=append(u,w).places >> >> >>; sqrts!-in!-problem:=nconc(for each u in hard!-ones collect list(intvar.intvar, (lambda u;u.u) list('sqrt,prepf u)), places); basis:=makeinitialbasis sqrts!-in!-problem; % Bodge in any extra SQRTS that we will require later. % u:=1 ./ mapply(function multf, % for each u in sqrtl collect !*kk2f u); % basis:=for each v in basis collect multsq(u,v); basis:=integralbasis(mkvec basis,places,mkilist(places,-1),intvar); if not !*galois then basis:=combine!-sqrts(basis, getsqrtsfromplaces sqrts!-in!-problem); if hard!-ones then << v:=upbv basis; u:=1; for each v in hard!-ones do u:=multf(u,!*kk2f list('sqrt,prepf v)); hard!-ones:=1 ./ u; for i:=0:v do putv(basis,i,multsq(getv(basis,i),hard!-ones)) >>; if not !*galois then basis:=modify!-sqrts(basis,sqrtl); v:=fractional!-degree!-at!-infinity sqrtl; if v iequal 1 then n:=2 else n:=2*v-1; % N is the degree of the zero we need at INFINITY. basis:=normalbasis(basis,intvar,n); previousbasis:=nil; % it might have been set before, and we have changed its meaning. if !*tra or !*trmin then << printc "Differentials are:"; mapc(basis,function printsq) >>; return basis; end; endmodule; module intbasis; % Author: James H. Davenport. fluid '(excoatespoles intvar previousbasis taylorasslist taylorvariable); global '(!*tra !*trmin); exports completeplaces,completeplaces2,integralbasis; symbolic procedure deleteplace(a,b); if null b then nil else if equalplace(a,car b) then cdr b else (car b).deleteplace(a,cdr b); symbolic procedure completeplaces(places,mults); begin scalar current,cp,cm,op,om,ansp,ansm; if null places then return nil; %%% ACH loop: current:=basicplace car places; while places do << if current = (basicplace car places) then << cp:=(car places).cp; cm:=(car mults ).cm >> else << op:=(car places).op; om:=(car mults ).om >>; places:=cdr places; mults:=cdr mults >>; cp:=completeplaces2(cp,cm,sqrtsinplaces cp); ansp:=append(car cp,ansp); ansm:=append(cdr cp,ansm); places:=op; mults:=om; cp:=op:=cm:=om:=nil; if places then go to loop else return ansp.ansm end; symbolic procedure completeplaces2(places,mults,sqrts); % Adds extra places with multiplicities of 0 as necessary. begin scalar b,p; sqrts:=sqrtsign(sqrts,intvar); b:=basicplace car places; p:=places; while p do << if not(b = (basicplace car p)) then interr "Multiple places not supported"; sqrts:=deleteplace(extenplace car p,sqrts); p:=cdr p >>; mults:=nconc(nlist(0,length sqrts),mults); places:=nconc(mappend(sqrts,b),places); return places.mults end; symbolic procedure intbasisreduction(zbasis,places,mults); begin scalar i,m,n,v,w,substn,basis; substn:=list(intvar.intvar); % The X=X substitution. n:=upbv zbasis; basis:=copyvec(zbasis,n); taylorvariable:=intvar; v:=sqrtsinplaces places; for i:=0:n do w:=union(w,sqrtsinsq(getv(basis,i),intvar)); m:=intersect(v,w); v:=purge(m,v); w:=purge(m,w); for each u in v do << if !*tra or !*trmin then << printc u; printc "does not occur in the functions"; mapvec(basis,function printsq) >>; m:=!*q2f simp argof u; i:=w; while i and not quotf(m,!*q2f simp argof car i) do i:=cdr i; if null i then interr "Unable to find equivalent representation of branches"; i:=car i; w:=delete(i,w); places:=subst(i,u,places); if !*tra or !*trmin then << printc "replaced by"; printc i >> >>; if (length places) neq (iadd1 n) then << if !*tra then printc "Too many functions"; basis := shorten!-basis basis; n:=upbv basis >>; m:=mkvect n; for i:=0:n do putv(m,i,cl6roweval(basis.i,places,mults,substn)); reductionloop: if !*tra then << printc "Matrix before a reduction step:"; mapvec(m,function printc) >>; v:=firstlinearrelation(m,iadd1 n); if null v then return replicatebasis(basis,(iadd1 upbv zbasis)/(n+1)); i:=n; while null numr getv(v,i) do i:=isub1 i; w:=nil ./ 1; for j:=0:i do w:=!*addsq(w,!*multsq(getv(basis,j),getv(v,j))); w:=removecmsq multsq(w,1 ./ !*p2f mksp(intvar,1)); if null numr w then << mapvec(basis,function printsq); printc iadd1 i; interr "Basis collapses" >>; if !*tra then << princ "Element "; princ iadd1 i; printc " of the basis replaced by "; if !*tra then printsq w >>; putv(basis,i,w); putv(m,i,cl6roweval(basis.i,places,mults,substn)); goto reductionloop end; symbolic procedure integralbasis(basis,places,mults,x); begin scalar z,save,points,p,m,princilap!-part,mm; if null places then return basis; mults:=mapcar(mults,function (lambda u;min(u,0))); % this makes sure that we impose constraints only on % poles, not on zeroes. points:=removeduplicates mapcar(places,function basicplace); if points = list(x.x) then basis:=intbasisreduction(basis,places,mults) else if cdr points then go complex else << substitutevec(basis,car points); if !*tra then << printc "Integral basis reduction at"; printc car points >>; basis:=intbasisreduction(basis, mapcar(places,function extenplace), mults); substitutevec(basis,antisubs(car points,x)) >>; join: save:=taylorasslist; % we will not need te taylorevaluates at gensym. z:=gensym(); places:=mapcons(places,x.list('difference,x,z)); z:=list(x . z); % basis:=intbasisreduction(basis, % places, % nlist(0,length places), % x,z); taylorasslist:=save; % ***time-hack-2***; if not excoatespoles then previousbasis:=copyvec(basis,upbv basis); % Save only if in COATES/FINDFUNCTION, not if in EXCOATES. return basis; complex: while points do << p:=places; m:=mults; princilap!-part:=mm:=nil; while p do << if (car points) = (basicplace car p) then << princilap!-part:=(extenplace car p).princilap!-part; mm:=(car m).mm >>; p:=cdr p; m:=cdr m >>; substitutevec(basis,car points); if !*tra then << printc "Integral basis reduction at"; printc car points >>; basis:=intbasisreduction(basis,princilap!-part,mm); substitutevec(basis,antisubs(car points,x)); points:=cdr points >>; go to join end; symbolic procedure cl6roweval(basisloc,places,mults,x!-alpha); % Evaluates a row of the matrix in coates lemma 6. begin scalar i,v,w,save,basiselement,taysave,mmults,flg; i:=isub1 length places; v:=mkvect i; taysave:=mkvect i; i:=0; basiselement:=getv(car basisloc,cdr basisloc); mmults:=mults; while places do << w:=substitutesq(basiselement,car places); w:=taylorform substitutesq(w,x!-alpha); % The separation of these 2 is essential since the x->x-a % must occur after the places are chosen. save:=taylorasslist; if not flg then putv(taysave,i,w); w:=taylorevaluate(w,car mmults); tayshorten save; putv(v,i,w); i:=iadd1 i; flg:=flg or numr w; mmults:=cdr mmults; places:=cdr places >>; if flg then return v; % There was a non-zero element in this row. save:=0; loop: save:=iadd1 save; mmults:=mults; i:=0; while mmults do << w:=taylorevaluate(getv(taysave,i),save + car mmults); flg:=flg or numr w; mmults:=cdr mmults; putv(v,i,w); i:=iadd1 i >>; if not flg then go to loop; % Another zero row. putv(car basisloc,cdr basisloc,multsq(basiselement, 1 ./ !*p2f mksp(intvar,save))); return v end; symbolic procedure replicatebasis(basis,n); if n = 1 then basis else if n = 2 then begin scalar b,sqintvar,len; len:=upbv basis; sqintvar:=!*kk2q intvar; b:=mkvect(2*len+1); for i:=0:len do << putv(b,i,getv(basis,i)); putv(b,i+len+1,multsq(sqintvar,getv(basis,i))) >>; return b end else interr "Unexpected replication request"; symbolic procedure shorten!-basis v; begin scalar u,n,sfintvar; sfintvar:=!*kk2f intvar; n:=upbv v; for i:=0:n do begin scalar uu; uu:=getv(v,i); if not quotf(numr uu,sfintvar) then u:=uu.u end; return mkvec u end; endmodule; module jhddiff; % Author: James H. Davenport. fluid '(dw); % Differentiation routines for algebraic expressions; symbolic procedure !*diffsq(u,v); %U is a standard quotient, V a kernel. %Value is the standard quotient derivative of U wrt V. %Algorithm: df(x/y,z)= (x'-(x/y)*y')/y; !*multsq(!*addsq(!*difff(numr u,v), negsq !*multsq(u,!*difff(denr u,v))), 1 ./ denr u); symbolic procedure !*difff(u,v); %U is a standard form, V a kernel. %Value is the standard quotient derivative of U wrt V; if domainp u then nil ./ 1 else !*addsq(!*addsq(multpq(lpow u,!*difff(lc u,v)), !*multsq(lc u ./ 1,!*diffp(lpow u,v))), !*difff(red u,v)); symbolic procedure !*diffp(u,v); % Special treatment of SQRT's (JHD is not sure why, % but it seems to be necessary); if atom (car u) then diffp(u,v) else if not (caar u) eq 'sqrt then diffp(u,v) else begin scalar w,dw; w:=simp argof car u; dw:= !*diffsq(w,v); if null numr dw then return dw; return !*multsq(!*multsq(dw,invsq w), !*multf(cdr u,mksp(car u,1) .* 1 .+ nil)./ 2) end; endmodule; module jhdriver; % Author: James H. Davenport. fluid '(!*backtrace basic!-listofallsqrts basic!-listofnewsqrts expression gaussiani intvar listofallsqrts listofnewsqrts previousbasis sqrt!-intvar sqrtflag sqrts!-in!-integrand sqrts!-mod!-prime taylorasslist varlist zlist); global '(!*algint !*coates !*noacn !*tra !*trmin btrlevel tryharder); switch algint,coates,noacn,tra,trmin; exports algebraiccase,doalggeom,coates!-multiple; !*algint := t; % Assume algebraic integration wanted if this module % is loaded. symbolic procedure operateon(reslist,x); begin scalar u,v,answer,save; scalar sqrts!-mod!-prime; u:=zmodule(reslist); v:=answer:=nil ./ 1; while u and not atom v do << v:=findfunction cdar u; if not atom v then << if !*tra or !*trmin then << printc "Extension logarithm is "; printsq v >>; save:=tryharder; tryharder:=x; v:= !*multsq(simp!* caar u, simplogsq v); tryharder:=save; answer:=addsq(answer,v); u:=cdr u >> >>; if atom v then return v else return answer end; symbolic procedure findfunction divisor; begin scalar v,places,mults,ans,dof1k; scalar previousbasis; % ***time-hack-2 ::: % A hack for decreasing the amount of work done in COATES. divisor:=for each u in divisor collect correct!-mults u; if !*coates then go to nohack; v:=precoates(divisor,intvar,nil); if not atom v then return v; nohack: for each u in divisor do << places:=(car u).places; mults :=(cdr u).mults >>; v:=coates(places,mults,intvar); if not atom v then return v; dof1k:=differentials!-1 getsqrtsfromplaces places; if null dof1k then interr "Must be able to integrate over curves of genus 0"; if not mazurp(places,dof1k) then go to general; ans:='provably!-impossible; for i:=2:12 do if (i neq 11) and not atom (ans:=coates!-multiple(places,mults,i)) then i:=12; % leave the loop - we have an answer. return ans; general: v:=findmaninparm places; if null v then return algebraic!-divisor(divisor,dof1k); if not maninp(divisor,v,dof1k) then return 'provably!-impossible; v:=1; loop: v:=iadd1 v; if not atom (ans:=coates!-multiple(places,mults,v)) then return ans; go to loop end; symbolic procedure correct!-mults u; begin scalar multip; multip:=cdr u; for each v in car u do if (lsubs v eq intvar) and eqcar(rsubs v,'expt) then multip:=multip * (caddr rsubs v); return (car u).multip end; symbolic procedure algebraiccase (expression,zlist,varlist); begin scalar rischpart,deriv,w,firstterm; scalar sqrtflag; sqrtflag:=t; sqrtsave(listofallsqrts,listofnewsqrts,list(intvar . intvar)); rischpart:=errorset('(doalggeom expression), if !*tra or !*trmin then t else btrlevel, !*backtrace); newplace list (intvar.intvar); if atom rischpart then << if !*tra then printc "Inner integration failed"; deriv:=nil ./ 1; % assume no answer. rischpart:=deriv >> else if atom car rischpart then << if !*tra or !*trmin then printc "The 'logarithmic part' is not elementary"; return simpint1 list ('int,prepsq expression,intvar) >> else << rischpart:=car rischpart; deriv:=!*diffsq(rischpart,intvar); % deriv := squashsqrt deriv; % Should no longer be necessary. if !*tra or !*trmin then << printc "Inner working yields"; printsq rischpart; printc "with derivative"; printsq deriv >> >>; deriv:=!*addsq(expression,negsq deriv); if null numr deriv then return rischpart; % no algebraic part. if null involvesq(deriv,intvar) then return !*addsq(rischpart, !*multsq(deriv,((mksp(intvar,1) .* 1) .+ nil) ./ 1)); % if the difference is merely a constant. varlist:=getvariables deriv; zlist:=findzvars(varlist,list intvar,intvar,nil); varlist:=purge(zlist,varlist); firstterm:=simp!* car zlist; % this may crop up. w:=sqrt2top !*multsq(deriv,invsq !*diffsq(firstterm,intvar)); if null involvesq(w,intvar) then return !*addsq(rischpart,!*multsq(w,firstterm)); if !*noacn then interr "Testing only logarithmic code"; deriv:=transcendentalcase(deriv,intvar,nil,zlist,varlist); return !*addsq(deriv,rischpart) end; symbolic procedure doalggeom(differential); begin scalar reslist,place,placelist, savetaylorasslist,sqrts!-in!-integrand, taylorasslist; placelist:=findpoles(differential,intvar); reslist:=nil; sqrts!-in!-integrand:=sqrtsinsq (differential,intvar); while placelist do << place:=car placelist; placelist:=cdr placelist; savetaylorasslist:=taylorasslist; place:=find!-residue(differential,intvar,place); if place then reslist:=append(place,reslist) else taylorasslist:=savetaylorasslist >>; if reslist then go to serious; if !*tra or !*trmin then printc "No residues => no logs"; return nil ./ 1; serious: placelist:=operateon(reslist,intvar); if placelist eq 'failed then interr "Divisor operations failed"; return placelist end; symbolic procedure algebraic!-divisor(divisor,dof1k); if length dof1k = 1 then lutz!-nagell(divisor) else bound!-torsion(divisor,dof1k); symbolic procedure coates!-multiple(places,mults,v); begin scalar ans; if not atom (ans:=coates(places, for each u in mults collect v*u, intvar)) then << if !*tra or !*trmin then << princ "Divisor has order "; printc v >>; return !*kk2q list('nthroot,mk!*sq ans,v) >> else return ans end; symbolic procedure mazurp(places,dof1k); % Checks to ensure we have an elliptic curve over the rationals. begin % scalar sqrt2,sqrt4,v; % sqrt2:=0; % % Number of SQRTs of things of degree 1 or 2; % sqrt4:=0; % % " " " 3 or 4; % for each u in getsqrtsfromplaces places do << % v:=!*q2f simp u; % if sqrtsinsq(v,intvar) % then return nil; % % Cannot use nested SQRTs; % v:=car stt(v,intvar); % if v < 3 % then if sqrt4>0 % then return nil % else if sqrt2>1 % then return nil % else sqrt2:=iadd1 sqrt2 % else if v < 5 % then if sqrt2>0 or sqrt4>0 % then return nil % else sqrt4:=1 % else return nil >>; scalar answer; if length dof1k neq 1 then return nil; % Genus = # linearly independent differentials of 1st kind; % We know know that it is of genus = 1. answer:=t; while answer and places do if sqrtsintree(basicplace car places,nil,nil) then answer:= nil else places:=cdr places; if null answer then return nil; if !*tra then <<prin2 "*** We can apply Mazur's bound on the torsion of"; prin2t "elliptic curves over the rationals">>; return t end; endmodule; module linrel; % Author: James H. Davenport. symbolic procedure firstlinearrelation(m,n); % Returns vector giving first linear relation between % the rows of n*n matrix m. begin scalar mm,u,uu,v,w,x,xx,i,j,isub1n,ans; isub1n:=isub1 n; mm:=mkvect(isub1n); for i:=0 step 1 until isub1n do putv(mm,i,copyvec(getv(m,i),isub1n)); % mm is a copy of m which we can afford to destroy. ans:=mkidenm isub1n; i:=0; outerloop: u:=getv(mm,i); uu:=getv(ans,i); j:=0; pivotsearch: if j iequal n then goto zerorow; v:=getv(u,j); if null numr v then << j:=iadd1 j; goto pivotsearch >>; % we now use the j-th element of row i to flatten the j-th % element of all later rows. if i iequal isub1n then return nil; %no further rows to flatten, so no relationships. v:=!*invsq negsq v; for k:=iadd1 i step 1 until isub1n do << xx:=getv(ans,k); x:=getv(mm,k); w:=!*multsq(v,getv(x,j)); for l:=0:isub1n do << putv(x,l,addsq(getv(x,l),!*multsq(w,getv(u,l)))); putv(xx,l,addsq(getv(xx,l),!*multsq(w,getv(uu,l)))) >> >>; i:=iadd1 i; if i < n then goto outerloop; % no zero rows found at all. return nil; zerorow: % the i-t row is all zero, i.e. rows 1...i are dependent. return getv(ans,i) end; endmodule; module maninp; % Author: James H. Davenport. fluid '(intvar); symbolic procedure findmaninparm places; begin scalar sqrts,vars,u; sqrts:=sqrtsinplaces places; loop: if null sqrts then return nil; vars:=getvariables simp argof car sqrts; innerloop: if null vars then << sqrts:=cdr sqrts; go to loop >>; u:=car vars; vars:=cdr vars; if u eq intvar then go to innerloop; if atom u then return u; if car u eq 'sqrt then << u:=simp argof u; vars:=varsinsf(numr u,varsinsf(denr u,vars)); go to innerloop >>; interr "Unrecognised differentiation candidate" end; endmodule; module modify; % Author: James H. Davenport. fluid '(intvar); global '(!*tra); exports modify!-sqrts,combine!-sqrts; symbolic procedure modify!-sqrts(basis,sqrtl); begin scalar sqrtl!-in!-sf,n,u,v,f; n:=upbv basis; sqrtl!-in!-sf:=for each u in sqrtl collect !*q2f simp argof u; for i:=0:n do begin u:=getv(basis,i); v:=sqrtsinsq(u,intvar); % We have two tasks to perform, % the replacing of SQRT(A)*SQRT(B) by SQRT(A*B) % where relevant and the replacing of SQRT(A) % by SQRT(A*B) or 1 (depending on whether it occurs in % the numerator or the denominator). v:=purge(sqrtl,v); if null v then go to nochange; u:=sqrt2top u; u:=multsq(modify2(numr u,v,sqrtl!-in!-sf) ./ 1, 1 ./ modify2(denr u,v,sqrtl!-in!-sf)); v:=sqrtsinsq(u,intvar); v:=purge(sqrtl,v); if v then << if !*tra then << printc "Discarding element"; printsq u >>; putv(basis,i,1 ./ 1) >> else putv(basis,i,removecmsq u); f:=t; nochange: end; basis:=mkuniquevect basis; if f and !*tra then << printc "Basis replaced by"; mapvec(basis,function printsq) >>; return basis end; symbolic procedure combine!-sqrts(basis,sqrtl); begin scalar sqrtl!-in!-sf,n,u,v,f; n:=upbv basis; sqrtl!-in!-sf:=for each u in sqrtl collect !*q2f simp argof u; for i:=0:n do begin u:=getv(basis,i); v:=sqrtsinsq(u,intvar); % We have one task to perform, % the replacing of SQRT(A)*SQRT(B) by SQRT(A*B) % where relevant. v:=purge(sqrtl,v); if null v then go to nochange; u:=multsq(modify2(numr u,v,sqrtl!-in!-sf) ./ 1, 1 ./ modify2(denr u,v,sqrtl!-in!-sf)); putv(basis,i,u); f:=t; nochange: end; if f and !*tra then << printc "Basis replaced by"; mapvec(basis,function printsq) >>; return basis end; symbolic procedure modify2(sf,sqrtsin,realsqrts); if atom sf then sf else if atom mvar sf then sf else if eqcar(mvar sf,'sqrt) and dependsp(mvar sf,intvar) then begin scalar u,v,w,lcsf,sqrtsin2,w2,lcsf2,temp; u:=!*q2f simp argof mvar sf; v:=realsqrts; while v and null (w:=modify!-quotf(car v,u)) do v:=cdr v; if null v then << if !*tra then << printc "Unable to modify (postponed)"; printsf !*kk2f mvar sf >>; return sf >>; v:=car v; % We must modify SQRT(U) into SQRT(V) if possible. lcsf:=lc sf; sqrtsin2:=delete(mvar sf,sqrtsin); while sqrtsin2 and (w neq 1) do << temp:=!*q2f simp argof car sqrtsin2; if (w2:=modify!-quotf(w,temp)) and (lcsf2:=modify!-quotf(lcsf,!*kk2f car sqrtsin2)) then << w:=w2; lcsf:=lcsf2 >>; sqrtsin2:=cdr sqrtsin2 >>; if w = 1 then return addf(multf(lcsf,formsqrt v), modify2(red sf,sqrtsin,realsqrts)); % It is important to use FORMSQRT here since % SIMPSQRT will recreate the factorisation % we are trying to destroy. % Satisfactorily explained away. return addf(multf(!*p2f lpow sf, modify2(lc sf,sqrtsin,realsqrts)), modify2(red sf,sqrtsin,realsqrts)) end else addf(multf(!*p2f lpow sf, modify2(lc sf,sqrtsin,realsqrts)), modify2(red sf,sqrtsin,realsqrts)); %symbolic procedure modifydown(sf,sqrtl); %if atom sf % then sf % else if atom mvar sf % then sf % else if eqcar(mvar sf,'sqrt) and % dependsp(mvar sf,intvar) and % not member(!*q2f simp argof mvar sf,sqrtl) % then addf(modifydown(lc sf,sqrtl), % modifydown(red sf,sqrtl)) % else addf(multf(!*p2f lpow sf, % modifydown(lc sf,sqrtl)), % modifydown(red sf,sqrtl)); % symbolic procedure modifyup(sf,sqrtl); % if atom sf % then sf % else if atom mvar sf % then sf % else if eqcar(mvar sf,'sqrt) and % dependsp(mvar sf,intvar) % then begin % scalar u,v; % u:=!*q2f simp argof mvar sf; % if u member sqrtl % then return addf(multf(!*p2f lpow sf, % modifyup(lc sf,sqrtl)), % modifyup(red sf,sqrtl)); % v:=sqrtl; % while v and not modify!-quotf(car v,u) % do v:=cdr v; % if null v % then interr "No sqrt to upgrade to"; % return addf(multf(!*kk2f simpsqrt2 car v, % modifyup(lc sf,sqrtl)), % modifyup(red sf,sqrtl)) % end % else addf(multf(!*p2f lpow sf, % modifyup(lc sf,sqrtl)), % modifyup(red sf,sqrtl)); symbolic procedure modify!-quotf(u,v); % Replacement for quotf, in that it gets sqrts right. if atom v or atom mvar v then quotf(u,v) else if u=v then 1 else begin scalar sq; sq:=sqrt2top(u ./ v); if involvesf(denr sq,intvar) then return nil; if not onep denr sq then if not numberp denr sq then interr "Gauss' lemma violated in modify" else if !*tra then << printc "*** Denominator ignored in modify"; printc denr sq >>; return numr sq end; endmodule; module modlineq; % Author: James H. Davenport. fluid '(current!-modulus sqrts!-mod!-prime); global '(!*tra !*trmin list!-of!-medium!-primes sqrts!-mod!-8); exports check!-lineq; list!-of!-medium!-primes:='(101 103 107 109); sqrts!-mod!-8:=mkvect 7; putv(sqrts!-mod!-8,0,t); putv(sqrts!-mod!-8,1,t); putv(sqrts!-mod!-8,4,t); symbolic procedure modp!-nth!-root(m,n,p); begin scalar j,p2; p2:=p/2; for i:=-p2 step 1 until p2 do if modular!-expt(i,n) iequal m then << j:=i; i:=p2 >>; return j end; symbolic procedure modp!-sqrt(n,p); begin scalar p2,s,tt; p2:=p/2; if n < 0 then n:=n+p; for i:=0:p2 do begin tt:=n+p*i; if null getv(sqrts!-mod!-8,tt irem 8) then return; % mod 8 test for perfect squares. if (iadd1 tt irem 5) > 2 then return; % squares are -1,0,1 mod 5. s:=int!-sqrt tt; if fixp s then << p2:=0; return >> end; if (not fixp s) or null s then return nil else return s end; symbolic procedure subsetp(a,b); %True if all members of a are also members of b. if null a then t else if member(car a,b) then subsetp(cdr a,b) else nil; symbolic procedure check!-lineq(m,rightside); begin scalar vlist,n1,n2,u,primelist,mm,v,modp!-subs,atoms; n1:=upbv m; for i:=0:n1 do << u:=getv(m,i); if u then for j:=0:(n2:=upbv u) do vlist:=varsinsq(getv(u,j),vlist) >>; u:=vlist; while u do << v:=car u; u:=cdr u; if atom v then atoms:=v.atoms else if (car v eq 'sqrt) or (car v eq 'expt) then for each w in varsinsf(!*q2f simp argof v,nil) do if not (w member vlist) then << u:=w.u; vlist:=w.vlist >> else nil else interr "Unexpected item" >>; if sqrts!-mod!-prime and subsetp(vlist,for each u in cdr sqrts!-mod!-prime collect car u) then go to end!-of!-loop; vlist:=purge(atoms,vlist); u:=nil; for each v in vlist do if car v neq 'sqrt then u:=v.u; vlist:=nconc(u,sortsqrts(purge(u,vlist),nil)); % NIL is the variable to measure nesting on: % therefore all nesting is being caught. primelist:=list!-of!-medium!-primes; set!-modulus car primelist; atoms:=for each u in atoms collect u . modular!-number random car primelist; goto try!-prime; next!-prime: primelist:=cdr primelist; if null primelist and !*tra then printc "Ran out of primes in check!-lineq"; if null primelist then return t; set!-modulus car primelist; try!-prime: modp!-subs:=atoms; v:=vlist; loop: if null v then go to end!-of!-loop; u:=modp!-subst(simp argof car v,modp!-subs); if caar v eq 'sqrt then u:=modp!-sqrt(u,car primelist) else if caar v eq 'expt then u:=modp!-nth!-root(modular!-expt(u,cadr caddr car v), caddr caddr car v,car primelist) else interr "Unexpected item"; if null u then go to next!-prime; modp!-subs:=(car v . u) . modp!-subs; v:=cdr v; go to loop; end!-of!-loop: if null primelist then << setmod(car sqrts!-mod!-prime); modp!-subs:=cdr sqrts!-mod!-prime >> else sqrts!-mod!-prime:=(car primelist).modp!-subs; mm:=mkvect n1; for i:=0:n1 do begin u:=getv(m,i); if null u then return; putv(mm,i,v:=mkvect n2); for j:=0:n2 do putv(v,j,modp!-subst(getv(u,j),modp!-subs)) end; v:=mkvect n1; for i:=0:n1 do putv(v,i,modp!-subst(getv(rightside,i),modp!-subs)); u:=mod!-jhdsolve(mm,v); if (u eq 'failed) and (!*tra or !*trmin) then << princ "Proved insoluble mod "; printc car sqrts!-mod!-prime >>; return u end; symbolic procedure modp!-subst(sq,slist); modular!-quotient(modp!-subf(numr sq,slist), modp!-subf(denr sq,slist)); symbolic procedure modp!-subf(sf,slist); if atom sf then if null sf then 0 else modular!-number sf else begin scalar u; u:=assoc(mvar sf,slist); if null u then interr "Unexpected variable"; return modular!-plus(modular!-times(modular!-expt(cdr u,ldeg sf), modp!-subf(lc sf,slist)), modp!-subf(red sf,slist)) end; symbolic procedure mod!-jhdsolve(m,rightside); % Returns answer to m.answer=rightside. % Matrix m not necessarily square. begin scalar n1,n2,ans,u,row,swapflg,swaps; % The SWAPFLG is true if we have changed the order of the % columns and need later to invert this via SWAPS. n1:=upbv m; for i:=0:n1 do if (u:=getv(m,i)) then (n2:=upbv u); swaps:=mkvect n2; for i:=0:n2 do putv(swaps,i,n2-i); % We have the SWAPS vector, which should be a vector of indices, % arranged like this because VECSORT sorts in decreasing order. for i:=0:isub1 n1 do begin scalar k,v,pivot; tryagain: row:=getv(m,i); if null row then go to interchange; % look for a pivot in row. k:=-1; for j:=0:n2 do if not zerop (pivot:=getv(row,j)) then << k:=j; j:=n2 >>; if k neq -1 then goto newrow; if not zerop getv(rightside,i) then << m:='failed; i:=sub1 n1; %Force end of loop. go to finished >>; interchange: % now interchange i and last element. swap(m,i,n1); swap(rightside,i,n1); n1:=isub1 n1; if i iequal n1 then goto finished else goto tryagain; newrow: if i neq k then << swapflg:=t; swap(swaps,i,k); % record what we have done. for l:=0:n1 do swap(getv(m,l),i,k) >>; % place pivot on diagonal. pivot:=modular!-minus modular!-reciprocal pivot; for j:=iadd1 i:n1 do begin u:=getv(m,j); if null u then return; v:=modular!-times(getv(u,i),pivot); if not zerop v then << putv(rightside,j, modular!-plus(getv(rightside,j), modular!-times(v,getv(rightside,i)))); for l:=0:n2 do putv(u,l, modular!-plus(getv(u,l), modular!-times(v,getv(row,l)))) >> end; finished: end; if m eq 'failed then go to failed; % Equations were inconsistent. while null (row:=getv(m,n1)) do n1:=isub1 n1; u:=nil; for i:=0:n2 do if not zerop getv(row,i) then u:='t; if null u then if not zerop getv(rightside,n1) then go to failed else n1:=isub1 n1; % Deals with a last equation which is all zero. if n1 > n2 then go to failed; % Too many equations to satisfy. ans:=mkvect n2; for i:=0:n2 do putv(ans,i,0); % now to do the back-substitution. for i:=n1 step -1 until 0 do begin row:=getv(m,i); if null row then return; u:=getv(rightside,i); for j:=iadd1 i:n2 do u:=modular!-plus(u, modular!-times(getv(row,j),modular!-minus getv(ans,j))); putv(ans,i,modular!-times(u,modular!-reciprocal getv(row,i))) end; if swapflg then vecsort(swaps,list ans); return ans; failed: if !*tra then printc "Unable to force correct zeroes"; return 'failed end; endmodule; module nagell; % Author: James H. Davenport. fluid '(intvar); global '(!*tra !*trmin); exports lutz!-nagell; symbolic procedure lutz!-nagell(divisor); begin scalar ans,places,mults,save!*tra; for each u in divisor do << places:=(car u).places; mults :=(cdr u).mults >>; ans:=lutz!-nagell!-2(places,mults); save!*tra:=!*tra; if !*trmin then !*tra:=nil; ans:=coates!-multiple(places,mults,ans); !*tra:=save!*tra; return ans end; symbolic procedure lutz!-nagell!-2(places,mults); begin scalar wst,x,y,equation,point,a; wst:=weierstrass!-form getsqrtsfromplaces places; x:=car wst; y:=cadr wst; equation:=caddr wst; equation:=!*q2f !*multsq(equation,equation); equation:=makemainvar(equation,intvar); if ldeg equation = 3 then equation:=red equation else interr "Equation not of correct form"; if mvar equation eq intvar then if ldeg equation = 1 then << a:=(lc equation) ./ 1; equation:=red equation >> else interr "Equation should not have a x**2 term" else a:=nil ./ 1; equation:= a . (equation ./ 1); places:=for each u in places collect wst!-convert(u,x,y); point:=elliptic!-sum(places,mults,equation); a:=lutz!-nagell!-bound(point,equation); if !*tra or !*trmin then << princ "Point actually is of order "; printc a >>; return a end; symbolic procedure wst!-convert(place,x,y); begin x:=subzero(xsubstitutesq(x,place),intvar); y:=subzero(xsubstitutesq(y,place),intvar); return x.y end; symbolic procedure elliptic!-sum(places,mults,equation); begin scalar point; point:=elliptic!-multiply(car places,car mults,equation); places:=cdr places; mults:=cdr mults; while places do << point:=elliptic!-add(point, elliptic!-multiply(car places,car mults, equation), equation); places:=cdr places; mults:=cdr mults >>; return point end; symbolic procedure elliptic!-multiply(point,n,equation); if n < 0 then elliptic!-multiply( (car point) . (negsq cdr point), -n, equation) else if n = 0 then interr "N=0 in elliptic!-multiply" else if n = 1 then point else begin scalar q,r; q:=divide(n,2); r:=cdr q; q:=car q; q:=elliptic!-multiply(elliptic!-add(point,point,equation),q, equation); if r = 0 then return q else return elliptic!-add(point,q,equation) end; symbolic procedure elliptic!-add(p1,p2,equation); begin scalar x1,x2,y1,y2,x3,y3,inf,a,b,lhs,rhs; a:=car equation; b:=cdr equation; inf:=!*kk2q 'infinity; x1:=car p1; y1:=cdr p1; x2:=car p2; y2:=cdr p2; if x1 = x2 then if y1 = y2 then << % this is the doubling case. x3:=!*multsq(!*addsq(!*addsq(!*multsq(a,a), !*exptsq(x1,4)), !*addsq(multsq(-8 ./ 1,!*multsq(x1,b)), !*multsq(!*multsq(x1,x1), multsq(-2 ./ 1,a)))), !*invsq multsq(4 ./ 1, !*addsq(b,!*multsq(x1,!*addsq(a, !*exptsq(x1,2)))))); y3:=!*addsq(y1,!*multsq(!*multsq(!*addsq(x3,negsq x1), !*addsq(a,multsq(3 ./ 1, !*multsq(x1,x1)))), !*invsq multsq(2 ./ 1, y1))) >> else x3:=(y3:=inf) else if x1 = inf then << x3:=x2; y3:=y2 >> else if x2 = inf then << x3:=x1; y3:=y1 >> else << x3:=!*multsq(!*addsq(!*multsq(a,!*addsq(x1,x2)), !*addsq(multsq(2 ./ 1,b), !*addsq(!*multsq(!*multsq(x1,x2), !*addsq(x1,x2)), multsq(-2 ./ 1, !*multsq(y1,y2))))), !*invsq !*exptsq(!*addsq(x1,negsq x2),2)); y3:=!*multsq(!*addsq(!*multsq(!*addsq(y2,negsq y1),x3), !*addsq(!*multsq(x2,y1), !*multsq(x1,negsq y2))), !*invsq !*addsq(x1,negsq x2)) >>; if x3 = inf then return x3.y3; lhs:=!*multsq(y3,y3); rhs:=!*addsq(b,!*multsq(x3,!*addsq(a,!*multsq(x3,x3)))); if numr !*addsq(lhs,negsq rhs) % We can't just compare them % since they're algebraic numbers. % JHD Jan 14th. 1987. then << prin2t "Point defined by X and Y as follows:"; printsq x3; printsq y3; prin2t "on the curve defined by A and B as follows:"; printsq a; printsq b; prin2t "gives a consistency check between:"; printsq lhs; printsq rhs; interr "Consistency check failed in elliptic!-add" >>; return x3.y3 end; symbolic procedure infinitep u; kernp u and (mvar numr u eq 'infinite); symbolic procedure lutz!-nagell!-bound(point,equation); begin scalar x,y,a,b,lutz!-alist,n,point2,p,l,ans; % THE LUTZ!-ALIST is an association list of elements of the form % [X-value].([Y-value].[value of N for this point]) % See thesis, chapter 7, algorithm LUTZ!-NAGELL, step [1]. x:=car point; y:=cdr point; if !*tra or !*trmin then << printc "Point to have torsion investigated is"; printsq x; printsq y >>; a:=car equation; b:=cdr equation; if denr y neq 1 then << l:=denr y; % we can in fact make l an item whose cube is > denr y. y:=!*multsq(y,!*exptf(l,3) ./ 1); x:=!*multsq(x,!*exptf(l,2) ./ 1); a:=!*multsq(a,!*exptf(l,4) ./ 1); b:=!*multsq(b,!*exptf(l,6) ./ 1) >>; if denr x neq 1 then << l:=denr x; % we can in fact make l an item whose square is > denr x. y:=!*multsq(y,!*exptf(l,3) ./ 1); x:=!*multsq(x,!*exptf(l,2) ./ 1); a:=!*multsq(a,!*exptf(l,4) ./ 1); b:=!*multsq(b,!*exptf(l,6) ./ 1) >>; % we now have integral co-ordinates for x,y. lutz!-alist:=list (x . (y . 0)); if (x neq car point) and (!*tra or !*trmin) then << printc "Point made integral as "; printsq x; printsq y; printc "on the curve with coefficients"; printsq a; printsq b >>; point:=x.y; equation:=a.b; n:=0; loop: n:=n+1; point2:=elliptic!-multiply(x.y,2,equation); x:=car point2; y:=cdr point2; if infinitep x then return 2**n; if denr x neq 1 then go to special!-denr; if a:=assoc(x,lutz!-alist) then if y = cadr a then return (ans:=lutz!-reduce(point,equation,2**n-2**(cddr a))) else if null numr !*addsq(y,cadr a) then return (ans:=lutz!-reduce(point,equation,2**n+2**(cddr a))) else interr "Cannot have 3 points here"; lutz!-alist:=(x.(y.n)).lutz!-alist; if ans then return ans; go to loop; special!-denr: p:=denr x; if not jhd!-primep p then return 'infinite; n:=1; n:=1; loop2: point:=elliptic!-multiply(point,p,equation); n:=n*p; if infinitep car point then return n; if quotf(p,denr car point) then go to loop2; return 'infinite end; symbolic procedure lutz!-reduce(point,equation,power); begin scalar n; if !*tra or !*trmin then << princ "Point is of order dividing "; printc power >>; n:=1; while evenp power do << power:=power/2; n:=n*2; point:=elliptic!-add(point,point,equation) >>; % we know that all the powers of 2 must appear in the answer. if power = 1 then return n; if jhd!-primep power then return n*power; return n*lutz!-reduce2(point,equation,power,3) end; symbolic procedure lutz!-reduce2(point,equation,power,prime); if power = 1 then if infinitep car point then 1 else nil else if infinitep car point then power else begin scalar n,prime2,u,ans; n:=0; while zerop cdr divide(power,prime) do << n:=n+1; power:=power/prime >>; prime2:=nextprime prime; for i:=0:n do << u:=lutz!-reduce2(point,equation,power,prime2); if u then << ans:=u*prime**i; i:=n >> else << power:=power*prime; point:=elliptic!-multiply(point,prime,equation) >> >>; if ans then return ans else return nil end; endmodule; module nbasis; % Author: James H. Davenport. fluid '(nestedsqrts sqrt!-intvar taylorasslist); global '(!*tra); exports normalbasis; imports substitutesq,taylorform,printsq,newplace,sqrtsinsq,union, sqrtsign,interr,vecsort,mapvec,firstlinearrelation,mksp,multsq, !*multsq,addsq,removecmsq,antisubs,involvesq; symbolic procedure normalbasis(zbasis,x,infdegree); begin scalar n,nestedsqrts,sqrts,u,v,w,li,m,lam,i,inf,basis,save; save:=taylorasslist; inf:=list list(x,'quotient,1,x); n:=upbv zbasis; basis:=mkvect n; lam:=mkvect n; m:=mkvect n; goto a; square: sqrts:=nil; inf:=append(inf,list list(x,'expt,x,2)); % we were in danger of getting sqrt(x) where we didnt want it. a: newplace(inf); for i:=0:n do << v:=substitutesq(getv(zbasis,i),inf); putv(basis,i,v); sqrts:=union(sqrts,sqrtsinsq(v,x)) >>; if !*tra then << princ "Normal integral basis reduction with the"; printc " following sqrts lying over infinity:"; superprint sqrts >>; if member(list('sqrt,x),sqrts) then goto square; sqrts:=sqrtsign(sqrts,x); if iadd1 n neq length sqrts then interr "Length mismatch in normalbasis"; for i:=0:n do << v:=cl8roweval(getv(basis,i),sqrts); putv(m,i,cdr v); putv(lam,i,car v) >>; reductionloop: vecsort(lam,list(basis,m)); if !*tra then << printc "Matrix before a reduction step at infinity is:"; mapvec(m,function printc) >>; v:=firstlinearrelation(m,iadd1 n); if null v then goto ret; i:=n; while null numr getv(v,i) do i:=isub1 i; li:=getv(lam,i); w:=nil ./ 1; for j:=0:i do w:=addsq(w,!*multsq(getv(basis,j), multsq(getv(v,j),1 ./ !*fmksp(x,-li+getv(lam,j)) ))); % note the change of sign. my x is coates 1/x at this point!. if !*tra then << princ "Element "; princ i; printc " replaced by the function printed below:" >>; w:=removecmsq w; putv(basis,i,w); w:=cl8roweval(w,sqrts); if car w <= li then interr "Normal basis reduction did not work"; putv(lam,i,car w); putv(m,i,cdr w); goto reductionloop; ret: newplace list (x.x); u:= 1 ./ !*p2f mksp(x,1); inf:=antisubs(inf,x); u:=substitutesq(u,inf); m:=nil; for i:=0:n do begin v:=getv(lam,i)-infdegree; if v < 0 then goto next; w:=substitutesq(getv(basis,i),inf); for j:=0:v do << if not involvesq(w,sqrt!-intvar) then m:=w.m; w:=!*multsq(w,u) >>; next: end; tayshorten save; return m end; symbolic procedure !*fmksp(x,i); % sf for x**i. if i iequal 0 then 1 else !*p2f mksp(x,i); symbolic procedure cl8roweval(basiselement,sqrts); begin scalar lam,row,i,v,minimum,n; n:=isub1 length sqrts; lam:=mkvect n; row:=mkvect n; i:=0; minimum:=1000000; while sqrts do << v:=taylorform substitutesq(basiselement,car sqrts); v:=assoc(taylorfirst v,taylorlist v); putv(row,i,cdr v); v:=car v; putv(lam,i,v); if v < minimum then minimum:=v; i:=iadd1 i; sqrts:=cdr sqrts >>; if !*tra then << princ "Evaluating "; printsq basiselement; printc lam; printc row >>; v:=1000000; for i:=0:n do << v:=getv(lam,i); if v > minimum then putv(row,i,nil ./ 1) >>; return minimum.row end; endmodule; module places; % Author: James H. Davenport. fluid '(basic!-listofallsqrts basic!-listofnewsqrts intvar listofallsqrts listofnewsqrts sqrt!-intvar sqrt!-places!-alist sqrts!-in!-integrand); exports getsqrtsfromplaces,sqrtsinplaces,get!-correct!-sqrts,basicplace, extenplace,equalplace,printplace; % Function to manipulate places % a place is stored as a list of substitutions % substitutions (x.f(x)) define the algrbraic number % of which this place is an extension, % while places (f(x).g(x)) define the extension. % currently g(x( is list ('minus,f(x)) % or similar,e.g. (sqrt(sqrt x)).(sqrt(-sqrt x)). % Given a list of places, produces a list of all % the SQRTs in it that depend on INTVAR. symbolic procedure getsqrtsfromplaces places; % The following loop finds all the SQRTs for a basis, % taking account of BASICPLACEs. begin scalar basis,v,b,c,vv; for each u in places do << v:=antisubs(basicplace u,intvar); vv:=sqrtsinsq (substitutesq(!*kk2q intvar,v),intvar); % We must go via SUBSTITUTESQ to get parallel % substitutions performed correctly. if vv then vv:=simp argof car vv; for each w in extenplace u do << b:=substitutesq(simp lsubs w,v); b:=delete(sqrt!-intvar,sqrtsinsq(b,intvar)); for each u in b do for each v in delete(u,b) do if dependsp(v,u) then b:=delete(u,b); % remove all the "inner" items, since they will % be accounted for anyway. if length b iequal 1 then b:=car b else b:=mvar numr simpsqrtsq mapply(function !*multsq, for each u in b collect simp argof u); if vv and not (b member sqrts!-in!-integrand) then << c:=numr multsq(simp argof b,vv); c:=car sqrtsinsf(simpsqrt2 c,nil,intvar); if c member sqrts!-in!-integrand then b:=c >>; if not (b member basis) then basis:=b.basis >> >>; % The following loop deals with the annoying case of, say, % (X DIFFERENCE X 1) (X EXPT X 2) which should give rise to % SQRT(X-1). for each u in places do begin v:=cdr u; if null v or (car rfirstsubs v neq 'expt) then return; u:=simp!* subst(list('minus,intvar),intvar,rfirstsubs u); while v and (car rfirstsubs v eq 'expt) do << u:=simpsqrtsq u; v:=cdr v; basis:=union(basis,delete(sqrt!-intvar,sqrtsinsq(u,intvar))) >> end; return remove!-extra!-sqrts basis end; symbolic procedure sqrtsinplaces u; % Note the difference between this procedure and % the previous one: this one does not take account % of the BASICPLACE component (& is pretty useless). if null u then nil else sqrtsintree(for each v in car u collect lsubs v, intvar, sqrtsinplaces cdr u); %symbolic procedure placesindiv places; % Given a list of places (i.e. a divisor), % produces a list of all the SQRTs on which the places % explicitly depend. %begin scalar v; % for each u in places do % for each uu in u do % if not (lsubs uu member v) % then v:=(lsubs uu) . v; % return v % end; symbolic procedure get!-correct!-sqrts u; % u is a basicplace. begin scalar v; v:=assoc(u,sqrt!-places!-alist); if v then << v:=cdr v; listofallsqrts:=cdr v; listofnewsqrts:=car v >> else << listofnewsqrts:=basic!-listofnewsqrts; listofallsqrts:=basic!-listofallsqrts >>; return nil end; %symbolic procedure change!-place(old,new); %% old and new are basicplaces; %begin % scalar v; % v:=assoc(new,sqrt!-places!-alist); % if v % then sqrtsave(cddr v,cadr v,old) % else << % listofnewsqrts:=basic!-listofnewsqrts; % listofallsqrts:=basic!-listofallsqrts % >>; % return nil % end; symbolic procedure basicplace(u); % Returns the basic part of a place. if null u then nil else if atom caar u then (car u).basicplace cdr u else nil; symbolic procedure extenplace(u); % Returns the extension part of a place. if u and atom caar u then extenplace cdr u else u; symbolic procedure equalplace(a,b); % Sees if two extension places represent the same place or not. if null a then if null b then t else nil else if null b then nil else if member(car a,b) then equalplace(cdr a,delete(car a,b)) else nil; symbolic procedure remove!-extra!-sqrts basis; begin scalar basis2,save; save:=basis2:=for each u in basis collect !*q2f simp argof u; for each u in basis2 do for each v in delete(u,basis2) do if quotf(v,u) then basis2:=delete(v,basis2); if basis2 eq save then return basis else return for each u in basis2 collect list('sqrt,prepf u) end; symbolic procedure printplace u; begin scalar a,n,v; a:=rfirstsubs u; princ (v:=lfirstsubs u); princ "="; if atom a then princ "0" else if (car a eq 'quotient) and (cadr a=1) then princ "infinity" else << n:=negsq addsq(!*kk2q v,negsq simp!* a); % NEGSQ added JHD 22.3.87 - the previous value was wrong. % If the substitution is (X-v) then this takes -v to 0, % so the place was at -v. if (numberp numr n) and (numberp denr n) then << princ numr n; if not onep denr n then << princ " / "; princ denr n >> >> else << if degreein(numr n,intvar) > 1 then printc "Any root of:"; printsq n; if cdr u then princ "at the place " >> >>; u:=cdr u; if null u then goto nl!-return; n:=1; while u and (car rfirstsubs u eq 'expt) do << n:=n * caddr rfirstsubs u; u:=cdr u >>; if n neq 1 then << terpri!* nil; prin2 " "; princ v; princ "=>"; princ v; princ "**"; princ n >>; while u do << if car rfirstsubs u eq 'minus then princ "-" else princ "+"; u:=cdr u >>; nl!-return: terpri(); return end; symbolic procedure degreein(sf,var); if atom sf then 0 else if mvar sf eq var then ldeg sf else max(degreein(lc sf,var),degreein(red sf,var)); endmodule; module precoats; % Author: James H. Davenport. fluid '(basic!-listofallsqrts basic!-listofnewsqrts sqrt!-intvar taylorvariable thisplace); global '(!*tra); exports precoates; imports mksp,algint!-subf,subzero2,substitutesq,removeduplicates, printsq,basicplace,extenplace,interr,get!-correct!-sqrts, printplace,simptimes,subzero,negsq,addsq,involvesq,taylorform, taylorevaluate,mk!*sq,!*exptsq,!*multsq,!*invsq,sqrt2top, jfactor,sqrtsave,antisubs; symbolic procedure infsubs(w); if caar w = thisplace then (cdar w).(cdr w) else (thisplace.(car w)).(cdr w); % thisplace is (z quotient 1 z) so we are moving to infinity. symbolic procedure precoates(residues,x,movedtoinfinity); begin scalar answer,placeval,reslist,placelist,placelist2,thisplace; reslist:=residues; placelist:=nil; while reslist do << % car reslist = <substitution list>.<value>; placeval:=algint!-subf((mksp(x,1) .* 1) .+ nil,caar reslist); if 0 neq cdar reslist then if null numr subzero2(denr placeval,x) then << if null answer then answer:='infinity else if answer eq 'finite then answer:='mixed; if !*tra then printc "We have an residue at infinity" >> else << if null answer then answer:='finite else if answer eq 'infinity then answer:='mixed; placelist:=placeval.placelist; if !*tra then printc "This is a finite residue" >>; reslist:=cdr reslist >>; if answer eq 'mixed then return answer; if answer eq 'infinity then << thisplace:=list(x,'quotient,1,x); % maps x to 1/x. answer:=precoates(for each u in residues collect infsubs u,x,t); % derivative of 1/x is -1/x**2. if atom answer then return answer else return substitutesq(answer,list(thisplace)) >>; placelist2:=removeduplicates placelist; answer := 1 ./ 1; % the null divisor. if !*tra then << printc "The divisor has elements at:"; mapcar(placelist2,function printsq) >>; while placelist2 do begin scalar placelist3,extrasubs,u,bplace; % loop over all distinct places. reslist:=residues; placelist3:=placelist; placeval:=nil; while reslist do << if car placelist2 = car placelist3 then << placeval:=(cdar reslist).placeval; thisplace:= caar reslist; % the substitutions defining car placelist. u:=caar reslist; bplace:=basicplace u; u:=extenplace u; extrasubs:=u.extrasubs >>; reslist:=cdr reslist; placelist3:=cdr placelist3 >>; % placeval is a list of all the residues at this place. if !*tra then << princ "List of multiplicities at this place:"; printc placeval; princ "with substitutions:"; superprint extrasubs >>; if 0 neq mapply(function plus2,placeval) then interr "Divisor not effective"; get!-correct!-sqrts bplace; u:=pbuild(x,extrasubs,placeval); sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,bplace); if atom u then << placelist2:=nil; % set to terminate loop. answer:=u >> else << answer:=substitutesq(!*multsq(answer,u),antisubs(thisplace,x)); placelist2:=cdr placelist2 >> end; % loaded in pbuild to check for poles at the correct places. return answer end; symbolic procedure dlist(u); % Given a list of lists,converts to a list. if null u then nil else if null car u then dlist cdr u else append(car u,dlist cdr u); symbolic procedure debranch(extrasubs,reslist); begin scalar substlist; % remove spurious substitutions. for each u in dlist extrasubs do if not ((car u) member substlist) then substlist:=(car u).substlist; % substlist is a list of all the possible substitutions). while substlist do begin scalar tsqrt,usqrt; scalar with1,with2,without1,without2,wres; scalar a1,a2,b1,b2; % decide if tsqrt is redundant. tsqrt:=car substlist; substlist:=cdr substlist; wres:=reslist; for each place in extrasubs do << usqrt:=assoc(tsqrt,place); % usqrt is s.s' or s.(minus s'). if null usqrt then interr "Places not all there"; if cadr usqrt eq 'sqrt then<< with2:=(car wres).with2; with1:=delete(usqrt,place).with1>> else<< if not (cadr usqrt eq 'minus) then interr "Ramification format error"; without2:=(car wres).without2; without1:=delete(usqrt,place).without1 >>; wres:=cdr wres>>; % first see if one item appears passim. if null with1 then go to itswithout; if null without1 then go to itswith; % Now must see if WITH2 matches WITHOUT2 in order WITH1/WITHOUT1. a1:=with1; a2:=with2; outerloop: b1:=without1; b2:=without2; innerloop: if (car a1) = (car b1) then << if (car a2) neq (car b2) then return; else go to outeriterate >>; b1:=cdr b1; b2:=cdr b2; if null b1 then return else go to innerloop; % null b1 => lists do not match at all. outeriterate: a1:=cdr a1; a2:=cdr a2; if a1 then go to outerloop; if !*tra then << princ "Residues reduce to:"; printc without2; printc "at "; mapc(without1,function printplace) >>; extrasubs:=without1; reslist:=without2; return; itswithout: % everything is in the "without" list. with1:=without1; with2:=without2; itswith: % remove usqrt from the with lists. extrasubs:=for each u in with1 collect delete(assoc(tsqrt,u),u); if !*tra then << printc "The following appears throughout the list "; printc tsqrt >>; reslist:=with2 end; return extrasubs.reslist end; symbolic procedure pbuild(x,extrasubs,placeval); begin scalar multivals,u,v,answer; u:=debranch(extrasubs,placeval); extrasubs:=car u; placeval:=cdr u; % remove spurious entries. if (length car extrasubs) > 1 then return 'difficult; % hard cases not allowed for. multivals:=mapcar(dlist extrasubs,function car); u:=simptimes removeduplicates multivals; answer:= 1 ./ 1; while extrasubs do << v:=substitutesq(u,car extrasubs); v:=addsq(u,negsq subzero(v,x)); v:=mkord1(v,x); if !*tra then << princ "Required component is "; printsq v >>; answer:=!*multsq(answer,!*exptsq(v,car placeval)); % place introduced with correct multiplicity. extrasubs:=cdr extrasubs; placeval:=cdr placeval >>; if length jfactor(denr sqrt2top !*invsq answer,x) > 1 then return 'many!-poles else return answer end; symbolic procedure findord(v,x); begin scalar nord,vd; %given v(x) with v(0)=0, makes v'(0) nonzero. nord:=0; taylorvariable:=x; while involvesq(v,sqrt!-intvar) do v:=substitutesq(v,list(x.list('expt,x,2))); vd:=taylorform v; loop: nord:=nord+1; if null numr taylorevaluate(vd,nord) then go to loop; return nord end; symbolic procedure mkord1(v,x); begin scalar nord; nord:=findord(v,x); if nord iequal 1 then return v; if !*tra then << princ "Order reduction: "; printsq v; princ "from order "; princ nord; printc " to order 1" >>; % Note that here we do not need to simplify, since SIMPLOG will % remove all these SQRTs or EXPTs later. return !*p2q mksp(list('nthroot,mk!*sq v,nord),1) end; endmodule; module primes; % Author: James H. Davenport. exports nextprime,jhd!-primep; symbolic procedure nextprime p; % Returns the next prime number bigger than p. if p=0 then 1 else if p=1 then 2 else begin if evenp p then p:=p+1 else p:=p+2; test: if jhd!-primep p then return p; p:=p+2; go to test end; symbolic procedure jhd!-primep p; if p < 4 then t else if evenp p then nil else begin scalar n; n:=3; %trial factor. top: if n*n>p then return t else if remainder(p,n)=0 then return nil; n:=n+2; go to top end; endmodule; module removecm; % Routines to remove constant factors from expresions. % Author: James H. Davenport. fluid '(intvar); % New improved REMOVECOMMOMMULTIPLES routines. % These routines replace a straightforward pair with GCDF instead of % CMGCDF and its associates. The saving is large in complicated % expressions (in the "general point of order 7" calculations, they % exceeded 90% in some cases, being 1.5 secs as opposed to > 15 secs.). % They are about 1K larger, but this seems a small price to pay. exports removecmsq,removeconstantsf; imports ordop,addf,gcdn,gcdf,gcdk,involvesf,dependsp,makemainvar,quotf; symbolic procedure removecmsq sq; (removecmsf numr sq) ./ (removecmsf denr sq); symbolic procedure removecmsf sf; if atom sf or not ordop(mvar sf,intvar) or not involvesf(sf,intvar) then if sf then 1 else nil else if null red sf then if dependsp(mvar sf,intvar) then (lpow sf .* removecmsf lc sf) .+ nil else removecmsf lc sf else begin scalar u,v; % The general principle here is to find a (non-INTVAR-depending) % coefficient of a purely INTVAR-depending monomial, and then % perform a g.c.d. to discover that factor of this which is a CM. u:=sf; while (v:=involvesf(u,intvar)) do u:=lc makemainvar(u,v); if u iequal 1 then return sf; return quotf(sf,cmgcdf(sf,u)) end; symbolic procedure cmgcdf(sf,u); if numberp u then if atom sf then if null sf then u else gcdn(sf,u) else if u = 1 then 1 else cmgcdf(red sf,cmgcdf(lc sf,u)) else if atom sf then gcdf(sf,u) else if mvar u eq mvar sf then if ordop(intvar,mvar u) then gcdf(sf,u) else cmgcdf2(sf,u) else if ordop(mvar sf,mvar u) then cmgcdf(red sf,cmgcdf(lc sf,u)) else cmgcdf(u,sf); symbolic procedure remove!-maxdeg(sf,var); if atom sf then 0 else if mvar sf eq var then ldeg sf else if ordop(var,mvar sf) then 0 else max(remove!-maxdeg(lc sf,var),remove!-maxdeg(red sf,var)); symbolic procedure cmgcdf2(sf,u); % SF and U have the same MVAR, but INTVAR comes somewhere % down in SF. Therefore we can do better than a straight % GCDK, or even a straight MAKEMAINVAR. begin scalar n; n:=remove!-maxdeg(sf,intvar); if n = 0 then return gcdf(sf,u); % Doesn't actually depend on INTVAR. loop: if u = 1 then return 1; u:=gcdf(u,collectterms(sf,intvar,n)); n:=isub1 n; if n < 0 then return u else go loop end; symbolic procedure collectterms(sf,var,n); if atom sf then if n = 0 then sf else nil else if mvar sf eq var then if ldeg sf = n then lc sf else if ldeg sf > n then collectterms(red sf,var,n) else nil else if ordop(var,mvar sf) then if n = 0 then sf else nil else begin scalar v,w; v:=collectterms(lc sf,var,n); w:=collectterms(red sf,var,n); if null v then return w else return addf(w,(lpow sf .* v) .+ nil) end; symbolic procedure removeconstantsf sf; % Very simple version for now. begin scalar u; if null sf then return nil else if atom sf then return 1; while (null red sf) and (remove!-constantp mvar sf) do sf:=lc sf; u:=remove!-const!-content sf; if u = 1 then return sf else return quotf!*(sf,u) end; symbolic procedure remove!-constantp pf; if numberp pf then t else if atom pf then nil else if car pf eq 'sqrt then remove!-constantp argof pf else if (car pf eq 'expt) or (car pf eq 'quotient) then (remove!-constantp argof pf) and (remove!-constantp caddr pf) else nil; symbolic procedure remove!-const!-content sf; if numberp sf then sf else if null red sf then if remove!-constantp mvar sf then (lpow sf .* remove!-const!-content lc sf) .+ nil else remove!-const!-content lc sf else begin scalar u; u:=remove!-const!-content lc sf; if u = 1 then return u; return gcdf(u,remove!-const!-content red sf) end; endmodule; module sqfrnorm; % Author: James H. Davenport. fluid '(!*pvar listofallsqrts); global '(modevalcount); modevalcount:=1; exports sqfr!-norm2,res!-sqrt; %symbolic procedure resultant(u,v); %begin % scalar maxdeg,zeroes,ldegu,ldegv,m; % % we can have gone makemainvar on u and v; % ldegu:=ldeg u; % ldegv:=ldeg v; % maxdeg:=isub1 max2(ldegu,ldegv); % zeroes:=nlist(nil,maxdeg); % u:=remake(u,mvar u,ldegu); % v:=remake(v,mvar v,ldegv); % m:=nil; % ldegu:=isub1 ldegu; % ldegv:=isub1 ldegv; % for i:=0 step 1 until ldegv do % m:=append(ncdr(zeroes,maxdeg-ldegv+i), % append(u,ncdr(zeroes,maxdeg-i))).m; % for i:=0 step 1 until ldegu do % m:=append(ncdr(zeroes,maxdeg-ldegu+i), % append(v,ncdr(zeroes,maxdeg-i))).m; % return detqf m % end; %symbolic procedure remake(u,v,w); %% remakes u into a list of sf's representing its coefficients; %if w iequal 0 then list u % else if (pairp u) and (mvar u eq v) and (ldeg u iequal w) % then (lc u).remake(red u,v,isub1 w) % else (nil ).remake( u,v,isub1 w); %fluid '(n); %needed for the mapcar; %symbolic procedure detqf u; % %u is a square matrix standard form. %% %value is the determinant of u. %% %algorithm is expansion by minors of first row/column; % begin integer n; % scalar x,y,z; % if length u neq length car u then rederr "Non square matrix" % else if null cdr u then return caar u; % if length u < 3 % then go to noopt; % % try to remove a row with only one non-zero in it; % z:=1; % x:=u; % loop: % n:=posnnonnull car x; % if n eq t % then return nil; % % special test for all null; % if n then << % y:=nth(car x,n); % % next line is equivalent to: %% onne of n,z is even; % if evenp (n+z-1) % then y:=negf y; % u:=remove(u,z); % return !*multf(y,detqf remove2 u) >>; % x:=cdr x; % z:=z+1; % if x % then go to loop; % noopt: % x := u; % n := 1; %number of current row/column; % z := nil; % if nonnull car u < nonnullcar u % then go to row!-expand; % u:=mapcar(u,function cdr); % a: if null x then return z; % y := caar x; % if null y then go to b % else if evenp n then y := negf y; % z := addf(!*multf(y,detqf remove(u,n)),z); % b: x := cdr x; % n := iadd1 n; % go to a; % row!-expand: % u:=cdr u; % x:=car x; % aa: % if null x then return z; % y:=car x; % if null y % then go to bb % else if evenp n then y:=negf y; % z:=addf(!*multf(y,detqf remove2 u),z); % bb: % x:=cdr x; % n:=iadd1 n; % go to aa % end; % % %symbolic procedure remove2 u; %mapcar(u,function (lambda x; % remove(x,n))); % %unfluid '(n); % %symbolic procedure nonnull u; %if null u % then 0 % else if null car u % then nonnull cdr u % else iadd1 (nonnull cdr u); % % %symbolic procedure nonnullcar u; %if null u % then 0 % else if null caar u % then nonnullcar cdr u % else iadd1 (nonnullcar cdr u); % % % %symbolic procedure posnnonnull u; %% returns t if u has no non-null elements %% nil if more than one %% else position of the first; %begin % scalar n,x; % n:=1; %loop: % if null u % then return % if x % then x % else t; % if car u % then if x % then return nil % else x:=n; % n:=iadd1 n; % u:=cdr u; % go to loop % end; symbolic procedure res!-sqrt(u,a); % Evaluates resultant of u ( as a poly in its mvar) and x**-a. begin scalar x,n,v,k,l; x:=mvar u; n:=ldeg u; n:=quotient(n,2); v:=mkvect n; putv(v,0,1); for i:=1:n do putv(v,i,!*multf(a,getv(v,i-1))); % now substitute for x**2 in u leaving k*x+l. k:=l:=nil; while u do if mvar u neq x then << l:=addf(l,u); u:=nil >> else << if evenp ldeg u then l:=addf(l,!*multf(lc u,getv(v,(ldeg u)/2))) else k:=addf(k,!*multf(lc u,getv(v,(ldeg u -1)/2))); u:=red u >>; % now have k*x+l,x**2-a, giving l*l-a*k*k. return addf(!*multf(l,l),!*multf(negf a,multf(k,k))) end; symbolic procedure sqfr!-norm2 (f,mvarf,a); begin scalar u,w,aa,ff,resfn; resfn:='resultant; if eqcar(a,'sqrt) then << resfn:='res!-sqrt; aa:=!*q2f simp argof a >> else rederr "Norms over transcendental extensions"; f:=pvarsub(f,a,'! gerbil); w:=nil; if involvesf(f,'! gerbil) then goto l1; increase: w:=addf(w,!*p2f mksp(a,1)); f:=!*q2f algint!-subf(f,list(mvarf . list('plus,mvarf, list('minus,'! gerbil)))); l1: u:=apply(resfn,list(makemainvar(f,'! gerbil),aa)); ff:=nsqfrp(u,mvarf); if ff then go to increase; f:=!*q2f algint!-subf(f,list('! gerbil.a)); % cannot use pvarsub since want to squash higher powers. return list(u,w,f) end; symbolic procedure nsqfrp(u,v); begin scalar w; w:=modeval(u,v); if w eq 'failed then go to normal; if atom w then go to normal; if ldegvar(w,v) neq ldegvar(u,v) then go to normal; % printc "Modular image is:"; % printsf w; w:=gcdf(w,partialdiff(w,v)); % printc "Answer is:"; % printsf w; if w iequal 1 then return nil; normal; w:=gcdf(u,partialdiff(u,v)); if involvesf(w,v) then return w else return nil end; symbolic procedure ldegvar(u,v); if atom u then 0 else if mvar u eq v then ldeg u else if ordop(v,mvar u) then 0 else max2(ldegvar(lc u,v),ldegvar(red u,v)); symbolic procedure modeval(u,v); if atom u then u else if v eq mvar u then begin scalar w,x; w:=modeval(lc u,v); if w eq 'failed then return w; x:=modeval(red u,v); if x eq 'failed then return x; if null w then return x else return (lpow u .* w) .+ x end else begin scalar w,x; x:=mvar u; if not atom x then if dependsp(x,v) then return 'failed; x:=modevalvar x; if x eq 'failed then return x; w:=modeval(lc u,v); if w eq 'failed then return w; if x then w:=multf(w,exptf(x,ldeg u)); x:=modeval(red u,v); if x eq 'failed then return x; return addf(w,x) end; symbolic procedure modevalvar v; begin scalar w,x; if not atom v then go to alg; w:=get(v,'modvalue); if w then return w; put(v,'modvalue,modevalcount); modevalcount:=modevalcount+1; return modevalcount-1; alg: if car v neq 'sqrt then rederr "Unexpected algebraic"; if numberp argof v then return (mksp(v,1) .* 1) .+ nil; w:=modeval(!*q2f simp argof v,!*pvar); w:=assoc(w,listofallsqrts); % the variable does not matter, since we know that it does not depend. if w then return cdr w else return 'failed end; % unglobal '(modevalcount); endmodule; module substns; % Author: James H. Davenport. exports xsubstitutep,xsubstitutesq,substitutevec,substitutesq,subzero, subzero2,pvarsub; symbolic procedure xsubstitutep(pf,slist); simp xsubstitutep2(pf,slist); symbolic procedure xsubstitutep2(pf,slist); if null slist then pf else xsubstitutep2(subst(rfirstsubs slist, lfirstsubs slist, pf), cdr slist); symbolic procedure xsubstitutesq(sq,slist); substitutesq(substitutesq(sq,basicplace slist),extenplace slist); symbolic procedure substitutevec(v,slist); for i:=0:upbv v do putv(v,i,substitutesq(getv(v,i),slist)); symbolic procedure substitutesq(sq,slist); begin scalar list2,nm; list2:=nil; while slist do << if cdar slist iequal 0 then << if list2 then sq:=substitutesq(sq,reversewoc list2); list2:=nil; sq:=subzero(sq,caar slist) >> else if not (caar slist = cdar slist) then if assoc(caar slist,list2) then list2:=for each u in list2 collect (car u).subst(cdar slist,caar slist,cdr u) else list2:=(car slist).list2; % don't bother with the null substitution. slist:=cdr slist >>; list2:=reversewoc list2; if null list2 then return sq; nm:=algint!-subf(numr sq,list2); if numr nm then nm:=!*multsq(nm,invsq algint!-subf(denr sq,list2)); return nm end; % standard interface. symbolic procedure subzero(exprn,var); begin scalar top; top:=subzero2(numr exprn,var); if null numr top then return nil ./ 1; return !*multsq(top,!*invsq subzero2(denr exprn,var)) end; symbolic procedure subzero2(sf,var); if not involvesf(sf,var) then sf ./ 1 else if var eq mvar sf then subzero2(red sf,var) else if ordop(var,mvar sf) then sf ./ 1 else begin scalar u,v; if dependsp(mvar sf,var) then << u:=simp subst(0,var,mvar sf); if numr u then u:=!*exptsq(u,ldeg sf) >> else u:=((lpow sf .* 1) .+ nil) ./ 1; if null numr u then return subzero2(red sf,var); v:=subzero2(lc sf,var); if null numr v then return subzero2(red sf,var); return !*addsq(subzero2(red sf,var), !*multsq(u,v)) end; symbolic procedure pvarsub(f,u,v); % Changes u to v in polynomial f. No proper substitutions at all. if atom f then f else if mvar f equal u then addf(multf(lc f,!*p2f mksp(v,ldeg f)), pvarsub(red f,u,v)) else if ordop(u,mvar f) then f else addf(multf(pvarsub(lc f,u,v),!*p2f lpow f), pvarsub(red f,u,v)); endmodule; module taylor; % Author: James H. Davenport. fluid '(const taylorasslist taylorvariable); exports taylorform,taylorformp,taylorevaluate,return0,taylorplus, initialtaylorplus,taylorminus,initialtaylorminus, tayloroptminus,tayloroptplus,taylorctimes,initialtaylortimes, tayloroptctimes,taylorsqrtx,initialtaylorsqrtx, taylorquotient,initialtaylorquotient,taylorformersqrt, taylorbtimes,taylorformertimes,taylorformerexpt; symbolic procedure taylorform sq; if involvesf(denr sq,taylorvariable) then taylorformp list('quotient,tayprepf numr sq,tayprepf denr sq) else if 1 iequal denr sq then taylorformp tayprepf numr sq else taylorformp list('constanttimes, tayprepf numr sq, mk!*sq(1 ./ (denr sq))); % get division by a constant right. symbolic procedure taylorformp pf; if null pf then nil else if not dependsp(pf,taylorvariable) then taylorconst simp pf else begin scalar fn,initial,args; if atom pf then if pf eq taylorvariable then return taylorformp list ('expt,pf,1) else interr "False atom in taylorformp"; % get 'x right as reduce shorthand for x**1. if taylorp pf then return pf; % cope with pre-expressed cases. % ***store-hack-1*** % remove the (car pf eq 'sqrt) if more store is available. if (car pf eq 'sqrt) and (fn:=assoc(pf,taylorasslist)) then go to lookupok; % look it up first. fn:=get(car pf,'taylorformer); if null fn then go to ordinary; fn:=apply(fn,list cdr pf); % ***store-hack-1*** % remove the test if more store is available. if car pf eq 'sqrt then taylorasslist:=(pf.fn).taylorasslist; return fn; % cope with the special cases. ordinary: args:=mapcar(cdr pf,function taylorformp); fn:=get(car pf,'tayloropt); if null fn then go to nooptimisation; fn:=apply(fn,list args); if fn then go to ananswer; % an optimisation has been made. nooptimisation: fn:=get(car pf,'taylorfunction); if null fn then interr "No Taylor function provided"; fn:=fn.args; % fn is now the "how to compute" code. initial:=get(car pf,'initialtaylorfunction); if null initial then interr "No initial Taylor function"; initial:=apply(initial, list for each u in cdr fn collect firstterm u); % the first term in the expansion. fn:=list(fn,(car initial).(car initial),initial); ananswer: % ***store-hack-1*** % uncomment this if more store is available; % taylorasslist:=(pf.fn).taylorasslist; return fn; lookupok: % These PRINT statements can be enabled in order to test the % efficacy of the association list % printc "Taylor lookup succeeded"; % superprint car fn; % printc length taylorasslist; return cdr fn end; symbolic procedure taylorevaluate(texpr,n); if n<taylorfirst texpr then nil ./ 1 else if n>taylorlast texpr then tayloreval2(texpr,n) else begin scalar u; u:=assoc(n,taylorlist texpr); if u then return cdr u else return tayloreval2(texpr,n) end; symbolic procedure tayloreval2(texpr,n); begin scalar u; % actually evaluates from scratch. u:=apply(taylorfunction texpr, list(n,texpr,cdr taylordefn texpr)); if 'return0 eq taylorfunction texpr then return u; % no need to update with trivial zeroes. rplacd(cdr texpr,(n.u).taylorlist texpr); % update the association list. if n>taylorlast texpr then rplacd(taylornumbers texpr,n); % update the first/last pointer. return u end; symbolic procedure taylorconst sq; list('return0 . nil,0 . 0,0 . sq); symbolic procedure return0 (a,b,c); nil ./ 1; flag('(return0),'taylor); symbolic procedure firstterm texpr; begin scalar n,i; i:=taylorfirst texpr; trynext: n:=taylorevaluate(texpr,i); if numr n then return i.n; if i > 50 then interr "Potentially zero Taylor series"; i:=iadd1 i; rplaca(taylornumbers texpr,i); go to trynext end; symbolic procedure tayloroneterm u; % See if a Taylor expression has only one term. 'return0 eq taylorfunction u and taylorfirst u=taylorlast u; % ***store-hack-1***; % uncomment this procedure if more store is available; % there is a smacro for this at the start of the file % for use if no store can be spared; %symbolic procedure tayshorten(save); %begin % scalar z; % % shortens the association list back to save, % removing all the non-sqrts from it; % while taylorasslist neq save do << % if caar taylorasslist eq 'sqrt % then z:=(car taylorasslist).z; % taylorasslist:=cdr taylorasslist >>; % taylorasslist:=nconc(z,taylorasslist); % return nil % end; symbolic procedure tayprepf sf; if atom sf then sf else if atom mvar sf then taylorpoly makemainvar(sf,taylorvariable) else if null red sf then tayprept lt sf else list('plus,tayprept lt sf,tayprepf red sf); symbolic procedure tayprept term; if tdeg term = 1 then if tc term = 1 then tvar term else list('times,tvar term,tayprepf tc term) else if tc term = 1 then list ('expt,tvar term,tdeg term) else list('times,list('expt,tvar term,tdeg term), tayprepf tc term); symbolic procedure taylorpoly sf; % SF is a poly with MVAR = TAYLORVARIABLE. begin scalar tmax,tmin,u; tmax:=tmin:=ldeg sf; while sf do if atom sf or (mvar sf neq taylorvariable) then << tmin:=0; u:=(0 . !*f2q sf).u; sf:=nil >> else << u:=((tmin:=ldeg sf) . !*f2q lc sf) . u; sf:=red sf >>; return (list 'return0) . ((tmin.tmax).u) end; symbolic procedure taylorplus(n,texpr,args); mapply(function addsq, for each u in args collect taylorevaluate(u,n)); symbolic procedure initialtaylorplus slist; begin scalar n,numlst; n:=mapply(function min2,mapcar(slist,function car)); % the least of the degrees. numlst:=nil; while slist do << if caar slist iequal n then numlst:=(cdar slist).numlst; slist:=cdr slist >>; return n.mapply(function addsq,numlst) end; put ('plus,'taylorfunction,'taylorplus); put ('plus,'initialtaylorfunction,'initialtaylorplus); symbolic procedure taylorminus(n,texpr,args); negsq taylorevaluate(car args,n); symbolic procedure initialtaylorminus slist; (caar slist).(negsq cdar slist); put('minus,'taylorfunction,'taylorminus); put('minus,'initialtaylorfunction,'initialtaylorminus); flag('(taylorplus taylorminus),'taylor); symbolic procedure tayloroptminus(u); if 'return0 eq taylorfunction car u then taylormake(taylordefn car u, taylornumbers car u, taylorneglist taylorlist car u) else if 'taylorctimes eq taylorfunction car u then begin scalar const; u:=car u; const:=caddr taylordefn u; % the item to be negated. const:=taylormake(taylordefn const, taylornumbers const, taylorneglist taylorlist const); return taylormake(list(taylorfunction u, argof taylordefn u, const), taylornumbers u, taylorneglist taylorlist u) end else nil; put('minus,'tayloropt,'tayloroptminus); symbolic procedure taylorneglist u; mapcar(u,function (lambda v; (car v).(negsq cdr v))); symbolic procedure tayloroptplus args; begin scalar ret,hard,u; u:=args; while u do << if 'return0 eq taylorfunction car u then ret:=(car u).ret else hard:=(car u).hard; u:=cdr u >>; if null ret or null cdr ret then return nil; ret:=mapply(function joinret,ret); if null hard then return ret; rplaca(args,ret); rplacd(args,hard); return nil end; put('plus,'tayloropt,'tayloroptplus); symbolic procedure joinret(u,v); begin scalar nums,a,b,al; nums:=(min2(taylorfirst u,taylorfirst v). max2(taylorlast u,taylorlast v)); al:=nil; u:=taylorlist u; v:=taylorlist v; for i:=(car nums) step 1 until (cdr nums) do << a:=assoc(i,u); b:=assoc(i,v); if a then if b then al:=(i.addsq(cdr a,cdr b)).al else al:=a.al else if b then al:=b.al >>; return taylormake(list 'return0,nums,al) end; % the operator constanttimes % has two arguments (actually a list) % 1) a form dependent on the taylorvariable % 2) a form which is not. % the operator binarytimes has two arguments (actually a list) % but behaves like times otherwise. symbolic procedure taylorctimes(n,texpr,args); !*multsq(taylorevaluate(car args,n-(taylorfirst cadr args)), taylorevaluate(cadr args,taylorfirst cadr args)); symbolic procedure initialtaylortimes slist; % Multiply the variable by the constant. ((caar slist)+(caadr slist)). !*multsq(cdar slist,cdadr slist); symbolic procedure tayloroptctimes u; if 'taylorctimes eq taylorfunction car u then begin scalar reala,const,iconst,degg; % we have nested multiplication. reala:=argof taylordefn car u; % the thing to be multiplied by the two constants. const:=car taylorlist cadr u; %the actual outer constant: deg.sq. iconst:=caddr taylordefn car u; %the inner constant. degg:=(taylorfirst iconst)+(car const); iconst:=list(taylordefn iconst, degg.degg, degg.!*multsq(cdar taylorlist iconst,cdr const)); return list('taylorctimes,reala,iconst). ((((taylorfirst car u) + (car const)). ((taylorlast car u) + (car const))). mapcar(taylorlist car u,function multconst)) end else if 'return0 eq taylorfunction car u then begin scalar const; const:=car taylorlist cadr u; % the actual constant:deg.sq. u:=car u; return (taylordefn u). ((((taylorfirst u)+car const). ((taylorlast u)+car const)). mapcar(taylorlist u,function multconst)) end else nil; symbolic procedure multconst v; % Multiplies v by const in deg.sq form. ((car v)+(car const)) . !*multsq(cdr v,cdr const); put('constanttimes,'tayloropt,'tayloroptctimes); put('constanttimes,'simpfn,'simptimes); put('constanttimes,'taylorfunction,'taylorctimes); put('constanttimes,'initialtaylorfunction,'initialtaylortimes); symbolic procedure taylorbtimes(n,texpr,args); begin scalar answer,i,n1,n2; answer:= nil ./ 1; n1:=car firstterm car args; % the first term in one argument. n2:=car firstterm cadr args; % the first term in the other. for i:=n1 step 1 until (n-n2) do answer:=addsq(answer,!*multsq(taylorevaluate(cadr args,n-i), taylorevaluate(car args,i))); return answer end; put('binarytimes,'taylorfunction,'taylorbtimes); put('binarytimes,'initialtaylorfunction,'initialtaylortimes); put('binarytimes,'simpfn,'simptimes); symbolic procedure taylorformertimes arglist; begin scalar const,var,degg,wsqrt,negcount,u; negcount:=0; degg:=0;% the deggrees of any solitary x we may meet. const:=nil; var:=nil; wsqrt:=nil; while arglist do << if dependsp(car arglist,taylorvariable) then if and(eqcar(car arglist,'expt), cadar arglist eq taylorvariable, numberp caddar arglist) then degg:=degg+caddar arglist % removed JHD 21.8.86 - while it is anoptimisation, % it runs the risk of proving that -1 = +1 by ignoring the % number of "i" needed - despite the attempts we went to. % else if eqcar(car arglist,'sqrt) % then << % u:=argof car arglist; % wsqrt:=u.wsqrt; % if minusq cdr firstterm taylorformp u % then negcount:=1+negcount >> else if car arglist eq taylorvariable then degg:=degg + 1 else var:=(car arglist).var else const:=(car arglist).const; arglist:=cdr arglist >>; if wsqrt then if cdr wsqrt then var:=list('sqrt,prepsq simptimes wsqrt).var else var:=('sqrt.wsqrt).var; if var then var:=mapply(function (lambda u,v; list('binarytimes,u,v)),var); % insert binary multiplications. negcount:=negcount/2; if onep cdr divide(negcount,2) then const:= (-1).const; % we had an odd number of (-1) from i*i. if const or (degg neq 0) then << if const then const:=simptimes const else const:=1 ./ 1; const:=taylormake(list 'return0,degg.degg,list(degg.const)); if null var then var:=const else var:=list('constanttimes,var,const) >>; return taylorformp var end; put('times,'taylorformer,'taylorformertimes); flag('(taylorbtimes taylorctimes taylorquotient),'taylor); symbolic procedure taylorformerexpt arglist; begin scalar base,expon; base:=car arglist; expon:=simpcar cdr arglist; if (denr expon neq 1) or (not numberp numr expon) then interr "Hard exponent"; expon:=numr expon; if base neq taylorvariable then interr "Hard base"; return list('return0 . nil,expon.expon,expon.(1 ./ 1)) end; put ('expt,'taylorformer,'taylorformerexpt); symbolic procedure initialtaylorquotient slist; (caar slist - caadr slist).!*multsq(cdar slist,!*invsq cdadr slist); symbolic procedure taylorquotient(n,texpr,args); begin % problem is texpr=b/c or c*texpr=b. scalar sofar,b,c,cfirst; b:=car args; c:=cadr args; cfirst:=taylorfirst c; sofar:=taylorevaluate(b,n+cfirst); for i:=taylorfirst texpr step 1 until n-1 do sofar:=addsq(sofar,!*multsq(taylorevaluate(texpr,i), negsq taylorevaluate(c,n+cfirst-i))); return !*multsq(sofar,!*invsq taylorevaluate(c,cfirst)) end; put('quotient,'taylorfunction,'taylorquotient); put('quotient,'initialtaylorfunction,'initialtaylorquotient); symbolic procedure minusq sq; if null sq then nil else if minusf numr sq then not minusf denr sq else minusf denr sq; % This is wrapped round TAYLORFORMERSQRT2 in order to % remove the innards of the SQRT from the asslist. % note the precautions for nested SQRTs. symbolic procedure taylorformersqrt arglist; % ***store-hack-1***; % Uncomment these lines if more store is available. %begin % scalar z; % z:=taylorasslist; % if sqrtsintree(car arglist,taylorvariable) % then return taylorformersqrt2 arglist; % arglist:=taylorformersqrt2 arglist; % taylorasslist:=z; % return arglist % end; % % %symbolic procedure taylorformersqrt2 arglist; begin scalar f,realargs,ff,realsqrt; realargs:=taylorformp carx(arglist,'taylorformersqrt2); f:=firstterm realargs; if not evenp car f then interr "Extra sqrt substitution needed"; if and(0 iequal car f, 1 iequal numr cdr f, 1 iequal denr cdr f) then return taylorformp list('sqrtx,realargs); % if it starts with 1 already then it is easy. ff:=- car f; ff:=list(list 'return0,ff.ff,ff.(!*invsq cdr f)); % ff is the leading term in the expansion of realargs. realsqrt:=list('sqrtx,list('constanttimes,realargs,ff)); ff:=(car f)/2; return taylorformp list('constanttimes, realsqrt, list(list 'return0, ff.ff, ff.(simpsqrtsq cdr f))) end; put('sqrt,'taylorformer,'taylorformersqrt); symbolic procedure initialtaylorsqrtx slist; 0 . (1 ./ 1); % sqrt(1+ ...) = 1+.... symbolic procedure taylorsqrtx(n,texpr,args); begin scalar sofar,i; sofar:=taylorevaluate(car args,n); % (1+.....+a(n)*x**n)**2 % = ....+x**n*(2*a(n)+sum(0<i<n,a(i)*a(n-i))). % So a(n)=(coeff(x**n)-sum) /2. for i:=1 step 1 until (n-1) do sofar:=addsq(sofar,negsq !*multsq(taylorevaluate(texpr,i), taylorevaluate(texpr,n-i))); return multsq(sofar,1 ./ 2) end; flag('(taylorsqrtx),'taylor); put('sqrtx,'taylorfunction,'taylorsqrtx); put('sqrtx,'initialtaylorfunction,'initialtaylorsqrtx); endmodule; module torsionb; % Author: James H. Davenport. fluid '(intvar nestedsqrts); global '(!*tra !*trmin); exports bound!-torsion; symbolic procedure bound!-torsion(divisor,dof1k); % Version 1 (see Trinity Thesis for difference). begin scalar field,prime1,prime2,prime3,minimum,places; scalar non!-p1,non!-p2,non!-p3,curve,curve2,nestedsqrts; places:=for each u in divisor collect car u; curve:=getsqrtsfromplaces places; if nestedsqrts then rederr "Not yet implemented" else curve2:=curve; for each u in places do begin u:=rfirstsubs u; if eqcar(u,'quotient) and cadr u = 1 then return; u:=substitutesq(simp u,list(intvar . 0)); field:=union(field,sqrtsinsq(u,nil)); u:=list(intvar . prepsq u); for each v in curve2 do field:=union(field,sqrtsinsq(substitutesq(v,u),nil)); end; prime1:=2; while null (non!-p1:=good!-reduction(curve,dof1k,field,prime1)) do prime1:=nextprime prime1; prime2:=nextprime prime1; while null (non!-p2:=good!-reduction(curve,dof1k,field,prime2)) do prime2:=nextprime prime2; prime3:=nextprime prime2; while null (non!-p3:=good!-reduction(curve,dof1k,field,prime3)) do prime3:=nextprime prime3; minimum:=fix sqrt float(non!-p1*non!-p2*non!-p3); minimum:=min(minimum,non!-p1*max!-power(prime1,min(non!-p2,non!-p3))); minimum:=min(minimum,non!-p2*max!-power(prime2,min(non!-p1,non!-p3))); minimum:=min(minimum,non!-p3*max!-power(prime3,min(non!-p2,non!-p1))); if !*tra or !*trmin then << princ "Torsion is bounded by "; printc minimum >>; return minimum end; symbolic procedure max!-power(p,n); % Greatest power of p not greater than n. begin scalar ans; ans:=1; while ans<=n do ans:=ans*p; ans:=ans/p; end; symbolic procedure good!-reduction(curve,dof1k,field,prime); begin scalar u; u:=algebraic!-factorise(prime,field); interr "Good reduction not finished"; end; endmodule; module wstrass; % Author: James H. Davenport. fluid '(!*backtrace intvar listofallsqrts listofnewsqrts magiclist previousbasis sqrt!-intvar sqrtflag sqrts!-in!-integrand taylorasslist taylorvariable thisplace zlist); global '(!*tra !*trmin coates!-fdi); exports simpwstrass,weierstrass!-form,gcdn,sqrtsinplaces, makeinitialbasis,mkvec,completeplaces,integralbasis, normalbasis,mksp,multsq,xsubstitutesq,taylorform,taylorevaluate, coatessolve,checkpoles,substitutesq,removecmsq,printsq,interr, terpri!*,printplace,finitise,fractional!-degree!-at!-infinity, !*multsq,fdi!-print,fdi!-upgrade,fdi!-revertsq,simp,newplace, xsubstitutep,sqrtsinsq,removeduplicates,!*exptf,!*multf, !*multsq,!*q2f,mapvec,upbv,coates!-lineq,addsq,!*addsq; symbolic procedure simpwstrass u; begin scalar intvar,sqrt!-intvar,taylorvariable,taylorasslist; scalar listofallsqrts,listofnewsqrts; scalar sqrtflag,sqrts!-in!-integrand,tt,u; tt:=readclock(); sqrtflag:=t; taylorvariable:=intvar:=car u; sqrt!-intvar:=mvar !*q2f simpsqrti intvar; u:=for each v in cdr u collect simp!* v; sqrts!-in!-integrand:=sqrtsinsql(u,intvar); u:=errorset('(weierstrass!-form sqrts!-in!-integrand), t,!*backtrace); if atom u then return u else u:=car u; printc list('time,'taken,readclock()-tt,'milliseconds); printc "New x value is:"; printsq car u; u:=cdr u; printc "New y value is:"; printsq car u; u:=cdr u; printc "Related by the equation"; printsq car u; return car u end; put('wstrass,'simpfn,'simpwstrass); symbolic procedure weierstrass!-form sqrtl; begin scalar sqrtl2,u,x2,x1,vec,a,b,c,d,lhs,rhs; if !*tra or !*trmin then << printc "Find weierstrass form for elliptic curve defined by:"; for each u in sqrtl do printsq simp u >>; sqrtl2:=sqrts!-at!-infinity sqrtl; sqrtl2:=append(car sqrtl2, for each u in cdr sqrtl2 collect u.u); % one of the places lying over infinity % (after deramification as necessary). x2:=coates!-wstrass(list sqrtl2,list(-3),intvar); % Note that we do not multiply by the MULTIPLICITY!-FACTOR % since we genuinely want a pole of order -3 irrespective % of any ramification problems. if !*tra then << printc "Function with pole of order 3 (x2) is:"; printsq x2 >>; x1:=coates!-wstrass(list sqrtl2,list(-2),intvar); if !*tra then << printc "Function with pole of order 2 (x1) is:"; printsq x1 >>; vec:=mkvec list(1 ./ 1, x1, x2, !*multsq(x1,x1), !*multsq(x2,x2), !*multsq(x1,!*multsq(x1,x1)), !*multsq(x1,x2)); u:=!*lcm!*(!*exptf(denr x1,3),!*multf(denr x2,denr x2)) ./ 1; for i:=0:6 do putv(vec,i,!*q2f !*multsq(u,getv(vec,i))); if !*tra then << printc "List of seven functions in weierstrass!-form:"; mapvec(vec,function printsf) >>; vec:=wstrass!-lineq vec; % printsq(addsq(getv(vec,0),addsq(!*multsq(getv(vec,1),x1), % addsq(!*multsq(getv(vec,2),x2), % addsq(!*multsq(getv(vec,3),!*multsq(x1,x1)), % addsq(!*multsq(getv(vec,4),!*multsq(x2,x2)), % addsq(!*multsq(getv(vec,5),exptsq(x1,3)), % !*multsq(getv(vec,6), % !*multsq(x1,x2))))))))); x2:=!*addsq(!*multsq(!*multsq(2 ./ 1,getv(vec,4)),x2), addsq(!*multsq(x1,getv(vec,6)), getv(vec,2))); putv(vec,4,!*multsq(-4 ./ 1,getv(vec,4))); a:=!*multsq(getv(vec,4),getv(vec,5)); b:=!*addsq(!*multsq(getv(vec,6),getv(vec,6)), !*multsq(getv(vec,3),getv(vec,4))); c:=!*addsq(!*multsq(2 ./ 1,!*multsq(getv(vec,2),getv(vec,6))), !*multsq(getv(vec,1),getv(vec,4))); d:=!*addsq(!*multsq(getv(vec,2),getv(vec,2)), !*multsq(getv(vec,0),getv(vec,4))); lhs:=!*multsq(x2,x2); rhs:=addsq(d,!*multsq(x1, addsq(c,!*multsq(x1,addsq(b,!*multsq(x1,a)))))); if lhs neq rhs then << printsq lhs; printsq rhs; interr "Previous two unequal - consistency failure 1" >>; u:=!*lcm!*(!*lcm!*(denr a,denr b),!*lcm!*(denr c,denr d)); if u neq 1 then << % for now use u**2 whereas we should be using the least % square greater than u**2 (does it really matter). x2:=!*multsq(x2,u ./ 1); u:=!*multf(u,u) ./ 1; a:=!*multsq(a,u); b:=!*multsq(b,u); c:=!*multsq(c,u); d:=!*multsq(d,u) >>; if (numr b) and not (quotf(numr b,3)) then << % multiply all through by 9 for the hell of it. x2:=multsq(3 ./ 1,x2); u:=9 ./ 1; a:=multsq(a,u); b:=multsq(b,u); c:=multsq(c,u); d:=multsq(d,u) >>; x2:=!*multsq(x2,a); x1:=!*multsq(x1,a); c:=!*multsq(a,c); d:=!*multsq(!*multsq(a,a),d); lhs:=!*multsq(x2,x2); rhs:=addsq(d,!*multsq(x1,addsq(c,!*multsq(x1,addsq(b,x1))))); if lhs neq rhs then << printsq lhs; printsq rhs; interr "Previous two unequal - consistency failure 2" >>; b:=quotf(numr b,3) ./ 1; x1:=!*addsq(x1,b); d:=!*addsq(d,!*addsq(multsq(2 ./ 1,!*multsq(b,!*multsq(b,b))), negsq !*multsq(c,b))); c:=!*addsq(c,!*multsq((-3) ./ 1,!*multsq(b,b)) ); % b:=nil ./ 1; % not used again. if !*tra then << printsq x2; printsq x1; printc "with coefficients"; printsq c; printsq d; rhs:=!*addsq(d, !*addsq(!*multsq(c,x1), !*multsq(x1,!*multsq(x1,x1)) )); lhs:=!*multsq(x2,x2); if lhs neq rhs then << printsq lhs; printsq rhs; interr "Previous two unequal - consistency failure 3" >> >>; return weierstrass!-form1(c,d,x1,x2) end; symbolic procedure weierstrass!-form1(c,d,x1,x2); begin scalar b,u; u:=gcdf(numr c,numr d); % We will reduce by anything whose square divides C % and whose cube divides D. if not numberp u then begin scalar cc,dd; u:=jsqfree(u,mvar u); u:=cdr u; if null u then return; % We found no repeated factors. for each v in u do for each w in v do while (cc:=quotf(numr c,multf(w,w))) and (dd:=quotf(numr d,exptf(w,3))) do << c:=cc ./ 1; d:=dd ./ 1; x1:=!*multsq(x1,1 ./ w); x2:=!*multsq(x2,1 ./ multf(w,simpsqrt2 w)) >>; u:=gcdn(algint!-numeric!-content numr c, algint!-numeric!-content numr d) end; b:=2; while not (b*b) > u do begin scalar nc,nd,uu; nc:=0; while zerop cdr (uu:=divide(u,b)) do << nc:=nc+1; u:=car uu >>; if nc < 2 then go to next; uu:=algint!-numeric!-content numr d; nd:=0; while zerop cdr (uu:=divide(uu,b)) do << nd:=nd+1; uu:=car uu >>; if nd < 3 then go to next; nc:=min(nc/2,nd/3); % re-normalise by b**nc. uu:=b**nc; c:=multsq(c,1 ./ (uu**2)); d:=multsq(d,1 ./ (uu**3)); x1:=multsq(x1,1 ./ uu); x2:=multsq(x2,1 ./ (uu*b**(nc/2)) ); if not evenp nc then x2:=!*multsq(x2,!*invsq simpsqrti b); next: b:=nextprime(b) end; u:=!*kk2q intvar; u:=addsq(addsq(d,multsq(c,u)),exptsq(u,3)); if !*tra or !*trmin then << printc "Standard form is y**2 = "; printsq u >>; return list(x1,x2,simpsqrtsq u) end; symbolic procedure sqrts!-at!-infinity sqrtl; begin scalar inf,hack,sqrtl2,repeating; hack:=list list(intvar,'expt,intvar,2); inf:=list list(intvar,'quotient,1,intvar); sqrtl2:=list sqrt!-intvar; while sqrt!-intvar member sqrtl2 do << if repeating then inf:=append(inf,hack); newplace inf; sqrtl2:=for each v in sqrtl conc sqrtsinsq(xsubstitutep(v,inf),intvar); repeating:=t >>; sqrtl2:=removeduplicates sqrtl2; return inf.sqrtl2 end; symbolic procedure coates!-wstrass(places,mults,x); begin scalar thisplace,u,finite!-hack,save,places2,mults2; if !*tra or !*trmin then << princ "Find function with zeros of order:"; printc mults; if !*tra then princ " at "; terpri!*(t); if !*tra then mapc(places,function printplace) >>; % finite!-hack:=placesindiv places; % FINITE!-HACK is a list of all the substitutors in PLACES; % u:=removeduplicates sqrtsintree(finite!-hack,x,nil); % if !*tra then << % princ "Sqrts on this curve:"; % terpri!*(t); % superprint u >>; % algnos:=removeduplicates mapcar(places,function basicplace); % if !*tra then << % printc "Algebraic numbers where residues occur:"; % superprint algnos >>; finite!-hack:= finitise(places,mults); % returns list (places,mults,power of x to remove. places2:=car finite!-hack; mults2:=cadr finite!-hack; finite!-hack:=list(places,mults,caddr finite!-hack); coates!-fdi:=fractional!-degree!-at!-infinity u; if coates!-fdi iequal 1 then return !*multsq(wstrassmodule(places2,mults2,x,finite!-hack), !*p2q mksp(x,caddr finite!-hack)); if !*tra then fdi!-print(); places2:=mapcar(places2,function fdi!-upgrade); save:=taylorasslist; u:=wstrassmodule(places2, mapcar(mults2,function (lambda u;u*coates!-fdi)), x,finite!-hack); taylorasslist:=save; u:=fdi!-revertsq u; return !*multsq(u,!*p2q mksp(x,caddr finite!-hack)) end; symbolic procedure wstrassmodule(places,mults,x,finite!-hack); begin scalar pzero,mzero,u,v,basis,sqrts,magiclist,mpole,ppole; % MAGICLIST holds the list of extra unknowns created in JHDSOLVE % which must be found in CHECKPOLES (calling FINDMAGIC). sqrts:=sqrtsinplaces places; if !*tra then << princ "Sqrts on this curve:"; superprint sqrts >>; u:=places; v:=mults; while u do << if 0<car v then << mzero:=(car v).mzero; pzero:=(car u).pzero >> else << mpole:=(car v).mpole; ppole:=(car u).ppole >>; u:=cdr u; v:=cdr v >>; basis:=mkvec makeinitialbasis ppole; u:=completeplaces(ppole,mpole); basis:=integralbasis(basis,car u,cdr u,x); basis:=normalbasis(basis,x,0); u:=coatessolve(mzero,pzero,basis,force!-pole(basis,finite!-hack)); % This is the list of special constraints needed % to force certain poles to occur in the answer. previousbasis:=nil; if atom u then return u; v:= checkpoles(list u,places,mults); if null v then return 'failed; if not magiclist then return u; u:=removecmsq substitutesq(u,v); % Apply the values from FINDMAGIC. if !*tra or !*trmin then << printc "Function is"; printsq u >>; magiclist:=nil; if checkpoles(list u,places,mults) then return u else interr "Inconsistent checkpoles" end; symbolic procedure force!-pole(basis,finite!-hack); begin scalar places,mults,u,ans; places:=car finite!-hack; mults:=cadr finite!-hack; finite!-hack:=caddr finite!-hack; u:=!*p2q mksp(intvar,finite!-hack); basis:=for each v in basis collect multsq(u,v); while places do << u:=for each v in basis collect taylorevaluate(taylorform xsubstitutesq(v,car places), car mults); mults:=cdr mults; places:=cdr places; ans:=u.ans >>; return ans end; symbolic procedure wstrass!-lineq vec; begin scalar zlist,powlist,m,rightside,v; scalar zero,one; zero:=nil ./ 1; one:=1 ./ 1; for i:=0:6 do zlist:=varsinsf(getv(vec,i),zlist); zlist:=intvar . findzvars(zlist,nil,intvar,nil); for i:=0:6 do putv(vec,i,f2df getv(vec,i)); for i:=0:6 do for each u in getv(vec,i) do if not ((tpow u) member powlist) then powlist:=(tpow u).powlist; m:=for each u in powlist collect begin scalar v; v:=mkvect 6; for i:=0:6 do putv(v,i,(lambda u; if null u then zero else tc u) assoc(u,getv(vec,i))); return v end; v:=mkvect 6; for i:=0:6 do putv(v,i,zero); putv(v,4,one); % we know that coefficient e is non-zero. m:=mkvec (v.m); v:=upbv m; rightside:=mkvect v; putv(rightside,0,one); for i:=1:v do putv(rightside,i,zero); return coates!-lineq(m,rightside) end; % This is same as NUMERIC!-CONTENT in the EZGCD module, but is included % here so that that module doesn't need to be loaded. symbolic procedure algint!-numeric!-content form; %Find numeric content of non-zero polynomial. if domainp form then abs form else if null red form then algint!-numeric!-content lc form else begin scalar g1; g1 := algint!-numeric!-content lc form; if not (g1=1) then g1 := gcddd(g1,algint!-numeric!-content red form); return g1 end; endmodule; module zmodule; % Author: James H. Davenport. fluid '(!*galois basic!-listofallsqrts basic!-listofnewsqrts commonden gaussiani listofallsqrts listofnewsqrts sqrt!-places!-alist taylorasslist); global '(!*tra !*trfield !*trmin); exports zmodule; imports !*multf,sqrtsinsql,sortsqrts,simp,!*q2f,actualsimpsqrt,printsf; imports prepf,substitutesq,printsq,mapply,!*multsq,mkilist; imports mkvecf2q,mkvec,mkidenm,invsq,multsq,negsq,addsq,gcdn; imports !*invsq,prepsq; symbolic procedure zmodule(w); begin scalar reslist,denlist,u,commonden,basis,p1,p2,hcf; % w is a list of elements (place.residue)=sq. for each v in w do << u:=cdr v; reslist:=u.reslist; denlist:=(denr u).denlist >>; basis:=sqrtsinsql(reslist,nil); if null u or null cdr u or !*galois then go to nochange; reslist:=check!-sqrts!-dependence(reslist,basis); denlist:=for each u in reslist collect denr u; nochange: commonden:=mapply(function(lambda u,v; multf(u,quotf(v,gcdf(u,v)))),denlist)./1; u:=nil; for each v in reslist do u:=(numr !*multsq(v,commonden)).u; reslist:=u; % We have effectively reserves RESLIST twice, % so it is in the corect order. u:=bexprn(reslist); basis:=car u; reslist:=cdr u; denlist:=nil; while basis do << p1:=reslist; p2:=w; u:=nil; hcf:=0; while p1 do << if 0 neq caar p1 then << u:=((caar p2).(caar p1)).u; hcf:=gcdn(hcf,caar p1) >>; p1:=cdr p1; p2:=cdr p2 >>; if hcf neq 1 then u:=for each uu in u collect (car uu). ( (cdr uu) / hcf); denlist:=(prepsq !*multsq(car basis, multsq(!*f2q hcf,!*invsq commonden)) .u).denlist; basis:=cdr basis; reslist:=mapcar(reslist,function cdr) >>; return denlist end; symbolic procedure bexprn(wlist); begin scalar basis,replist,w,w2,w3,p1,p2; % wlist is a list of sf. w:=reverse wlist; replist:=nil; while w do << w2:=sf2df car w; % now ensure that all elements of w2 are in the basis. w3:=w2; while w3 do << % caar is the sf,cdar a its coefficient. if not member(caar w3,basis) then << basis:=(caar w3).basis; replist:=mapcons(replist,0) >>; % adds car w3 to basis. w3:=cdr w3 >>; replist:=mkilist(basis,0).replist; % builds a new zero representation. w3:=w2; while w3 do << p1:=basis; p2:=car replist; %the list for this element. while p1 do << if caar w3 = car p1 then rplaca(p2,cdar w3); p1:=cdr p1; p2:=cdr p2 >>; w3:=cdr w3 >>; w:=cdr w >>; return mkbasis(basis,replist) end; symbolic procedure mkbasis(basis,reslist); begin scalar row,nbasis,nreslist,u,v; basis:=for each u in basis collect !*f2q u; % basis is a list of sq's % reslist is a list of representations in the form % ( (coeff1 coeff2 ...) ...). nreslist:=mkilist(reslist,nil); % initialise our list-of-lists. trynewloop: row:=mapcar(reslist,function car); reslist:=mapcar(reslist,function cdr); if obvindep(row,nreslist) then u:=nil else u:=lindep(row,nreslist); if u then << % u contains the numbers with which to add this new item into the % basis. v:=nil; while nbasis do << v:=addsq(car nbasis,!*multsq(car basis,car u)).v; nbasis:=cdr nbasis; u:=cdr u >>; nbasis:=reversewoc v >> else << nreslist:=pair(row,nreslist); nbasis:=(car basis).nbasis >>; basis:=cdr basis; if basis then go to trynewloop; return nbasis.nreslist end; symbolic procedure obvindep(row,matrx); % True if row is obviously linearly independent of the % Rows of the matrix. begin scalar u; if null car matrx then return t; % no matrix => no dependence. nexttry: if null row then return nil; if 0 iequal car row then go to nouse; u:=car matrx; testloop: if 0 neq car u then go to nouse; u:=cdr u; if u then go to testloop; return t; nouse: row:=cdr row; matrx:=cdr matrx; go to nexttry end; symbolic procedure sf2df sf; if null sf then nil else if numberp sf then (1 . sf).nil else begin scalar a,b,c; a:=sf2df lc sf; b:=(lpow sf .* 1) .+ nil; while a do << c:=(!*multf(caar a,b).(cdar a)).c; a :=cdr a >>; return nconc(c,sf2df red sf) end; symbolic procedure check!-sqrts!-dependence(sql,sqrtl); % Resimplifies the list of SQs SQL, % allowing for all dependencies among the % sqrts in SQRTl. begin scalar !*galois,sublist,sqrtsavelist,changeflag; sqrtsavelist:=listofallsqrts.listofnewsqrts; listofnewsqrts:=list mvar gaussiani; listofallsqrts:=list((argof mvar gaussiani) . gaussiani); !*galois:=t; for each u in sortsqrts(sqrtl,nil) do begin scalar v,uu; uu:=!*q2f simp argof u; v:=actualsimpsqrt uu; listofallsqrts:=(uu.v).listofallsqrts; if domainp v or mvar v neq u then << if !*tra or !*trfield then << printc u; printc "re-expressed as"; printsf v >>; v:=prepf v; sublist:=(u.v) . sublist; changeflag:=t >> end; if changeflag then << sql:=for each u in sql collect substitutesq(u,sublist); taylorasslist:=nil; sqrt!-places!-alist:=nil; basic!-listofallsqrts:=listofallsqrts; basic!-listofnewsqrts:=listofnewsqrts; if !*tra or !*trmin then << printc "New set of residues are"; mapc(sql,function printsq) >> >> else << listofallsqrts:=car sqrtsavelist; listofnewsqrts:=cdr sqrtsavelist >>; return sql end; symbolic procedure lindep(row,matrx); begin scalar m,mm,n,i,j,k,u,v,inverse,rowsinuse,failure; % Inverse is the answer from the "gaussian elimination" % we are doing. % Rowsinuse has nil for rows with no "awkward" non-zero entries. mm:=length car matrx; m:=isub1 mm; n:=isub1 length matrx; % n=length row. row:=mkvecf2q row; matrx:=mkvec mapcar(matrx,function mkvecf2q); inverse:=mkidenm mm; rowsinuse:=mkvect m; failure:=t; % initialisation complete. for i:=0 step 1 until n do begin % try to kill off i'th elements in each row. u:=nil; for j:=0 step 1 until m do << % try to find a pivot element. if (null u) and (null getv(rowsinuse,j)) and (numr getv(getv(matrx,i),j)) then u:=j >>; if null u then go to nullu; putv(rowsinuse,u,t); % it is no use trying this again --- % u is our pivot element. if u iequal m then go to nonetokill; for j:=iadd1 u step 1 until m do if numr getv(getv(matrx,i),j) then << v:=negsq multsq(getv(getv(matrx,i),j), invsq getv(getv(matrx,i),u)); for k:=0 step 1 until mm do putv(getv(inverse,k),j, addsq(getv(getv(inverse,k),j), multsq(v,getv(getv(inverse,k),u)))); for k:=0 step 1 until n do putv(getv(matrx,k),j, addsq(getv(getv(matrx,k),j), multsq(v,getv(getv(matrx,k),u)))) >>; %we have now pivoted throughout matrx. nonetokill: % now do the same in row if necessary. if null numr getv(row,i) then go to norowop; v:=negsq multsq(getv(row,i), invsq getv(getv(matrx,i),u)); for k:=0 step 1 until mm do putv(getv(inverse,k),mm, addsq(getv(getv(inverse,k),mm), multsq(v,getv(getv(inverse,k),u)))); for k:=0 step 1 until n do putv(row,k,addsq(getv(row,k), multsq(v,getv(getv(matrx,k),u)))); u:=nil; for k:=0 step 1 until n do if numr getv(row,k) then u:=t; % if u is null then row is all 0. if null u then << n:=-1; failure:=nil >>; norowop: if !*tra then << princ "At end of cycle"; printc row; printc matrx; printc inverse >>; return; nullu: % there is no pivot for this u. if numr getv(row,i) then n:=-1; % this element cannot be killed. end; if failure then return nil; v:=nil; for i:=0 step 1 until m do v:=(negsq getv(getv(inverse,m-i),mm)).v; return v end; endmodule; end; |
Added r33/anum.red version [15ab74d356].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module arnum; % Support for algebraic rationals. % Author: Eberhard Schruefer. global '(domainlist!* arbase!* arvars!* repowl!* curdefpol!* !*acounter!* !*extvar!* reexpressl!*); !*acounter!* := 0; %counter for number of extensions; !*extvar!* := 'a; %default print character for primitive element; fluid '(!*arnum dmode!* !*exp !*minimal !*reexpress !*arinv !*arquot !*arq alglist!*); global '(timer timef); switch arnum; timer:=timef:=0; domainlist!*:=union('(!:ar!:),domainlist!*); symbolic procedure defpoly u; begin if null(dmode!* eq '!:ar!:) then on 'arnum; for each j in u do (if eqexpr j then if cadr j=0 then mkextension caddr j else if caddr j=0 then mkextension cadr j else rederr list(cadr j,"=",caddr j, " is not a proper defining polynomial") else mkextension j) end; rlistat '(defpoly); symbolic procedure mkextension u; if null curdefpol!* then initalgnum u else begin scalar !*exp; !*exp := t; primitive!_elem !*a2f u end; symbolic procedure initalgnum u; begin scalar dmode!*,alglist!*,!*exp; !*exp := t; arbase!* := nil; u := numr simp0 u; if lc u neq 1 then u := monicize u; % rederr("defining polynomial must be monic"); curdefpol!* := u; for j:=0:(ldeg u-1) do arbase!* := (if j=0 then 1 else mksp(mvar u,j)) . arbase!*; arvars!* := mvar u . arvars!*; mk!-algebraic!-number!-vars list mvar u; repowl!* := lpow u . negf red u end; symbolic procedure put!-current!-representation(u,v); put(u,'currep,v); symbolic procedure get!-current!-representation u; get(u,'currep); symbolic procedure mkdar u; %puts any algebraic number domain element into its tagged form. %updated representations (through field extension) are accessed here; ((if x then x else '!:ar!: . !*k2f u) ./ 1) where x = get!-current!-representation u; symbolic procedure release u; %Undeclares elements of list u to be algebraic numbers; for each j in u do if atom j then remprop(j,'idvalfn) else remprop(car j,'opvalfn); symbolic procedure mk!-algebraic!-number!-vars u; %Declares elements of list u to be algebraic numbers; for each j in u do if atom j then put(j,'idvalfn,'mkdar) else put(car j,'opvalfn,'mkdar); symbolic procedure uncurrep u; for each j in u do remprop(j,'currep); symbolic procedure update!-extension u; %Updates representation of elements in list u; for each j in u do ((x and put(j,'currep,numr simp prepf cdr x)) where x = get(j,'currep)); symbolic procedure express!-in!-arvars u; %u is an untagged rational number. Result is equivalent algebraic %number expressed in input variables. rederr "switch reexpress not yet implemented"; % begin scalar x; % for each j in reexpressl!* do % x := extmult(extadd(...,j),x); % return solve!-for!-arvars x % end; symbolic procedure mkreexpressl; %Sets up the homogenous part of the system to be solved for %expressing a primitive element expression in terms of the %input variables. reexpressl!* := nil; % begin scalar x; % put('reexpress,'simpfg,'((t (mkreexpressl)) (nil (setq reexpressl!* nil)))); %*** tables for algebraic rationals ***; flag('(!:ar!:),'field); put('arnum,'tag,'!:ar!:); put('!:ar!:,'dname,'arnum); put('!:ar!:,'i2d,'!*i2ar); %put('!:ar!:,'!:rn!:,'ar2rn); put('!:ar!:,'!:ft!:,'arconv); put('!:ar!;,'!:bf!:,'arconv); put('!:ar!:,'!:mod!:,'arconv); put('!:ar!:,'minusp,'arminusp!:); put('!:ar!:,'zerop,'arzerop!:); put('!:ar!:,'onep,'aronep!:); put('!:ar!:,'plus,'arplus!:); put('!:ar!:,'difference,'ardifference!:); put('!:ar!:,'times,'artimes!:); put('!:ar!:,'quotient,'arquotient!:); put('!:ar!:,'factorfn,'arfactor!:); put('!:ar!:,'rationalizefn,'arrationalize!:); put('!:ar!:,'prepfn,'arprep!:); put('!:ar!:,'intequivfn,'arintequiv!:); put('!:ar!:,'prifn,'arprn!:); put('!:rn!:,'!:ar!:,'rn2ar); flag('(!:ar!:),'ratmode); symbolic procedure rn2ar u; '!:ar!: . if cddr u=1 then cadr u else u; symbolic procedure ar2rn u; if cadr u eq '!:rn!: then cdr u else if numberp cdr u then '!:rn!: . (cdr u . 1) else rederr list "conversion to rational not possible"; symbolic procedure !*i2ar u; '!:ar!: . u; symbolic procedure arconv u; rederr list("conversion between current extension and", get(car u,'dname),"not possible"); symbolic procedure arminusp!: u; minusf cdr u; symbolic procedure arzerop!: u; null cdr u; symbolic procedure aronep!: u; cdr u=1; symbolic procedure arintequiv!: u; if numberp cdr u then cdr u else if (cadr u eq '!:rn!:) and (cdddr u=1) then caddr u else nil; smacro procedure mkar u; '!:ar!: . u; symbolic procedure arplus!:(u,v); begin scalar dmode!*,!*exp; !*exp := t; return mkar addf(cdr u,cdr v) end; symbolic procedure ardifference!:(u,v); begin scalar dmode!*,!*exp; !*exp := t; return mkar addf(cdr u,negf cdr v) end; symbolic procedure artimes!:(u,v); begin scalar dmode!*,!*exp; !*exp := t; return mkar reducepowers multf(cdr u,cdr v) end; symbolic procedure arquotient!:(u,v); begin scalar r,s,y,z,dmode!*,!*exp; !*exp := t; if domainp cdr v then return mkar multd(<<dmode!* := '!:rn!:; s := !:recip cdr v; dmode!* := nil; s>>,cdr u); if !*arinv then return mkar reducepowers multf(cdr u,arinv cdr v); if !*arquot then return mkar arquot(cdr v,cdr u); if !*arq then return mkar reducepowers multf(u,arquot1 v); r := ilnrsolve(mkqmatr cdr v,mkqcol cdr u); z := arbase!*; dmode!* := '!:rn!:; for each j in r do s := addf(multf(int!-equiv!-chk car j, <<y := if atom car z then 1 else !*p2f car z; z := cdr z; y>>),s); return mkar s end; symbolic procedure arfactor!: v; if domainp v then list v else if null curdefpol!* then factorf v else begin scalar w,x,y,z,aftrs,ifctr,ftrs,mva,mvu, dmode!*,!*exp; timer:=timef:=0; !*exp := t; mva := mvar curdefpol!*; mvu := mvar v; ifctr := factorft numr(v := fd2q v); dmode!* := '!:ar!:; w := if denr v neq 1 then mkrn(car ifctr,denr v) else car ifctr; for each f in cdr ifctr do begin scalar l; y := numr subf1(car f,nil); if domainp y then <<w := multd(y,w); return>>; y := sqfrnorm y; dmode!* := nil; ftrs := factorft car y; dmode!* := '!:ar!:; if cadr y neq 0 then l := list(mvu . prepf addf(!*k2f mvu, negf multd(cadr y,!*k2f mva))); y := cddr y; for each j in cdr ftrs do <<x := gcdf!*(car j,y); y := quotf!*(y,x); z := if l then numr subf1(x,l) else x; x := lnc ckrn z; z := quotf(z,x); w := multf(w,exptf(x,cdr f)); aftrs := (z . cdr f) . aftrs>> end; %print timer; print timef; return w . aftrs end; symbolic procedure afactorize u; begin scalar ftrs,x,!*exp; integer n; !*exp := t; if cdr u then <<off 'arnum; defpoly cdr u>>; x := arfactor!: !*a2f car u; ftrs := (0 . mk!*sq(car x ./ 1)) . nil; for each j in cdr x do for k := 1:cdr j do ftrs := ((n := n+1) . mk!*sq(car j ./ 1)) . ftrs; return multiple!-result(ftrs,nil) end; put('algeb!_factorize,'psopfn,'afactorize); symbolic procedure arprep!: u; %u; prepf if !*reexpress then express!-in!-arvars cdr u else cdr u; %symbolic procedure simpar u; %('!:ar!: . !*a2f car u) ./ 1; %put('!:ar!:,'simpfn,'simpar); symbolic procedure arprn!: v; ( if atom u or (car u memq '(times expt)) then maprin u else <<prin2!* "("; maprin u; prin2!* ")" >>) where u = prepsq!*(cdr v ./ 1); %*** utility functions ***; symbolic procedure monicize u; %makes standard form u monic by the appropriate variable subst.; begin scalar a,mvu,x; integer n; x := lc u; mvu := mvar u; n := ldeg u; !*acounter!* := !*acounter!* + 1; a := intern compress append(explode !*extvar!*, explode !*acounter!*); u := multsq(subf(u,list(mvu . list('quotient,a,x))), x**(n-1) ./ 1); mk!-algebraic!-number!-vars list mvu; put!-current!-representation(mvu, mkar(a to 1 .* ('!:rn!: . 1 . x) .+ nil)); terpri(); prin2 "defining polynomial has been monicized"; terpri(); maprin prepsq u; terpri!* t; return !*q2f u end; symbolic procedure polynorm u; begin scalar dmode!*,x,y; integer n; n := ldeg curdefpol!*; x := fd2q u; y := resultantft(curdefpol!*,numr x,mvar curdefpol!*); dmode!* := '!:ar!:; return if denr x = 1 then y else !*q2f multsq(y ./ 1,1 ./ (denr x)**n) end; symbolic procedure resultantft(u,v,w); resultant(u,v,w); symbolic procedure factorft u; begin scalar dmode!*; return factorf u end; symbolic procedure fd2q u; %converts a s.f. over ar to a s.q. over the integers; if atom u then u ./ 1 else if car u eq '!:ar!: then fd2q cdr u else if car u eq '!:rn!: then cdr u else addsq(multsq(!*p2q lpow u,fd2q lc u),fd2q red u); symbolic procedure sqfrnorm u; begin scalar l,norm,y; integer s; y := u; if algebnp u then go to b; a: s := s-1; l := list(mvar u . prepf addf(!*k2f mvar u,multd(s,!*k2f mvar curdefpol!*))); y := numr subf1(u,l); if null algebnp y then go to a; b: norm := polynorm y; if not ar!-sqfrp norm then go to a; return norm . (s . y) end; symbolic procedure algebnp u; if atom u then nil else if car u eq '!:ar!: then t else if domainp u then nil else algebnp lc u or algebnp red u; symbolic procedure ar!-sqfrp u; % This is same as sqfrp in gint module. domainp gcdf!*(u,diff(u,mvar u)); symbolic procedure primitive!_elem u; begin scalar a,x,y,z,newu,newdefpoly,olddefpoly; if x := not!_in!_extension u then u := x else return; !*acounter!* := !*acounter!* + 1; a := intern compress append(explode !*extvar!*, explode !*acounter!*); x := sqfrnorm u; newdefpoly := !*q2f subf(car x,list(mvar car x . a)); olddefpoly := curdefpol!*; newu := !*q2f subf(cddr x,list(mvar car x . a)); rmsubs(); release arvars!*; initalgnum prepf newdefpoly; y := gcdf!*(numr simp prepf newu,olddefpoly); arvars!* := mvar car x . arvars!*; mk!-algebraic!-number!-vars arvars!*; put!-current!-representation(mvar olddefpoly, z := quotf!*(negf red y,lc y)); put!-current!-representation(mvar car x, addf(mkar !*k2f a, multf(!*n2f cadr x,z))); rmsubs(); update!-extension arvars!*; terpri!* t; prin2!* "*** Defining polynomial for primitive element:"; terpri!* t; maprin prepf curdefpol!*; terpri!* t end; symbolic procedure not!_in!_extension u; %We still need a criterion which branch to choose; %Isolating intervals would do; begin scalar ndp,x; integer cld; if null !*minimal then return u; cld := ldeg u; x := arfactor!: u; for each j in cdr x do if ldeg car j < cld then <<ndp := car j; cld := ldeg ndp>>; if cld=1 then <<mk!-algebraic!-number!-vars list mvar u; put!-current!-representation(mvar u, quotf!*(negf red ndp,lc ndp)); return nil>> else return ndp end; symbolic procedure split!_field1(u,v); %determines the minimal splitting field for u; begin scalar a,ftrs,mvu,q,x,y,z,roots,bpoly,minpoly,newminpoly, polys,newfactors,dmode!*,!*exp; integer indx,k,n,new!_s; off 'arnum; %crude way to clear previous extensions; !*exp := t; u := !*q2f simp!* u; mvu := mvar u; indx := 1; polys := (1 . u) . polys; !*acounter!* := !*acounter!* + 1; a := intern compress append(explode !*extvar!*, explode !*acounter!*); minpoly := newminpoly := numr subf(u,list(mvu . a)); dmode!* := '!:ar!:; mkextension prepf minpoly; roots := mkar !*k2f a . roots; b: polys := for each j in polys collect if indx=car j then car j . quotf!*(cdr j, addf(!*k2f mvu,negf car roots)) else j; k := 1; indx := 0; for each j in polys do begin scalar l; x := sqfrnorm cdr j; if cadr x neq 0 then l := list(mvu . prepf addf(!*k2f mvu, negf multd(cadr x,!*k2f a))); z := cddr x; dmode!* := nil; ftrs := cdr factorf car x; dmode!* := '!:ar!:; for each qq in ftrs do <<y := gcdf!*(z,q:=car qq); if ldeg q > ldeg newminpoly then <<newminpoly := q; new!_s := cadr x; indx := k; bpoly := y>>; z := quotf!*(z,y); if l then y := numr subf(y,l); if ldeg y=1 then roots := quotf(negf red y,lc y) . roots else <<newfactors:=(k . y) . newfactors; k:=k+1>>>> end; if null newfactors then <<terpri(); prin2t "*** Splitting field is generated by:"; terpri(); maprin prepf newminpoly; terpri!* t; n := length roots; return multiple!-result( for each j in roots collect (n := n-1) . mk!*sq(j ./ 1),v)>>; !*acounter!* := !*acounter!* + 1; a := intern compress append(explode !*extvar!*, explode !*acounter!*); newminpoly := numr subf(newminpoly,list(mvu . a)); bpoly := numr subf(bpoly,list(mvu . a)); rmsubs(); release arvars!*; initalgnum prepf newminpoly; x := gcdf!*(minpoly,numr simp prepf bpoly); mk!-algebraic!-number!-vars arvars!*; put!-current!-representation(mvar minpoly, z := quotf!*(negf red x,lc x)); rmsubs(); roots := addf(mkar !*k2f a,multf(!*n2f new!_s,z)) . for each j in roots collect numr subf(cdr j,nil); polys := for each j in newfactors collect car j . numr simp prepf cdr j; newfactors := nil; minpoly := newminpoly; go to b end; symbolic procedure split!-field!-eval u; begin scalar x; if length u > 2 then rederr "split!_field called with wrong number of arguments"; x := split!_field1(car u,if cdr u then cadr u else nil); dmode!* := '!:ar!:; %The above is necessary for working with the results. return x end; put('split!_field,'psopfn,'split!-field!-eval); symbolic procedure arrationalize!: u; %We should actually factorize the denominator first to %make sure that the result is in lowest terms. ???? begin scalar x,y,z,dmode!*; if domainp denr u then return quotf(numr u,denr u) ./ 1; if null algebnp denr u then return u; x := polynorm numr fd2q denr u; y := multsq(fd2q multf(numr u,quotf!*(x,denr u)),1 ./ x); dmode!* := '!:ar!:; x := numr subf(denr y,nil); y := numr subf(numr y,nil); z := lnc x; return quotf(y,z) ./ quotf(x,z) end; %put('rationalize,'simpfn,'rationalize); its now activated by a switch. put('polynorm,'polyfn,'polynorm); %*** support functions ***; comment the function ilnrsolve and others are identical to the %ones in matr except they work only on integers here; %there should be better algorithms; symbolic procedure reducepowers u; %reduces powers with the help of the defining polynomial; if domainp u or (ldeg u<pdeg car repowl!*) then u else if ldeg u=pdeg car repowl!* then addf(multf(cdr repowl!*,lc u),red u) else reducepowers addf(multf(multpf(mvar u .** (ldeg u-pdeg car repowl!*),lc u), cdr repowl!*),red u); symbolic procedure mkqmatr u; %u is an ar domainelement, result is a matrix form which %needs to be inverted for calculating the inverse of ar; begin scalar r,x,v,w; v := mkqcol u; for each k in cdr reverse arbase!* do <<w := reducepowers multpf(k,u); v := for each j in arbase!* collect <<r := ((if atom j then ratn w else if domainp w then 0 . 1 else if j=lpow w then <<x:=ratn lc w; w:=cdr w; x>> else 0 . 1) . car v); v := cdr v; r>>>>; return v end; symbolic procedure mkqcol u; %u is an ar domainelement result is a matrix form %representing u as a coefficient matrix of the ar base; begin scalar x,v; v := for each j in arbase!* collect if atom j then list ratn u else if domainp u then list(0 . 1) else if j=lpow u then <<x:=list ratn lc u; u:=cdr u; x>> else list(0 . 1); return v end; symbolic procedure ratn u; if null u then 0 . 1 else if atom u then u . 1 else if car u eq '!:rn!: then cdr u else rederr "Illegal domain in :ar:"; symbolic procedure inormmat u; begin integer y; scalar z; % x := 1; for each v in u do <<y := 1; for each w in v do y := ilcm(y,denr w); z := (for each w in v collect numr w*y/denr w) . z>>; return reverse z end; symbolic procedure ilcm(u,v); if u=0 or v=0 then 0 else if u=1 then v else if v=1 then u else u*v/gcdn(u,v); symbolic procedure ilnrsolve(u,v); %u is a matrix standard form, v a compatible matrix form; %value is u**(-1)*v; begin integer n; n := length u; v := ibacksub(ibareiss inormmat ar!-augment(u,v),n); u := ar!-rhside(car v,n); v := cdr v; return for each j in u collect for each k in j collect mkrn(k,v) end; symbolic procedure ar!-augment(u,v); % Same as augment in bareiss module. if null u then nil else append(car u,car v) . ar!-augment(cdr u,cdr v); symbolic procedure ar!-rhside(u,m); % Same as rhside in bareiss module. if null u then nil else pnth(car u,m+1) . ar!-rhside(cdr u,m); symbolic procedure ibareiss u; %as in matr but only for integers; begin scalar ik1,ij,kk1,kj,k1j,k1k1,ui,u1,x; integer k,k1,aa,c0,ci1,ci2; aa:= 1; k:= 2; k1:=1; u1:=u; go to pivot; agn: u1 := cdr u1; if null cdr u1 or null cddr u1 then return u; aa:=nth(car u1,k); %aa := u(k,k); k:=k+2; k1:=k-1; u1:=cdr u1; pivot: %pivot algorithm; k1j:= k1k1 := pnth(car u1,k1); if car k1k1 neq 0 then go to l2; ui:= cdr u1; %i := k; l: if null ui then return nil else if car(ij := pnth(car ui,k1))=0 then go to l1; l0: if null ij then go to l2; x:= car ij; rplaca(ij,-car k1j); rplaca(k1j,x); ij:= cdr ij; k1j:= cdr k1j; go to l0; l1: ui:= cdr ui; go to l; l2: ui:= cdr u1; %i:= k; l21: if null ui then return; %if i>m then return; ij:= pnth(car ui,k1); c0:= car k1k1*cadr ij-cadr k1k1*car ij; if c0 neq 0 then go to l3; ui:= cdr ui; %i:= i+1; go to l21; l3: c0:= c0/aa; kk1 := kj := pnth(cadr u1,k1); %kk1 := u(k,k-1); if cdr u1 and null cddr u1 then go to ev0 else if ui eq cdr u1 then go to comp; l31: if null ij then go to comp; %if i>n then go to comp; x:= car ij; rplaca(ij,-car kj); rplaca(kj,x); ij:= cdr ij; kj:= cdr kj; go to l31; %pivoting complete; comp: if null cdr u1 then go to ev; ui:= cddr u1; %i:= k+1; comp1: if null ui then go to ev; %if i>m then go to ev; ik1:= pnth(car ui,k1); ci1:= (cadr k1k1*car ik1-car k1k1*cadr ik1)/aa; ci2:= (car kk1*cadr ik1-cadr kk1*car ik1)/aa; if null cddr k1k1 then go to comp3;%if j>n then go to comp3; ij:= cddr ik1; %j:= k+1; kj:= cddr kk1; k1j:= cddr k1k1; comp2: if null ij then go to comp3; rplaca(ij,(car ij*c0+car kj*ci1+car k1j*ci2)/aa); ij:= cdr ij; kj:= cdr kj; k1j:= cdr k1j; go to comp2; comp3: ui:= cdr ui; go to comp1; ev0:if c0=0 then return; ev: kj := cdr kk1; x := cddr k1k1; %x := u(k-1,k+1); rplaca(kj,c0); ev1:kj:= cdr kj; if null kj then go to agn; rplaca(kj,(car k1k1*car kj-car kk1*car x)/aa); x := cdr x; go to ev1 end; symbolic procedure ibacksub(u,m); begin scalar ij,ijj,ri,uj,ur; integer i,jj,summ,detm,det1; %n in comments is number of columns in u; if null u then rederr "singular matrix"; ur := reverse u; detm := car pnth(car ur,m); %detm := u(i,j); if detm=0 then rederr "singular matrix"; i := m; rows: i := i-1; ur := cdr ur; if null ur then return u . detm; %if i=0 then return u . detm; ri := car ur; jj := m+1; ijj:=pnth(ri,jj); r2: if null ijj then go to rows; %if jj>n then go to rows; ij := pnth(ri,i); %j := i; det1 := car ij; %det1 := u(i,i); uj := pnth(u,i); summ := 0; %summ := 0; r3: uj := cdr uj; %j := j+1; if null uj then go to r4; %if j>m then go to r4; ij := cdr ij; summ := summ+car ij*nth(car uj,jj); %summ:=summ+u(i,j)*u(j,jj); go to r3; r4: rplaca(ijj,(detm*car ijj-summ)/det1); %u(i,j):=(detm*u(i,j)-summ)/det1; jj := jj+1; ijj := cdr ijj; go to r2 end; initdmode 'arnum; put('arnum,'simpfg, '((t (setdmode (quote arnum) t)) (nil (setdmode (quote arnum) nil) (release arvars!*) (uncurrep arvars!*) (setq curdefpol!* nil) (setq arvars!* nil)))); endmodule; end; |
Added r33/arith.red version [5e2a9bbaab].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module farith; % Operators for fast arithmetic; % Authors: A. C. Norman and P. M. A. Moore, 1981; remprop('iplus,'infix); % to allow for redefinition; remprop('itimes,'infix); symbolic macro procedure iplus u; expand(cdr u,'plus2); symbolic macro procedure itimes u; expand(cdr u,'times2); smacro procedure isub1 a; a-1; smacro procedure iadd1 a; a+1; remprop('iminus,'infix); smacro procedure iminus a; -a; smacro procedure idifference(a,b); a-b; smacro procedure iquotient(a,b); a/b; smacro procedure iremainder(a,b); remainder(a,b); smacro procedure igreaterp(a,b); a>b; smacro procedure ilessp(a,b); a<b; smacro procedure iminusp a; a<0; newtok '((!#) hash); newtok '((!# !+) iplus); newtok '((!# !-) idifference); newtok '((!# !*) itimes); newtok '((!# !/) iquotient); newtok '((!# !>) igreaterp); newtok '((!# !<) ilessp); infix #+,#-,#*,#/,#>,#<; precedence #+,+; precedence #-,-; precedence #*,*; precedence #/,/; precedence #>,>; precedence #<,<; flag('(iplus itimes),'nary); deflist('((idifference iminus)),'unary); deflist('((iminus iplus)), 'alt); endmodule; module genmod; % Modular arithmetic where the modulus may be any size. % Authors: A. C. Norman and P. M. A. Moore, 1981; fluid '(current!-modulus modulus!/2); symbolic procedure set!-general!-modulus p; if not numberp p then current!-modulus else begin scalar previous!-modulus; previous!-modulus:=current!-modulus; current!-modulus:=p; modulus!/2 := p/2; return previous!-modulus end; symbolic procedure general!-modular!-plus(a,b); begin scalar result; result:=a+b; if result >= current!-modulus then result:=result-current!-modulus; return result end; symbolic procedure general!-modular!-difference(a,b); begin scalar result; result:=a-b; if result < 0 then result:=result+current!-modulus; return result end; symbolic procedure general!-modular!-number a; begin a:=remainder(a,current!-modulus); if a < 0 then a:=a+current!-modulus; return a end; symbolic procedure general!-modular!-times(a,b); begin scalar result; result:=remainder(a*b,current!-modulus); if result<0 then result := result+current!-modulus; %can this happen? return result end; symbolic procedure general!-modular!-reciprocal a; begin return general!-reciprocal!-by!-gcd(current!-modulus,a,0,1) end; symbolic procedure general!-modular!-quotient(a,b); general!-modular!-times(a,general!-modular!-reciprocal b); symbolic procedure general!-modular!-minus a; if a=0 then a else current!-modulus - a; symbolic procedure general!-reciprocal!-by!-gcd(a,b,x,y); %On input A and B should be coprime. This routine then %finds X and Y such that A*X+B*Y=1, and returns the value Y %on input A > B; if b=0 then rederr "INVALID MODULAR DIVISION" else if b=1 then if y < 0 then y+current!-modulus else y else begin scalar w; %N.B. Invalid modular division is either: % a) attempt to divide by zero directly % b) modulus is not prime, and input is not % coprime with it; w:=quotient(a,b); %Truncated integer division; return general!-reciprocal!-by!-gcd(b,a-b*w,y,x-y*w) end; %symbolic procedure general!-modular!-expt(x,n); % if not fixp n then % rederr % "ZFACT(general-modular-expt): power is not a small integer" % else if n=0 then 1 % else if n=1 then x % else % (lambda ans; % if evenp n then % general!-modular!-times(ans,ans) % else general!-modular!-times(general!-modular!-times(ans,x), % ans)) % general!-modular!-expt(x,n/2); symbolic procedure general!-modular!-expt(a,n); % a**n; if n=0 then 1 else if n=1 then a else begin scalar x; x:=general!-modular!-expt(a,n/2); x:=general!-modular!-times(x,x); if not evenp n then x:=general!-modular!-times(x,a); return x end; endmodule; module smallmod; %Small integer modular arithmetic used in factorizer. % Author: Arthur C. Norman. fluid '(current!-modulus modulus!/2); global '(largest!-small!-modulus); symbolic procedure set!-modulus p; if not numberp p or p=0 then current!-modulus else begin scalar previous!-modulus; previous!-modulus:=current!-modulus; current!-modulus:=p; modulus!/2:=p/2; set!-small!-modulus p; return previous!-modulus end; symbolic procedure set!-small!-modulus p; begin scalar previous!-modulus; if p>largest!-small!-modulus then rederr list("Overlarge modulus",p,"being used"); previous!-modulus:=current!-modulus; current!-modulus:=p; modulus!/2 := p/2; return previous!-modulus end; smacro procedure modular!-plus(a,b); begin scalar result; result:=a #+ b; if not result #< current!-modulus then result:=result #- current!-modulus; return result end; smacro procedure modular!-difference(a,b); begin scalar result; result:=a #- b; if iminusp result then result:=result #+ current!-modulus; return result end; symbolic procedure modular!-number a; begin a:=remainder(a,current!-modulus); if iminusp a then a:=a #+ current!-modulus; return a end; smacro procedure modular!-times(a,b); remainder(a*b,current!-modulus); smacro procedure modular!-reciprocal a; reciprocal!-by!-gcd(current!-modulus,a,0,1); symbolic procedure reciprocal!-by!-gcd(a,b,x,y); %On input A and B should be coprime. This routine then %finds X and Y such that A*X+B*Y=1, and returns the value Y %on input A > B; if b=0 then rederr "Invalid modular division" else if b=1 then if iminusp y then y #+ current!-modulus else y else begin scalar w; %N.B. Invalid modular division is either: % a) attempt to divide by zero directly % b) modulus is not prime, and input is not % coprime with it; w:= a #/ b; %Truncated integer division; return reciprocal!-by!-gcd(b,a #- b #* w, y,x #- y #* w) end; smacro procedure modular!-quotient(a,b); modular!-times(a,modular!-reciprocal b); smacro procedure modular!-minus a; if a=0 then a else current!-modulus #- a; symbolic procedure modular!-expt(a,n); % a**n; if n=0 then 1 else if n=1 then a else begin scalar x; x:=modular!-expt(a,n#/2); x:=modular!-times(x,x); if not (iremainder(n,2) = 0) then x:=modular!-times(x,a); return x end; symbolic set!-modulus(1) ; % forces everything into a standard state; endmodule; module random; % Random Number Generator. % Author: Unknown. global '(randomseed!* randommodulus!*); % The declarations below constitute a linear, congruential random number % generator (see Knuth, "The Art of Computer Programming: Volume 2: % Seminumerical Algorithms", pp9-24). With the given constants it has a % period of 392931 and potency 6. To have deterministic behaviour, set % RANDOMSEED. % Constants are: 6 2 % modulus: 392931 = 3 * 7 * 11 % multiplier: 232 = 3 * 7 * 11 + 1 % increment: 65537 is prime % % Would benefit from being recoded in a SysLisp style, when full word % integers could be used with "automatic" modular arithmetic (see % Knuth). Perhaps we should have a longer period version? randommodulus!* := 392931; % randomseed!* := remainder(time(),randommodulus!*); randomseed!* := 300000; % To avoid use of time function. symbolic procedure next!-random!-number; % Returns a pseudo-random number between 0 and RandomModulus-1 % (inclusive). randomseed!* := remainder(232*randomseed!* + 65537, randommodulus!*); symbolic procedure random(n); % Returns a pseudo-random number uniformly selected from the range % 0..N-1. fix( (float(n) * next!-random!-number()) / randommodulus!*); endmodule; module zfactor; % Integer factorization. % Author: Julian Padget. % exports zfactor, primep; % zfactor - returns an alist of factors dotted with their multiplicities % primep - determines whether argument is prime or not % % imports evenp, gcdn, general-modular-expt, general-modular-times, leq, % modular-expt, modular-times, neq, prin2t, rederr, reversip, % set-general-modulus, set-small-modulus; % % needs bigmod,smallmod; % % internal-functions add-factor, general-primep, mcfactor!*, % internal-primep, isqrt, mcfactor, small-primep; % Parameters to this module are: % % !*confidence!* - controls the computation in the primality test. % Probability that a number is composite when test says it is % prime is 1/(2**(2*!*confidence!*)). % % !*maxtrys!* - controls the maximum number of attempts to be made % at factorisation (using mcfactor) whilst varying the polynomial % used as part of the Monte-Carlo technique. When !*maxtrys!* is % exceeded assumes n is prime (case will most likely occur when % primality test fails). % % !*mod!* - controls the modulus of the numbers emitted by the random % number generator. It is important that the number being tested % for primality should lie in [0,!*mod!*]. % % Globals private to this module are: % % !*primelist!* - a list of the first xxx prime numbers used in the % first part of the factorisation where trial division is % employed. % % !*last!-prime!-in!-list!* - the largest prime in the !*primelist!* fluid '(!*maxtrys!* !*confidence!*); !*maxtrys!*:=10; !*confidence!*:=10; global '(!*primelist!* !*last!-prime!-in!-list!*); !*primelist!*:='( 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 )$ !*last!-prime!-in!-list!* := car reverse !*primelist!*; % the following four routines were written by John Abbot and are % incorporated here with his permission. symbolic procedure ilog2 n; % n integral; result 'r' s.t. 2**r <= abs n < 2**(r+1) if not fixp n then rederr "(ZFACTOR(ilog2):argument must be an integer" else begin scalar ans, powers!-of!-2; if n<0 then n:=-n; powers!-of!-2:=2 . nil; ans:=1; while n>=(car powers!-of!-2) do << n:=n/(car powers!-of!-2); powers!-of!-2:=((car powers!-of!-2)**2) . powers!-of!-2 >>; while (car powers!-of!-2) neq n and cdr powers!-of!-2 do << powers!-of!-2:=cdr powers!-of!-2; ans:=ans+ans; if powers!-of!-2 and n>=(car powers!-of!-2) then << n:=n/(car powers!-of!-2); ans:=ans+1 >> >>; return (ans-1) end; symbolic procedure isqrt n; irootn(n,2); symbolic procedure irootn(n,r); % n,r integral; result 's' approximates rth root of n % that is if n>0 then s**r <= n < (s+1)**r else s**r >= n > (s-1)**r % 3363/2378 is an approximation to sqrt 2; if not (fixp n and fixp r) then rederr "ZFACTOR(irootn): both arguments must be integers" else if r<=0 then rederr "ZFACTOR(irootn): non-positive integer root" else if n<0 then if evenp r then rederr "ZFACTOR(irootn): even root of a negative integer" else -irootn(-n,r) else if r=1 then n else begin scalar x,newx,upb; x:=2**(irootn!-round(1+ilog2 n,r)); newx:=x-irootn!-roundup(x-n/x**(r-1),r); upb:=(3363*x)/2378; if upb<newx then newx:=upb; repeat << x:=newx; newx:=x-irootn!-roundup(x-n/x**(r-1),r) >> until newx>=x or newx=0; return x end; symbolic procedure irootn!-round(m,n); % m,n integral, n>0, answer is nearest integer to m/n (m+n/2)/n; symbolic procedure irootn!-roundup(m,n); % m,n integral, n>0, answer is least integer >= m/n (lambda quotrem; if (cdr quotrem)=0 then car quotrem else 1+(car quotrem)) divide(m,n); symbolic procedure add!-factor(n,l); (lambda (p); if p then << rplacd(p,add1 cdr p); l>> else (n . 1) . l) if pairp l then if n>(caar l) then nil else atsoc(n,l) else nil; symbolic procedure zfactor n; if n<0 then ((-1) . 1) . zfactor(-n) else if n<4 then list (n . 1) else % trial division then advanced technology if needed (lambda (primelist,rootn,factor!-list); << while pairp primelist do (lambda aprime; << while remainder(n,aprime)=0 do << n:=n/aprime; rootn:=isqrt n; factor!-list:=add!-factor(aprime,factor!-list) >>; if rootn < aprime then << if n neq 1 then factor!-list:=add!-factor(n,factor!-list); primelist:=aprime >> else primelist:=cdr primelist >>) car primelist; if null primelist then mcfactor!*(n,factor!-list) else factor!-list >>) (!*primelist!*,isqrt n,nil); symbolic procedure mcfactor!*(n,factors!-so!-far); if internal!-primep n then add!-factor(n,factors!-so!-far) else << n:=(lambda (p,tries); << while (atom p) and (tries<!*maxtrys!*) do << tries:=tries+1; p:=mcfactor(n,tries) >>; if tries>!*maxtrys!* then << prin2 "ZFACTOR(mcfactor!*):Assuming "; prin2 n; prin2t " is prime"; p:=list n >> else p >>) (mcfactor(n,1),1); if null cdr n then add!-factor(n,factors!-so!-far) else if (car n)<(cdr n) then mcfactor!*(cdr n,mcfactor!*(car n,factors!-so!-far)) else mcfactor!*(car n,mcfactor!*(cdr n,factors!-so!-far)) >>; symbolic procedure mcfactor(n,p); % Based on "An Improved Monte-Carlo Factorisation Algorithm" by % R.P.Brent in BIT 20 (1980) pp 176-184. Argument n is the number to % factor, p specifies the constant term of the polynomial. There are % supposed to be optimal p's for each n, but in general p=1 works well. begin scalar gg,k,m,q,r,x,y,ys; y:=0; r:=q:=m:=1; outer: x:=y; for i:=1:r do y:=remainder(y*y+p,n); k:=0; inner: ys:=y; for i:=1:(if m<(r-k) then m else r-k) do << y:=remainder(y*y+p,n); q:=remainder(q*abs(x-y),n) >>; gg:=gcdn(q,n); k:=k+m; if (k<r) and (gg leq 1) then goto inner; r:=2*r; if gg leq 1 then goto outer; if gg=n then begin loop: ys:=remainder(ys*ys+p,n); gg:=gcdn(abs(x-ys),n); if gg leq 1 then goto loop end; return if gg=n then n else gg . (n/gg) end; symbolic procedure primep n; if n member !*primelist!* then t else if (isqrt n)<!*last!-prime!-in!-list!* then begin scalar p; p:=!*primelist!*; loop: if remainder(n,car p)=0 then return nil; if null(p:=cdr p) then return t; go loop end else if n>largest!-small!-modulus then general!-primep n else small!-primep n; symbolic procedure internal!-primep n; if n>largest!-small!-modulus then general!-primep n else small!-primep n; symbolic procedure small!-primep n; % Based on an algorithm of M.Rabin published in the Journal of Number % Theory Vol 12, pp 128-138 (1980). This version uses small modular % arithmetic which can be open coded. begin scalar i,m,l,b2m,result,x,!*mod!*; m:=n-1; l:=0; set!-small!-modulus n; % first a quick check for compositeness if modular!-expt(3,m) neq 1 then return nil; i:=20; while (!*mod!*:=2**i)<n do i:=i+4; % construct (2**l)*m from n-1 while evenp m do << m:=m/2; l:=l+1 >>; i:=1; result:=t; b2m:=mkvect l; while result and i<=!*confidence!* do << % pick a potential witness % make a vector of b**(2*m) up to b**((2**l)*m) x:=putv(b2m,1,modular!-expt(remainder(random(!*mod!*),n),m+m)); for j:=2:l do x:=putv(b2m,j,modular!-times(x,x)); % neq 1 implies a witness that n is composite if getv(b2m,l)=1 then for j:=1:l do << if result then << x:=gcdn(getv(b2m,j)-1,n); if (x neq 1) and (x neq n) then result:=nil >> >> else result:=nil; i:=i+1 >>; return result end; symbolic procedure general!-primep n; % Based on an algorithm of M.Rabin published in the Journal of Number % Theory Vol 12, pp 128-138 (1980). This version uses general modular % arithmetic which is somewhat more expensive than the above routine begin scalar i,m,l,b2m,result,x,!*mod!*; m:=n-1; l:=0; set!-general!-modulus n; % first a quick check for compositeness if general!-modular!-expt(3,m) neq 1 then return nil; i:=32; while (!*mod!*:=2**i)<n do i:=i+4; % construct (2**l)*m from n-1 while evenp m do << m:=m/2; l:=l+1 >>; i:=1; result:=t; b2m:=mkvect l; while result and i<=!*confidence!* do << % pick a potential witness % make a vector of b**(2*m) up to b**((2**l)*m) x:=putv(b2m,1, general!-modular!-expt(remainder(random(!*mod!*),n),m+m)); for j:=2:l do x:=putv(b2m,j,general!-modular!-times(x,x)); % /=1 implies a witness that n is composite if getv(b2m,l)=1 then for j:=1:l do << if result then << x:=gcdn(getv(b2m,j)-1,n); if (x neq 1) and (x neq n) then result:=nil >> >> else result:=nil; i:=i+1 >>; return result end; endmodule; end; |
Added r33/bfloat.red version [6a4733a467].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module bfloat; % Routines for arbitrary precision real arithmetic. % Author: T. Sasaki, 1979. % Modifications by: Anthony C. Hearn (interface to algebraic mode) % Jed B. Marti (general cleanup) global '(bfsaveprec!* !*nat !:prec!: domainlist!*); % BFSAVEPREC!* is precision at which to save constants. If NIL, use % !:PREC!: otherwise use value of this global (usually set in REND). % Constants for use during this package. These are set at the % end of this package. global '(!:bf!-pi %PI to 20 digits. !:bf!-0 %0.0 !:bf!-1 %1.0 !:bf!-e %E to 20 digits !:bf!-0!.5 %0.5 !:bf!-0!.25 %0.25 !:bf!-0!.1 %0.1 !:bf!-1!.72 %1.72 !:bf!-0!.42 %0.42 !:bf!-0!.72 %0.72 ); switch bigfloat; comment *** Tables for Bigfloats ***; domainlist!* := union('(!:bf!:),domainlist!*); put('bigfloat,'tag,'!:bf!:); put('!:bf!:,'dname,'bigfloat); flag('(!:bf!:),'field); put('!:bf!:,'i2d,'i2bf!:); put('!:ft!:,'!:bf!:,'!*ft2bf); put('!:rn!:,'!:bf!:,'!*rn2bf); put('!:bf!:,'minusp,'minusp!:); put('!:bf!:,'plus,'bfplus!:); put('!:bf!:,'times,'ttimes!:); put('!:bf!:,'difference,'tdifference!:); put('!:bf!:,'quotient,'bfquotient!:); put('!:bf!:,'zerop,'bfzerop!:); put('!:bf!:,'onep,'bfonep!:); put('!:bf!:,'prepfn,'bfprep!:); put('!:bf!:,'prifn,'bfprin!:); put('!:bf!:,'cmpxtype,list '!:gbf!:); comment SMACROS needed; symbolic smacro procedure mt!:(nmbr); % This function selects the mantissa of a number "n". % NMBR is a BIG-FLOAT representation of "n". cadr nmbr; symbolic smacro procedure ep!:(nmbr); % This function selects the exponent of a number "n". % NMBR is a BIG-FLOAT representation of "n". cddr nmbr; symbolic procedure i2bf!: u; '!:bf!: . u . 0; symbolic procedure !*rn2bf u; begin scalar x; x := get('!:bf!:,'i2d); return apply2(get('!:bf!:,'quotient), apply(x,list cadr u),apply(x,list cddr u)) end; symbolic procedure !*ft2bf u; conv!:a2bf cdr u; symbolic procedure bfplus!:(u,v); % Value is sum of U and V, or tagged bigfloat zero if outside % precision. begin scalar x,y; x := tplus!:(u,v); y := '!:bf!: . abs mt!: x . (ep!: x+!:prec!:-1); return if lessp!:(y,abs!: u) and lessp!:(y,abs!: v) then '!:bf!: . (0 . ep!: x) else x end; symbolic procedure bfquotient!:(u,v); divide!:(u,v,!:prec!:); symbolic procedure bfzerop!: u; % This is possibly too restricted a definition. mt!: u = 0; symbolic procedure bfonep!: u; % allow for roundup of four in the last place. begin scalar x,y; y := ep!: u + !:prec!:; if not(y=0 or y=1) then return; x := mt!: u*10**y - 10**!:prec!:; return (x<=0 and x>=-4) end; symbolic procedure bfprep!: u; u; symbolic procedure bfprin!: u; % Print tagged bigfloat U. bfprin cdr u; symbolic procedure bfprin nmbr; %prints a big-float in a variety of formats. Still needs work %for fortran output; begin integer j,k; scalar u,v; nmbr := round!:mt('!:bf!: . nmbr,!:prec!:-2); if bfzerop!:(nmbr) then return prin2!* '!0; u := explode abs(j := mt!: nmbr); k := ep!: nmbr; if k>=0 then if k>5 then go to etype else <<v := list('!.,'!0); while (k := k-1)>=0 do v := '!0 . v; u := nconc(u,v)>> else if (k := order!:(nmbr)+1)>0 then <<v := u; while (k := k-1)>0 do v := cdr v; rplacd(v,'!. . cdr v)>> else if k<-10 then go to etype else <<while (k := k+1)<=0 do u := '!0 . u; u := '!0 . '!. . u>>; bfprin1(u,j); return nmbr; etype: if null( cdr(u)) then rplacd(u , list('!0)); u:= car u . '!. . cdr u; j := bfprin1(u,j); if j=0 then <<prin2!*("E " ); j:=2>> else if j=1 then <<prin2!*(" E " ); j:=4>> else if j=2 then <<prin2!*(" E "); j:=0>> else if j=3 then <<prin2!*(" E " ); j:=0>> else if j=4 then <<prin2!*(" E "); j:=2>>; u:=explode( k:=order!:(nmbr)); if k>=0 then u:=cons('!+,u); while u do <<prin2!*( car(u)); u:=cdr(u); j:=j+1; if j=5 then <<prin2!*(" "); j:=0>> >>; return nmbr end; symbolic procedure bfprin1(u,j); begin scalar v,w; if j<0 then u := '!- . u; %suppress trailing zeros; v := u; while not(car v eq '!.) do v := cdr v; v := cdr v; l: while cdr v and not(cadr v eq '!0) do v := cdr v; w := cdr v; while w and car w eq '!0 do w := cdr w; if null w then rplacd(v,nil) else <<v := w; go to l>>; %now print the number; j := 0; for each char in u do <<prin2!* char; j := j+1; if j=5 then <<if !*nat then prin2!* '! ; j := 0>>>>; return j end; symbolic procedure bflerrmsg u; %Standard error message for BFLOAT module; rederr list("Invalid argument to",u); % Simp property for !:BF!: since PREP is identity. symbolic procedure !:bf!:simp u; ('!:bf!: . u) ./ 1; put('!:bf!:,'simpfn,'!:bf!:simp); !:prec!: := 12; %default value; initdmode 'bigfloat; symbolic procedure precision n; if n=0 then !:prec!:-2 else <<!:prec!: := n+2; n>>; flag('(precision),'opfn); % symbolic operator precision; % *** Tables for Elementary Function and Constant Values *** deflist('((exp exp!*) (expt bfexpt!:) (log log!*) (sin sin!*) (cos cos!*) (tan tan!*) (asin asin!*) (acos acos!*) (atan atan!*) (sqrt sqrt!*) (sinh sinh!*) (cosh cosh!*) (e e!*) (pi pi!*)), '!:bf!:); symbolic procedure bfexpt!:(u,v); % Calculates u**v, including case u<0. if minusp!: u then multd(texpt!:any(minus!: u,v), !*q2f if null numr simp list('difference,v, '(quotient 1 2)) then simp 'i else mksq(list('expt,'(minus 1),v),1)) else texpt!:any(u,v); symbolic procedure exp!* u; exp!:(u,!:prec!:); symbolic procedure log!* u; log!:(u,!:prec!:); symbolic procedure sin!* u; sin!:(u,!:prec!:); symbolic procedure cos!* u; cos!:(u,!:prec!:); symbolic procedure tan!* u; tan!:(u,!:prec!:); symbolic procedure asin!* u; asin!:(u,!:prec!:); symbolic procedure acos!* u; acos!:(u,!:prec!:); symbolic procedure atan!* u; atan!:(u,!:prec!:); symbolic procedure sqrt!* u; sqrt!:(u,!:prec!:); symbolic procedure sinh!* u; ttimes!:(conv!:a2bf 0.5, tdifference!:(exp!* u,exp!* !:minus u)); symbolic procedure cosh!* u; ttimes!:(conv!:a2bf 0.5, bfplus!:(exp!* u,exp!* !:minus u)); symbolic procedure pi!*; if !:prec!:>1000 then !:bigpi !:prec!: else !:pi !:prec!:; symbolic procedure e!*; !:e !:prec!:; %************************************************************* %************************************************************* %** ** %** ARBITRARY PRECISION REAL ARITHMETIC SYSTEM ** %** machine-independent version ** %** ** %** made by ** %** ** %** Tateaki Sasaki ** %** ** %** The University of Utah, March 1979 ** %** ** %**=========================================================** %** ** %** For design philosophy and characteristics of this ** %** system, see T. Sasaki, "An Arbitrary Precision ** %** Real Arithmetic Package in REDUCE," Proceedings ** %** of EUROSAM '79, Marseille (France), June 1979. ** %** ** %** For implementing and using this system, see T. Sasaki, ** %** "Manual for Arbitrary Precision Real Arithmetic ** %** System in REDUCE," Operating Report of Utah Sym- ** %** bolic Computation Group. ** %** ** %**=========================================================** %** ** %** In order to speed up this system, you have only to ** %** rewrite four routines (DECPREC!:, INCPREC!:, ** %** PRECI!:, and ROUND!:LAST) machine-dependently. ** %** ** %**=========================================================** %** ** %** Table of Contents ** %** ** %** 1-1. Initialization. ** %** 1-2. Constructor, selectors and basic predicate. ** %** 1-3. Temporary routines for rational number arithmetic. ** %** 1-4. Counters. ** %** 1-5. Routines for converting the numeric type. ** %** 1-6. Routines for converting a big-float number. ** %** 1-7. Routines for reading/printing numbers. ** %** 2-1. Arithmetic manipulation routines. ** %** 2-2. Arithmetic predicates. ** %** 3-1. Elementary constants. ** %** 3-2. Routines for saving constants. ** %** 4-1. Elementary functions. ** %** 5-1. Appendix: routines for defining infix operators. ** %** ** %************************************************************* %************************************************************* %************************************************************* %** ** %** 1-1. Initialization. ** %** ** %************************************************************* %************************************************************* %** ** %** 1-2. CONSTRUCTOR, SELECTORS and basic PREDICATE. ** %** ** %************************************************************* symbolic smacro procedure make!:bf(mt,ep); % MT and EP are any integers (positive or negative). So, % you can handle any big or small numbers. In this % sense, "BF" denotes a BIG-FLOATING-POINT number. % Hereafter, an internal representation of a number % constructed by MAKE!:BF is referred to as a % BIG-FLOAT representation. cons('!:bf!: , cons(mt,ep))$ symbolic procedure bfp!:(x); % This function returns T if X is a BIG-FLOAT % representation, else it returns NIL. % X is any LISP entity. if atom(x) then nil else if car(x) eq '!:bf!: then t else nil$ %************************************************************* %** ** %** 1-3. Temporary routines for rational number arithmetic. ** %** ** %************************************************************* symbolic procedure make!:ratnum(nm,dn); % This function constructs an internal representation % of a rational number composed of the numerator % NM and the denominator DN. % NM and DN are any integers (positive or negative). % **** Four routines in this section are temporary. % **** That is, if your system has own routines % **** for rational number arithmetic, you can % **** accommodate our system to yours only by % **** redefining these four routines. if zerop dn then rederr "ZERO DENOMINATOR IN MAKE!:RATNUM" else if dn > 0 then '!:ratnum!: . (nm . dn) else '!:ratnum!: . (-nm . -dn); symbolic procedure ratnump!:(x); % This function returns T if X is a rational number % representation, else it returns NIL. % X is any LISP entity. eqcar(x, '!:ratnum!:); %JBM Change to EQCAR. symbolic smacro procedure numr!: rnmbr; % This function selects the numerator of a rational % number "n". % RNMBR is a rational number representation of "n". cadr rnmbr$ symbolic smacro procedure denm!: rnmbr; % This function selects the denominator of a rational % number "n". % RNMBR is a rational number representation of "n". cddr rnmbr$ %************************************************************* %** ** %** 1-4. COUNTERS. ** %** ** %************************************************************* symbolic smacro procedure preci!: nmbr; % This function counts the precision of a number "n". % NMBR is a BIG-FLOAT representation of "n". length explode abs mt!: nmbr$ symbolic procedure order!: nmbr; % This function counts the order of a number "n". % NMBR is a BIG-FLOAT representation of "n". % **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1) % **** when n is not 0, and ORDER(0)=0. if mt!: nmbr = 0 then 0 else preci!: nmbr + ep!: nmbr - 1$ %************************************************************* %** ** %** 1-5. Routines for converting the numeric type. ** %** ** %************************************************************* symbolic procedure conv!:a2bf(n); % This function converts a number N or a number-like % entity N to a <BIG-FLOAT>, i.e., a BIG-FLOAT % representation of N. % N is either an integer, a floating-point number, % a string representing a number, a rational % number, or a <BIG-FLOAT>. % **** This function is the most general conversion % **** function to get a BIG-FLOAT representation. % **** In this sense, A means an Arbitrary number. % **** A rational number is converted to a <BIG-FLOAT> % **** of precision !:PREC!: if !:PREC!: is not % **** NIL, else the precision is set 50. if bfp!: n then n else if fixp n then make!:bf(n, 0) else if floatp n then read!:num n else if stringp n then read!:num n else if ratnump!: n then conv!:r2bf(n, if !:prec!: then !:prec!: else 50) else if not atom n and idp car n and get(car n,'dname) then apply(get(car n,'!:bf!:),list n) else bflerrmsg 'conv!:a2bf$ symbolic procedure conv!:f2bf fnmbr; % This function converts a floating-point number % FNMBR to a <BIG-FLOAT>, i.e., a BIG-FLOAT % representation. % FNMBR is a floating-point number. % **** CAUTION!. If you input a number, say, 0.1, % **** some systems do not accept it as 0.1 % **** but may accept it as 0.09999999. % **** In such a case, you had better use % **** CONV!:S2BF than to use CONV!:F2BF. if floatp fnmbr then read!:num fnmbr else bflerrmsg 'conv!:f2bf$ symbolic procedure conv!:i2bf intgr; % This function converts an integer INTGR to a <BIG- % FLOAT>, i.e., a BIG-FLOAT representation. % INTGR is an integer. if fixp intgr then make!:bf(intgr, 0) else bflerrmsg 'conv!:i2bf$ symbolic procedure conv!:r2bf(rnmbr,k); % This function converts a rational number RNMBR to a % <BIG-FLOAT> of precision K, i.e., a BIG-FLOAT % representation with a given precision. % RNMBR is a rational number representation. % K is a positive integer. if ratnump!: rnmbr and fixp k and k > 0 then divide!:( make!:bf( numr!: rnmbr, 0), make!:bf( denm!: rnmbr, 0), k) else bflerrmsg 'conv!:r2bf$ symbolic procedure conv!:s2bf strng; % This function converts a string representing % a number "n" to a <BIG-FLOAT>, i.e., % a BIG-FLOAT representation. % STRNG is a string representing "n". "n" may % be an integer, a floating-point number % of any precision, or a rational number. % **** CAUTION! Some systems may set the % **** maximum size of string. if stringp strng then read!:num strng else bflerrmsg 'conv!:s2bf$ symbolic procedure conv!:bf2f nmbr; % This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT % representation of "n", to a floating-point number. % NMBR is a BIG-FLOAT representation of the number "n". if bfp!: nmbr then float mt!: nmbr * float(10 ** ep!: nmbr) else bflerrmsg 'conv!:bf2f$ symbolic procedure conv!:bf2i nmbr; % This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT % representation of "n", to an integer. The result % is the integer part of "n". % **** For getting the nearest integer to "n", please use % **** the combination MT!:( CONV!:EP(NMBR,0)). % NMBR is a BIG-FLOAT representation of the number "n". if bfp!: nmbr then if ep!:(nmbr := cut!:ep(nmbr, 0)) = 0 then mt!: nmbr else mt!: nmbr * 10 ** ep!: nmbr else bflerrmsg 'conv!:bf2i$ symbolic procedure conv!:bf2r nmbr; % This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT % representation of "n", to a rational number. % NMBR is a BIG-FLOAT representation of "n". % **** The numerator and the denominator of the result % **** have no common divisor. if bfp!: nmbr then begin integer nn,nd,m,n,q; if (q := ep!: nmbr) >= 0 then << nn := mt!: nmbr * 10**q; nd := 1; m := 1 >> else << nn := mt!: nmbr; nd := 10 ** -q; if abs nn > abs nd then <<m := nn; n := nd >> else << m := nd; n:= nn >>; while not(n = 0) do << q := remainder(m, n); m := n; n := q >> >>; return make!:ratnum(nn/m, nd/m); end else bflerrmsg 'conv!:bf2r$ %************************************************************* %** ** %** 1-6. Routines for converting a BIG-FLOAT number. ** %** ** %************************************************************* symbolic procedure decprec!:(nmbr, k); % This function converts a number "n" to an equivalent % number the precision of which is decreased by K. % **** CAUTION! No rounding is made. % NMBR is a BIG-FLOAT representation of "n". % K is a positive integer. make!:bf( mt!: nmbr / 10**k, ep!: nmbr + k)$ symbolic procedure incprec!:(nmbr, k); % This function converts a number "n" to an equivalent % number the precision of which is increased by K. % **** CAUTION! No rounding is made. % NMBR is a BIG-FLOAT representation of "n". % K is a positive integer. make!:bf( mt!: nmbr * 10**k, ep!: nmbr - k)$ symbolic procedure conv!:mt(nmbr, k); % This function converts a number "n" to an % equivalent number of precision K by % rounding "n" or adding "0"s to "n". % NMBR is a BIG-FLOAT representation of "n". % K is a positive integer. if bfp!: nmbr and fixp k and k > 0 then if (k := preci!: nmbr - k) = 0 then nmbr else if k < 0 then incprec!:(nmbr, -k) else round!:last(decprec!:(nmbr, k - 1)) else bflerrmsg 'conv!:mt$ symbolic procedure conv!:ep(nmbr, k); % This function converts a number "n" to an % equivalent number having the exponent K % by rounding "n" or adding "0"s to "n". % NMBR is a BIG-FLOAT representation of "n". % K is an integer (positive or negative). if bfp!: nmbr and fixp k then if (k := k - ep!: nmbr) = 0 then nmbr else if k < 0 then incprec!:(nmbr, -k) else round!:last(decprec!:(nmbr, k - 1)) else bflerrmsg 'conv!:ep$ symbolic procedure cut!:mt(nmbr,k); % This function returns a given number "n" unchanged % if its precision is not greater than K, else it % cuts off its mantissa at the (K+1)th place and % returns an equivalent number of precision K. % **** CAUTION! No rounding is made. % NMBR is a BIG-FLOAT representation of "n". % K is a positive integer. if bfp!: nmbr and fixp k and k > 0 then if (k := preci!: nmbr - k) <= 0 then nmbr else decprec!:(nmbr, k) else bflerrmsg 'cut!:mt$ symbolic procedure cut!:ep(nmbr, k); % This function returns a given number "n" unchanged % if its exponent is not less than K, else it % cuts off its mantissa and returns an equivalent % number of exponent K. % **** CAUTION! No rounding is made. % NMBR is a BIG-FLOAT representation of "n". % K is an integer (positive or negative). if bfp!: nmbr and fixp k then if (k := k - ep!: nmbr) <= 0 then nmbr else decprec!:(nmbr, k) else bflerrmsg 'cut!:ep$ symbolic procedure match!:(n1,n2); % This function converts either "n1" or "n2" so that they % have the same exponent, which is the smaller of % the exponents of "n1" and "n2". % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". % **** CAUTION! Using this function, one of the previous % **** expressions of "n1" and "n2" is lost. if bfp!: n1 and bfp!: n2 then begin integer e1,e2; scalar n; if (e1 := ep!: n1) = (e2 := ep!: n2) then return t; if e1 > e2 then << rplaca(n1, car(n := conv!:ep(n1, e2))); rplacd(n1, cdr n) >> else << rplaca(n2, car(n := conv!:ep(n2, e1))); rplacd(n2, cdr n) >>; return t; end else bflerrmsg 'match!:$ symbolic procedure round!:mt(nmbr, k); % This function rounds a number "n" at the (K+1)th place % and returns an equivalent number of precision K % if the precision of "n" is greater than K, else % it returns the given number unchanged. % NMBR is a BIG-FLOAT representation of "n". % K is a positive integer. if bfp!: nmbr and fixp k and k > 0 then if (k := preci!: nmbr - k - 1) < 0 then nmbr else if k = 0 then round!:last nmbr else round!:last decprec!:(nmbr, k) else bflerrmsg 'round!:mt$ symbolic procedure round!:ep(nmbr, k); % This function rounds a number "n" and returns an % equivalent number having the exponent K if % the exponent of "n" is less than K, else % it returns the given number unchanged. % NMBR is a BIG-FLOAT representation of "n". % K is an integer (positive or negative). if bfp!: nmbr and fixp k then if (k := k - 1 - ep!: nmbr) < 0 then nmbr else if k = 0 then round!:last nmbr else round!:last decprec!:(nmbr, k) else bflerrmsg 'round!:ep$ symbolic procedure round!:last nmbr; % This function rounds a number "n" at its last place. % NMBR is a BIG-FLOAT representation of "n". begin scalar n; n := divide(abs mt!: nmbr, 10); if cdr n < 5 then n := car n else n := car n + 1; if mt!: nmbr < 0 then n := -n; return make!:bf(n, ep!: nmbr + 1); end$ %************************************************************* %** ** %** 1-7. Routines for reading/printing numbers. ** %** ** %************************************************************* symbolic procedure allfixp l; %JBM % Returns T if all of L are FIXP. %JBM if null l then t %JBM else if not fixp car l then nil %JBM else allfixp cdr l; %JBM symbolic procedure read!:lnum(l); % This function reads a long number "n" represented by a list in a way % described below, and constructs a BIG-FLOAT representation of "n". % L is a list of integers, the first element of which gives the order of % "n" and all the next elements when concatenated give the mantissa of % "n". % **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1). % **** Except for the first element, all integers in L % **** should not begin with "0" because some % **** systems suppress leading zeros. % JBM: Fix some kludgy coding here. % JBM: Add BFSAVEPREC!* precision saver. if not allfixp l then bflerrmsg 'read!:lnum else begin scalar mt, ep, k, sign, u, v, dcnt; mt := dcnt := 0; %JBM % ep := car(u := l) + 1; %JBM u := l; ep := add1 car u; sign := if minusp cadr l then -1 else 1; %JBM while u:=cdr u do << k := length explode(v := abs car u); %JBM % k := 0; %JBM % while v do << k := k + 1; v := cdr v >>; %JBM mt := mt * 10**k + v; %JBM ep := ep - k; dcnt := dcnt + k; % JBM if bfsaveprec!* and dcnt > bfsaveprec!* then %JBM u := '(nil) >>; %JBM return make!:bf(sign * mt, ep); end$ symbolic procedure read!:num(n); % This function reads a number or a number-like entity N % and constructs a BIG-FLOAT representation of it. % N is an integer, a floating-point number, or a string % representing a number. % **** If the system does not accept or may incorrectly % **** accept the floating-point numbers, you can % **** input them as strings such as "1.234E-56", % **** "-78.90 D+12" , "+3456 B -78", or "901/234". % **** A rational number in a string form is converted % **** to a <BIG-FLOAT> of precision !:PREC!: if % **** !:PREC!: is not NIL, else the precision of % **** the result is set 50. % **** Some systems set the maximum size of strings. If % **** you want to input long numbers exceeding % **** such a maximum size, please use READ!:LNUM. if fixp n then make!:bf(n, 0) else if not(numberp n or stringp n) then bflerrmsg 'read!:num else begin integer j,m,sign; scalar ch,u,v,l,appear!.,appear!/; j := m := 0; sign := 1; u := v := appear!. := appear!/ := nil; l := explode n; loop: ch := car l; if digit ch then << u := ch . u; j := j + 1 >> else if ch eq '!. then << appear!. := t; j := 0 >> else if ch eq '!/ then << appear!/ := t; v := u; u := nil >> else if ch eq '!- then sign := -1 else if ch memq '(!E !D !B !e !d !b) then go to jump; %JBM endl: if l := cdr l then goto loop else goto make; jump: while l := cdr l do <<if digit(ch := car l) or ch eq '!- then v := ch . v >>; l := reverse v; if car l eq '!- then m := - compress cdr l else m:= compress l; make: u := reverse u; v := reverse v; if appear!/ then return conv!:r2bf(make!:ratnum(sign*compress v,compress u), if !:prec!: then !:prec!: else 50); if appear!. then j := - j else j := 0; if sign = 1 then u := compress u else u := - compress u; return make!:bf(u, j + m); end$ symbolic procedure print!:bf(nmbr, type); % This function prints a number "n" in the print-type TYPE. % NMBR is a BIG-FLOAT representation of "n". % TYPE is either 'N, 'I, 'E, 'F, 'L, 'R, meaning as: % TYPE='N ... the internal representation is printed. % TYPE='I ... the integer part is printed. % TYPE='E ... <mantissa in form *.***>E<exponent>. % TYPE='F ... <integer part>.<decimal part>. % TYPE='L ... in a list form readable by READ!:LNUM. % TYPE='R ... printed as a rational number. % **** The number is printed by being inserted a blank % **** after each five characters. Therefore, you % **** can not use the printed numbers as input data, % **** except when they are printed in type 'L. if not(type memq '(n i e f l r)) %JBM or not bfp!: nmbr then bflerrmsg 'print!:bf else begin integer j,k; scalar u,v; % if bfzerop!: nmbr then nmbr:=make!:bf(0, 0); if bfzerop!: nmbr then nmbr := !:bf!-0; %JBM if type eq 'i then goto itype else if type eq 'e then goto etype else if type eq 'f then goto ftype else if type eq 'l then goto ltype else if type eq 'r then goto rtype; ntype: print nmbr; return t; itype: u := explode conv!:bf2i nmbr; j := 0; while u do << prin2 car u; u := cdr u; j := j + 1; if j = 5 then << prin2 " "; j := 0 >> >>; terpri(); return t; etype: u := explode abs(j := mt!: nmbr); if null cdr u then rplacd(u , list 0); if j >= 0 then u := car u . ('!. . cdr u) else u := '!- . (car u . ('!. . cdr u)); j := 0; while u do << prin2 car u; u := cdr u; j := j + 1; if j = 5 then << prin2 " "; j := 0 >> >>; if j = 0 then << prin2 "E "; j := 2 >> else if j = 1 then << prin2 " E "; j := 4 >> else if j = 2 then << prin2 " E "; j := 0 >> else if j = 3 then << prin2 " E "; j := 0 >> else if j = 4 then << prin2 " E "; j := 2 >>; u := explode(k := order!: nmbr); if k >= 0 then u := '!+ . u; while u do << prin2 car u; u := cdr u; j := j + 1; if j=5 then << prin2 " "; j := 0 >> >>; terpri(); return t; ftype: u := explode abs mt!: nmbr; if (j := ep!: nmbr) >= 0 then << v := nil; while (j := j - 1) >= 0 do v := 0 . v; u := nconc(u, v) >> else if (j := order!: nmbr + 1) > 0 then << v := u; while (j := j - 1) > 0 do v := cdr v; rplacd(v, '!. . cdr v) >> else << while (j := j + 1) <= 0 do u := 0 . u; u := 0 . ('!. . u) >>; if mt!: nmbr < 0 then u := '!- . u; j := 0; while u do << prin2 car u; u := cdr u; j := j + 1; if j = 5 then << prin2 " "; j := 0 >> >>; terpri(); return t; ltype: prin2 " '("; prin2 order!: nmbr; prin2 " "; u := explode mt!: nmbr; j := 0; while u do << prin2 car u; u := cdr u; j := j + 1; if j >= 5 and u and not(car u eq '!0) then <<prin2 " "; j := j - 5 >> >>; prin2 ")"; terpri(); return t; rtype: print!:ratnum conv!:bf2r nmbr; return t; end$ symbolic procedure print!:ratnum rnmbr; % This function prints a rational number "n". % RNMBR is a rational number representation of "n". % **** The number is printed by being inserted a blank % **** after each five characters. So, you can % **** not use the printed numbers as input data. if not ratnump!: rnmbr then bflerrmsg 'print!:ratnum else begin integer j; scalar u, v; u := numr!: rnmbr; v := denm!: rnmbr; if v < 0 then << u := - u; v := - v >>; j := 0; for each d in explode u %JBM loop here. do << prin2 d; j := j + 1; if j = 5 then << prin2 " "; j := 0 >> >>; if j = 0 then << prin2 "/ "; j := 2 >> else if j = 1 then << prin2 " / "; j := 4 >> else if j = 2 then << prin2 " / "; j := 0 >> else if j = 3 then << prin2 " / "; j := 0 >> else if j = 4 then << prin2 " / "; j := 2 >>; for each d in explode v %JBM loop here. do << prin2 d; j := j + 1; if j = 5 then << prin2 " "; j := 0 >> >>; terpri(); return t; end$ %************************************************************* %** ** %** 2-1. Arithmetic manipulation routines. ** %** ** %************************************************************* symbolic procedure abs!: nmbr; % This function makes the absolute value of "n". % N is a BIG-FLOAT representation of "n". if mt!: nmbr > 0 then nmbr else make!:bf(- mt!: nmbr, ep!: nmbr)$ symbolic procedure minus!: nmbr; % This function makes the minus number of "n". % N is a BIG-FLOAT representation of "n". make!:bf(- mt!: nmbr, ep!: nmbr)$ symbolic procedure plus!:(n1, n2); % This function calculates the sum of "n1" and "n2". % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". begin integer e1, e2; if (e1 := ep!: n1) = (e2 := ep!: n2) then return make!:bf(mt!: n1 + mt!: n2, e1) else if e1 > e2 then return make!:bf(mt!: incprec!:(n1, e1 - e2) + mt!: n2, e2) else return make!:bf(mt!: n1 + mt!: incprec!:(n2, e2 - e1), e1); end$ symbolic procedure difference!:(n1, n2); % This function calculates the difference of "n1" and "n2". % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". begin integer e1,e2; if (e1 := ep!: n1) = (e2 := ep!: n2) then return make!:bf(mt!: n1 - mt!: n2, e1) else if e1 > e2 then return make!:bf(mt!: incprec!:(n1, e1 - e2) - mt!: n2, e2) else return make!:bf(mt!: n1 - mt!: incprec!:(n2, e2 - e1), e1); end$ symbolic procedure times!:(n1, n2); % This function calculates the product of "n1" and "n2". % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". make!:bf(mt!: n1 * mt!: n2, ep!: n1 + ep!: n2)$ symbolic procedure divide!:(n1,n2,k); % This function calculates the quotient of "n1" and "n2", % with the precision K, by rounding the ratio of "n1" % and "n2" at the (K+1)th place. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". % K is any positive integer. begin n1 := conv!:mt(n1, k + preci!: n2 + 1); n1 := make!:bf(mt!: n1 / mt!: n2, ep!: n1 - ep!: n2); return round!:mt(n1, k); end$ symbolic procedure expt!:(nmbr, k); % This function calculates the Kth power of "n". % The result will become a long number if % ABS(K) >> 1. % NMBR is a BIG-FLOAT representation of "n". % K is an integer (positive or negative). % **** For calculating a power X**K, with non- % **** integer K, please use TEXPT!:ANY. if k >= 0 then make!:bf(mt!: nmbr ** k, ep!: nmbr * k) % else divide!:(make!:bf(1, 0), expt!:(nmbr, - k), else divide!:(!:bf!-1, expt!:(nmbr, - k), %JBM - preci!: nmbr * k)$ symbolic procedure tplus!:(n1, n2); % This function calculates the sum of "n1" and "n2" % up to a precision specified by !:PREC!: or N1 or N2. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2", % otherwise they are converted to <BIG-FLOAT>'s. if bfp!:(n1 := conv!:a2bf n1) and bfp!:(n2 := conv!:a2bf n2) then round!:mt(plus!:(n1, n2), (if !:prec!: then !:prec!: else max(preci!: n1, preci!: n2))) else bflerrmsg 'tplus!:$ symbolic procedure tdifference!:(n1, n2); % This function calculates the difference of "n1" and "n2" % up to a precision specified by !:PREC!: or N1 or N2. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2", % otherwise they are converted to <BIG-FLOAT>'s. if bfp!:(n1 := conv!:a2bf n1) and bfp!:(n2 := conv!:a2bf n2) then round!:mt(difference!:(n1, n2), (if !:prec!: then !:prec!: else max(preci!: n1, preci!: n2))) else bflerrmsg 'tdifference!:$ symbolic procedure ttimes!:(n1, n2); % This function calculates the product of "n1" and "n2" % up to a precision specified by !:PREC!: or N1 or N2. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2", % otherwise they are converted to <BIG-FLOAT>'s. if bfp!:(n1 := conv!:a2bf n1) and bfp!:(n2 := conv!:a2bf n2) then round!:mt(times!:(n1, n2), (if !:prec!: then !:prec!: else max(preci!: n1, preci!: n2))) else bflerrmsg 'ttimes!:$ symbolic procedure tdivide!:(n1, n2); % This function calculates the quotient of "n1" and "n2" % up to a precision specified by !:PREC!: or N1 or N2. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2", % otherwise they are converted to <BIG-FLOAT>'s. if bfp!:(n1 := conv!:a2bf n1) and bfp!:(n2 := conv!:a2bf n2) then divide!:(n1, n2, (if !:prec!: then !:prec!: else max(preci!: n1, preci!: n2))) else bflerrmsg 'tdivide!:$ symbolic procedure texpt!:(nmbr, k); % This function calculates the Kth power of "n" up to % the precision specified by !:PREC!: or NMBR. % NMBR is a BIG-FLOAT representation of "n", % otherwise it is converted to a <BIG-FLOAT>. % K is an integer (positive or negative). % **** For calculating a power X**K, where K is not % **** an integer, please use TEXPT!:ANY. if bfp!:(nmbr := conv!:a2bf nmbr) and fixp k then % if k = 0 then make!:bf(1, 0) if zerop k then !:bf!-1 %JBM else if k = 1 then nmbr % else if k < 0 then tdivide!:(make!:bf(1, 0), else if minusp k then tdivide!:(!:bf!-1, %JBM texpt!:(nmbr, - k)) else texpt!:cal(nmbr, k, (if !:prec!: then !:prec!: else preci!: nmbr)) else bflerrmsg 'texpt!:$ symbolic procedure texpt!:cal(nmbr,k,prec); if k=1 then nmbr else begin integer k2; scalar u; u := round!:mt(times!:(nmbr, nmbr), prec); if k = 2 then return u else if (k - 2 * (k2 := k / 2)) = 0 then return texpt!:cal(u, k2, prec) else return round!:mt (times!:(nmbr, texpt!:cal(u, k2, prec)), prec); end$ symbolic procedure quotient!:(n1, n2); % This function calculates the integer quotient of "n1" % and "n2", just as the "QUOTIENT" for integers does. % **** For calculating the quotient up to a necessary % **** precision, please use DIVIDE!:. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". begin integer e1, e2; if (e1 := ep!: n1) = (e2 := ep!: n2) then return make!:bf(mt!: n1 / mt!: n2, 0) else if e1 > e2 then return quotient!:(incprec!:(n1, e1 - e2) , n2) else return quotient!:(n1, incprec!:(n2, e2 - e1)); end$ symbolic procedure remainder!:(n1, n2); % This function calculates the remainder of "n1" and "n2", % just as the "REMAINDER" for integers does. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". begin integer e1, e2; if (e1 := ep!: n1) = (e2 := ep!: n2) then return make!:bf(remainder(mt!: n1, mt!: n2), e2) else if e1 > e2 then return remainder!:(incprec!:(n1, e1 - e2), n2) else return remainder!:(n1, incprec!:(n2, e2 - e1)); end$ symbolic procedure texpt!:any(x, y); % This function calculates the power x**y, where "x" % and "y" are any numbers. The precision of % the result is specified by !:PREC!: or X or Y. % **** For a negative "x", this function returns % **** -(-x)**y unless "y" is an integer. % X is a BIG-FLOAT representation of "x", otherwise % it is converted to a <BIG-FLOAT>. % Y is either an integer, a floating-point number, % or a BIG-FLOAT number, i.e., a BIG-FLOAT % representation of "y". if fixp y then texpt!:(x, y) else if integerp!: y then texpt!:(x, conv!:bf2i y) else if not bfp!:(x := conv!:a2bf x) or not bfp!:(y := conv!:a2bf y) then bflerrmsg 'texpt!:any % else if minusp!: y then tdivide!:(make!:bf(1, 0), else if minusp!: y then tdivide!:(!:bf!-1, %JBM texpt!:any(x, minus!: y)) else begin integer n; scalar xp, yp; n := (if !:prec!: then !:prec!: else max(preci!: x, preci!: y)); if minusp!: x then xp:=minus!: x else xp := x; if integerp!: times!:(y, conv!:i2bf 2) then %CONSTANT << xp := incprec!:(xp, 1); yp := texpt!:(xp, conv!:bf2i y); yp := times!:(yp, sqrt!:(xp, n + 1)); yp := round!:mt(yp, n) >> else << yp := ttimes!:(y, log!:(xp, n + 1)); yp := exp!:(yp, n) >>; return (if minusp!: x then minus!: yp else yp); end$ symbolic procedure max!:(n1,n2); % This function returns the larger of "n1" and "n2". % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". if greaterp!:(n2, n1) then n2 else n1$ symbolic procedure min!:(n1,n2); % This function returns the smaller of "n1" and "n2". % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". if lessp!:(n2, n1) then n2 else n1$ %************************************************************* %** ** %** 2-2. Arithmetic predicates. ** %** ** %************************************************************* symbolic procedure greaterp!:(n1, n2); % This function returns T if "n1" > "n2" else returns NIL. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". begin integer e1,e2; if (e1 := ep!: n1) = (e2 := ep!: n2) then return (mt!: n1 > mt!: n2) %JBM else if e1 > e2 then return mt!: incprec!:(n1, e1 - e2) > mt!: n2 %JBM else return mt!: n1 > mt!: incprec!:(n2, e2 - e1) %JBM end$ symbolic procedure geq!:(n1, n2); % This function returns T if "n1" >= "n2" else returns NIL. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". not lessp!:(n1, n2)$ symbolic procedure equal!:(n1,n2); % This function returns T if "n1" = "n2" else returns NIL. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". bfzerop!: difference!:(n1, n2)$ symbolic procedure lessp!:(n1, n2); % This function returns T if "n1" < "n2" else returns NIL. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". greaterp!:(n2, n1)$ symbolic procedure leq!:(n1, n2); % This function returns T if "n1" <= "n2" else returns NIL. % N1 and N2 are BIG-FLOAT representations of "n1" and "n2". not greaterp!:(n1, n2)$ symbolic procedure integerp!: x; % This function returns T if X is a BIG-FLOAT % representing an integer, else it returns NIL. % X is any LISP entity. %JBM Critique: this is pretty slow. Couldn't we just check the %JBM Critique: exponent in relation to the precision? bfp!: x and (ep!: x >= 0 or equal!:(x, conv!:i2bf conv!:bf2i x)); symbolic procedure minusp!: x; % This function returns T if "x"<0 else returns NIL. % X is any LISP entity. bfp!: x and mt!: x < 0$ %************************************************************* %** ** %** 3-1. Elementary CONSTANTS. ** %** ** %************************************************************* symbolic procedure !:pi k; % This function calculates the value of the circular % constant "PI", with the precision K, by % using Machin's well known identity: % PI = 16*atan(1/5) - 4*atan(1/239). % Calculation is performed mainly on integers. % K is a positive integer. if not fixp k or k <= 0 then bflerrmsg '!:pi else if k <= 20 then % round!:mt(make!:bf(314159265358979323846, -20), k) round!:mt(!:bf!-pi, k) %JBM else begin integer k3,s,ss,m,n,x; scalar u; u := get!:const('!:pi, k); if u neq "NOT FOUND" then return u; ss := n := 10 ** (k3 := k + 3) / 5; x := -5 ** 2; m := 1; while n neq 0 do <<n := n/x; ss := ss + n/(m := m + 2)>>; s := n := 10 ** k3 / 239; x := -239 ** 2; m := 1; while n neq 0 do << n := n / x; s := s + n / (m := m + 2) >>; ans: u := round!:mt(make!:bf(16 * ss - 4 * s, - k3), k); save!:const('!:pi, u); return u; end$ symbolic procedure !:bigpi k; % This function calculates the value of the circular % constant "PI", with the precision K, by the % arithmetic-geometric mean method. (See, % R. Brent, JACM Vol.23, #2, pp.242-251(1976).) % K is a positive integer. % **** This function should be used only when you % **** need "PI" of precision higher than 1000. if not fixp k or k <= 0 then bflerrmsg '!:bigpi else begin integer k2, n; scalar dcut, half, x, y, u, v; u := get!:const('!:pi, k); if u neq "NOT FOUND" then return u; k2 := k + 2; % half := conv!:s2bf "0.5"; %constant half := !:bf!-0!.5; %JBM dcut := make!:bf(10, - k2); x := conv!:i2bf(n := 1); y := divide!:(x, !:sqrt2 k2, k2); % u := conv!:s2bf "0.25"; %constant u := !:bf!-0!.25; %JBM while greaterp!:(abs!: difference!:(x, y), dcut) do << v := x; x := times!:(plus!:(x, y), half); y := sqrt!:(cut!:ep(times!:(y, v), - k2), k2); v := difference!:(x, v); v := times!:(times!:(v, v), conv!:i2bf n); u := difference!:(u, cut!:ep(v, - k2)); n := 2 * n >>; v := cut!:mt(expt!:(plus!:(x, y), 2), k2); u := divide!:(v, times!:(conv!:i2bf 4, u), k); %CONSTANT save!:const('!:pi, u); return u; end$ symbolic procedure !:e k; % This function calculates the value of "e", the base % of the natural logarithm, with the precision K, % by summing the Taylor series for exp(x=1). % Calculation is performed mainly on integers. % K is a positive integer. if not fixp k or k <= 0 then bflerrmsg '!:e else if k <= 20 then % round!:mt(make!:bf(271828182845904523536, -20), k) round!:mt(!:bf!-e, k) %JBM else begin integer k2, ans, m, n; scalar u; u := get!:const('!:e, k); if u neq "NOT FOUND" then return u; k2 := k + 2; m := 1; n := 10 ** k2; ans := 0; while n neq 0 do ans := ans + (n := n / (m := m + 1)); ans := ans + 2 * 10 ** k2; u := round!:mt(make!:bf(ans, - k2), k); save!:const('!:e2, u); return u; end$ symbolic procedure !:e01(k); % This function calculates exp(0.1), the value of the % exponential function at the point 0.1, with % the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:e01, k); if u neq "NOT FOUND" then return u; % u := exp!:(conv!:s2bf "0.1", k); %constant u := exp!:(!:bf!-0!.1, k); %JBM save!:const('!:e01, u); return u; end$ symbolic procedure !:log2 k; % This function calculates log(2), the natural % logarithm of 2, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:log2, k); if u neq "NOT FOUND" then return u; u := log!:(conv!:i2bf 2, k); %CONSTANT save!:const('!:log2, u); return u; end$ symbolic procedure !:log3 k; % This function calculates log(3), the natural % logarithm of 3, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:log3, k); if u neq "NOT FOUND" then return u; u := log!:(conv!:i2bf 3, k); %CONSTANT save!:const('!:log3, u); return u; end$ symbolic procedure !:log5 k; % This function calculates log(5), the natural % logarithm of 5, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:log5, k); if u neq "NOT FOUND" then return u; u := log!:(conv!:i2bf 5, k); %CONSTANT save!:const('!:log5, u); return u; end$ symbolic procedure !:log10 k; % This function calculates log(10), the natural % logarithm of 10, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:log10, k); if u neq "NOT FOUND" then return u; u := log!:(conv!:i2bf 10, k); %CONSTANT save!:const('!:log10, u); return u; end$ symbolic procedure !:logpi k; % This function calculates log(PI), the natural % logarithm of "PI", with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:logpi, k); if u neq "NOT FOUND" then return u; u := log!:(!:pi(k + 2), k); save!:const('!:logpi, u); return u end$ symbolic procedure !:sqrt2(k); % This function calculates SQRT(2), the square root % of 2, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:sqrt2, k); if u neq "NOT FOUND" then return u; u := sqrt!:(conv!:i2bf 2, k); %CONSTANT save!:const('!:sqrt2, u); return u; end$ symbolic procedure !:sqrt3(k); % This function calculates SQRT(3), the square root % of 3, with the precision K. % K is a positive integer. begin scalar u; u:=get!:const('!:sqrt3, k); if u neq "NOT FOUND" then return u; u := sqrt!:(conv!:i2bf 3, k); %CONSTANT save!:const('!:sqrt3, u); return u; end$ symbolic procedure !:sqrt5 k; % This function calculates SQRT(5), the square root % of 5, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:sqrt5, k); if u neq "NOT FOUND" then return u; u := sqrt!:(conv!:i2bf 5, k); %CONSTANT save!:const('!:sqrt5, u); return u; end$ symbolic procedure !:sqrt10 k; % This function calculates SQRT(10), the square root % of 10, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:sqrt10, k); if u neq "NOT FOUND" then return u; u := sqrt!:(conv!:i2bf 10, k); %CONSTANT save!:const('!:sqrt10, u); return u; end$ symbolic procedure !:sqrtpi k; % This function calculates SQRT(PI), the square root % of "PI", with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:sqrtpi, k); if u neq "NOT FOUND" then return u; u := sqrt!:(!:pi(k + 2), k); save!:const('!:sqrtpi, u); return u; end$ symbolic procedure !:sqrte k; % This function calculates SQRT(e), the square root % of "e", with the precision K. % K is a positive integer. begin scalar u; u:=get!:const('!:sqrte, k); if u neq "NOT FOUND" then return u; u := sqrt!:(!:e(k + 2), k); save!:const('!:sqrte, u); return u; end$ symbolic procedure !:cbrt2 k; % This function calculates CBRT(2), the cube root % of 2, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:cbrt2, k); if u neq "NOT FOUND" then return u; u := cbrt!:(conv!:i2bf 2, k); %CONSTANT save!:const('!:cbrt2, u); return u; end$ symbolic procedure !:cbrt3 k; % This function calculates CBRT(3), the cube root % of 3, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:cbrt3, k); if u neq "NOT FOUND" then return u; u := cbrt!:(conv!:i2bf 3, k); save!:const('!:cbrt3, u); return u; end$ symbolic procedure !:cbrt5 k; % This function calculates CBRT(5), the cube root % of 5, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:cbrt5, k); if u = "NOT FOUND" then return u; u := cbrt!:(conv!:i2bf 5, k); %CONSTANT save!:const('!:cbrt5, u); return u; end$ symbolic procedure !:cbrt10 k; % This function calculates CBRT(10), the cube root % of 10, with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:cbrt10, k); if u neq "NOT FOUND" then return u; u := cbrt!:(conv!:i2bf 10, k); %CONSTANT save!:const('!:cbrt10, u); return u; end$ symbolic procedure !:cbrtpi k; % This function calculates CBRT(PI), the cube root % of "PI", with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:cbrtpi, k); if u neq "NOT FOUND" then return u; u := cbrt!:(!:pi(k + 2), k); save!:const('!:cbrtpi, u); return u; end$ symbolic procedure !:cbrte k; % This function calculates CBRT(e), the cube root % of "e", with the precision K. % K is a positive integer. begin scalar u; u := get!:const('!:cbrte, k); if u neq "NOT FOUND" then return u; u := cbrt!:(!:e(k + 2), k); save!:const('!:cbrte, u); return u; end$ %************************************************************* %** ** %** 3-2. Routines for saving CONSTANTS. ** %** ** %************************************************************* symbolic procedure get!:const(cnst, k); % This function returns the value of constant CNST % of the precision K, if it was calculated % previously with, at least, the precision K, % else it returns "NOT FOUND". % CNST is the name of the constant (to be quoted). % K is a positive integer. if atom cnst and fixp k and k > 0 then begin scalar u; u := get(cnst, 'save!:c); if null u or car u < k then return "NOT FOUND" else if car u = k then return cdr u else return round!:mt(cdr u, k); end else bflerrmsg 'get!:const$ symbolic procedure save!:const(cnst, nmbr); % This function saves the value of constant CNST % for the later use. % CNST is the name of the constant (to be quoted). % NMBR is a BIG-FLOAT representation of the value. if atom cnst and bfp!: nmbr then put(cnst, 'save!:c, preci!: nmbr . nmbr) else bflerrmsg 'save!:const$ symbolic procedure set!:const(cnst, l); % This function sets the value of constant CNST. % CNST is the name of the constant (to be quoted). % L is a list of integers, which represents the % value of the constant in the way described % in the function READ!:LNUM. save!:const(cnst, read!:lnum l)$ % Setting the constants. set!:const( '!:pi , '( 0 3141 59265 35897 93238 46264 33832 79502 88419 71693 99375 105820 9749 44592 30781 64062 86208 99862 80348 25342 11706 79821 48086 51328 23066 47093 84460 95505 82231 72535 94081 28481 1174 5028410 2701 93852 11055 59644 62294 89549 30381 96442 88109 8) )$ set!:const( '!:e , '( 0 2718 28182 84590 45235 36028 74713 52662 49775 72470 93699 95957 49669 67627 72407 66303 53547 59457 13821 78525 16642 74274 66391 93200 30599 21817 41359 66290 43572 90033 42952 60595 63073 81323 28627 943490 7632 33829 88075 31952 510190 1157 38341 9) )$ set!:const( '!:e01 , '( 0 1105 17091 80756 47624 81170 78264 90246 66822 45471 94737 51871 87928 63289 44096 79667 47654 30298 91433 18970 74865 36329 2) )$ set!:const( '!:log2 , '(-1 6931 47180 55994 53094 17232 12145 81765 68075 50013 43602 55254 1206 800094 93393 62196 96947 15605 86332 69964 18687 54200 2) )$ set!:const( '!:log3 , '( 0 1098 61228 866810 9691 39524 52369 22525 70464 74905 57822 74945 17346 94333 63749 42932 18608 96687 36157 54813 73208 87879 7) )$ set!:const( '!:log5 , '( 0 1609 43791 2434100 374 60075 93332 26187 63952 56013 54268 51772 19126 47891 47417 898770 7657 764630 1338 78093 179610 7999 7) )$ set!:const( '!:log10 , '( 0 2302 58509 29940 456840 1799 14546 84364 20760 11014 88628 77297 60333 27900 96757 26096 77352 48023 599720 5089 59829 83419 7) )$ set!:const( '!:logpi , '( 0 1144 72988 5849400 174 14342 73513 53058 71164 72948 12915 31157 15136 23071 47213 77698 848260 7978 36232 70275 48970 77020 1) )$ set!:const( '!:sqrt2 , '( 0 1414 21356 23730 95048 80168 872420 96980 7856 96718 75376 94807 31766 79737 99073 24784 621070 38850 3875 34327 64157 27350 1) )$ set!:const( '!:sqrt3 , '( 0 17320 5080 75688 77293 52744 634150 5872 36694 28052 53810 38062 805580 6979 45193 301690 88000 3708 11461 86757 24857 56756 3) )$ set!:const( '!:sqrt5 , '( 0 22360 6797 74997 89696 40917 36687 31276 235440 6183 59611 52572 42708 97245 4105 209256 37804 89941 441440 8378 78227 49695 1) )$ set!:const( '!:sqrt10, '( 0 3162 277660 1683 79331 99889 35444 32718 53371 95551 39325 21682 685750 4852 79259 44386 39238 22134 424810 8379 30029 51873 47))$ set!:const( '!:sqrtpi, '( 0 1772 453850 9055 16027 29816 74833 41145 18279 75494 56122 38712 821380 7789 85291 12845 91032 18137 49506 56738 54466 54162 3) )$ set!:const( '!:sqrte , '( 0 1648 721270 7001 28146 8486 507878 14163 57165 3776100 710 14801 15750 79311 64066 10211 94215 60863 27765 20056 36664 30028 7) )$ set!:const( '!:cbrt2 , '( 0 1259 92104 98948 73164 7672 106072 78228 350570 2514 64701 5079800 819 75112 15529 96765 13959 48372 93965 62436 25509 41543 1) )$ set!:const( '!:cbrt3 , '( 0 1442 249570 30740 8382 32163 83107 80109 58839 18692 53499 35057 75464 16194 54168 75968 29997 33985 47554 79705 64525 66868 4) )$ set!:const( '!:cbrt5 , '( 0 1709 97594 66766 96989 35310 88725 43860 10986 80551 105430 5492 43828 61707 44429 592050 4173 21625 71870 10020 18900 220450 ) )$ set!:const( '!:cbrt10, '( 0 2154 4346900 318 83721 75929 35665 19350 49525 93449 42192 10858 24892 35506 34641 11066 48340 80018 544150 3543 24327 61012 6) )$ set!:const( '!:cbrtpi, '( 0 1464 59188 75615 232630 2014 25272 63790 39173 85968 55627 93717 43572 55937 13839 36497 98286 26614 56820 67820 353820 89750 ) )$ set!:const( '!:cbrte , '( 0 1395 61242 50860 89528 62812 531960 2586 83759 79065 15199 40698 26175 167060 3173 90156 45951 84696 97888 17295 83022 41352 1) )$ %************************************************************* %** ** %** 4-1. Elementary FUNCTIONS. ** %** ** %************************************************************* symbolic procedure sqrt!:(x, k); % This function calculates SQRT(x), the square root % of "x", with the precision K, by Newton's % iteration method. % X is a BIG-FLOAT representation of "x", x >= 0, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or minusp!: x or not fixp k or k <= 0 then bflerrmsg 'sqrt!: else if bfzerop!: x then conv!:i2bf 0 else begin integer k2,ncut,nfig; scalar dcut,half,dy,y,y0,u; k2 := k + 2; ncut := k2 - (order!: x + 1) / 2; % half := conv!:s2bf "0.5"; half := !:bf!-0!.5; %JBM dcut := make!:bf(10, - ncut); dy := make!:bf(20, - ncut); y0 := conv!:mt(x, 2); if remainder(ep!: y0, 2) = 0 then y0 := make!:bf(3 + 2 * mt!: y0 / 25, ep!: y0 / 2) else y0 := make!:bf(10 + 2 * mt!: y0 / 9, (ep!: y0 - 1) / 2); nfig := 1; while nfig < k2 or greaterp!:(abs!: dy, dcut) do << if (nfig := 2 * nfig) > k2 then nfig := k2; u := divide!:(x, y0, nfig); y := times!:(plus!:(y0, u), half); dy := difference!:(y, y0); y0 := y >>; return round!:mt(y, k); end$ symbolic procedure cbrt!:(x, k); % This function calculates CBRT(x), the cube root % of "x", with the precision K, by Newton's % iteration method. % X is a BIG-FLOAT representation of any real "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'cbrt!: else if bfzerop!: x then conv!:i2bf 0 else if minusp!: x then minus!: cbrt!:(minus!: x, k) else begin integer k2, ncut, nfig, j; scalar dcut, thre, dy, y, u; k2 := k + 2; ncut := k2 - (order!: x + 2) / 3; thre := conv!:i2bf 3; dcut := make!:bf(10, - ncut); dy := make!:bf(20, - ncut); y := conv!:mt(x, 3); if (j := remainder(ep!: y, 3)) = 0 then y := make!:bf(5 + mt!: y / 167, ep!: y / 3) else if j = 1 or j = -2 then y := make!:bf(10 + mt!: y / 75, (ep!: y - 1) / 3) else y := make!:bf(22 + 2 * mt!: y / 75, (ep!: y - 2) / 3); nfig := 1; while nfig < k2 or greaterp!:(abs!: dy, dcut) do << if (nfig := 2 * nfig) > k2 then nfig := k2; u := cut!:mt(times!:(y, y), nfig); u := divide!:(x, u, nfig); j :=order!:(u := difference!:(u, y)) + ncut - k2; dy := divide!:(u, thre, max(1, nfig + j)); y := plus!:(y, dy) >>; return round!:mt(y, k); end$ symbolic procedure exp!:(x, k); % This function calculates exp(x), the value of % the exponential function at the point "x", % with the precision K, by summing terms of % the Taylor series for exp(z), 0 < z < 1. % X is a BIG-FLOAT representation of any real "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'exp!: else if bfzerop!: x then conv!:i2bf 1 else begin integer k2, m; scalar one, q, r, y, yq, yr, save!:p; k2 := k + 2; one := conv!:i2bf 1; q := conv!:i2bf(m := conv!:bf2i(y := abs!: x)); r := difference!:(y, q); if bfzerop!: q then yq := one else << save!:p := !:prec!:; !:prec!: := k2; yq := texpt!:(!:e k2, m); !:prec!: := save!:p >>; if bfzerop!: r then yr:=one else begin integer j, n; scalar dcut, fctrial, ri, tm; dcut := make!:bf(10, - k2); yr := ri := tm := one; m := 1; j := 0; while greaterp!:(tm, dcut) do << fctrial := conv!:i2bf(m := m * (j := j + 1)); ri := cut!:ep(times!:(ri, r), - k2); n := max(1, k2 - order!: fctrial + order!: ri); tm := divide!:(ri, fctrial, n); yr := plus!:(yr,tm); if remainder(j,10)=0 then yr := cut!:ep(yr, - k2) >>; end; y := cut!:mt(times!:(yq, yr), k + 1); return (if minusp!: x then divide!:(one, y, k) else round!:last y); end$ symbolic procedure log!:(x, k); % This function calculates log(x), the value of the % logarithmic function at the point "x", with % the precision K, by summing terms of the % Taylor series for log(1+z), 0 < z < 0.10518. % X is a BIG-FLOAT representation of "x", x > 0, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or minusp!: x or bfzerop!: x or not fixp k or k <= 0 then bflerrmsg 'log!: else if equal!:(x, conv!:i2bf 1) then conv!:i2bf 0 else begin integer k2,m; scalar ee,es,one,sign,l,y,z,save!:p; k2 := k + 2; one := conv!:i2bf 1; ee := !:e k2; es := !:e01 k2; if greaterp!:(x, one) then << sign := one; y := x >> else << sign := minus!: one; y := divide!:(one, x, k2) >>; if lessp!:(y, ee) then << m := 0; z := y >> else << if (m := (order!: y * 23) / 10) = 0 then z := y else << save!:p := !:prec!:; !:prec!: := k2; z := divide!:(y, texpt!:(ee, m), k2); !:prec!: := save!:p >>; while greaterp!:(z, ee) do << m := m+1; z := divide!:(z, ee, k2) >> >>; l := conv!:i2bf m; % y := conv!:s2bf "0.1"; %constant y := !:bf!-0!.1; %JBM while greaterp!:(z, es) do << l := plus!:(l, y); z := divide!:(z, es, k2) >>; z := difference!:(z, one); begin integer n; scalar dcut, tm, zi; y := tm := zi := z; z := minus!: z; dcut := make!:bf(10, - k2); m := 1; while greaterp!:(abs!: tm, dcut) do << zi := cut!:ep(times!:(zi, z), - k2); n := max(1, k2 + order!: zi); tm := divide!:(zi, conv!:i2bf(m := m + 1), n); y := plus!:(y, tm); if zerop remainder(m,10) then y := cut!:ep(y,-k2)>>; end; y := plus!:(y, l); return round!:mt(times!:(sign, y), k); end$ symbolic procedure ln!:(x, k); % This function calculates log(x), the value of % the logarithmic function at the point "x", % with the precision K, by solving % x = exp(y) by Newton's method. % X is a BIG-FLOAT representation of "x", x > 0, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or minusp!: x or bfzerop!: x or not fixp k or k <= 0 then bflerrmsg 'ln!: else if equal!:(x, conv!:i2bf 1) then conv!:i2bf 0 else begin integer k2, m; scalar ee, one, sign, y, z, save!:p; k2 := k + 2; one := conv!:i2bf 1; ee := !:e(k2 + 2); if greaterp!:(x, one) then << sign := one; y := x >> else << sign := minus!: one; y := divide!:(one, x, k2) >>; if lessp!:(y, ee) then << m := 0; z := y >> else << if zerop (m := (order!: y * 23) / 10) then z := y else << save!:p := !:prec!:; !:prec!: := k2; z := divide!:(y, texpt!:(ee, m), k2); !:prec!: := save!:p >>; while greaterp!:(z, ee) do << m := m + 1; z := divide!:(z, ee, k2) >> >>; begin integer nfig, n; scalar dcut, dx, dy, x0; dcut := make!:bf(10, - k2); dy := make!:bf(20, - k2); % y := divide!:(difference!:(z,one), conv!:s2bf "1.72", 2); y := divide!:(difference!:(z,one), !:bf!-1!.72, 2); %JBM nfig := 1; while nfig < k2 or greaterp!:(abs!: dy, dcut) do << if (nfig := 2 * nfig) > k2 then nfig := k2; x0 := exp!:(y, nfig); dx := difference!:(z, x0); n := max(1, nfig + order!: dx); dy := divide!:(dx, x0, n); y := plus!:(y, dy) >>; end; y := plus!:(conv!:i2bf m, y); return round!:mt(times!:(sign, y), k); end$ symbolic procedure sin!:(x, k); % This function calculates sin(x), the value of % the sine function at the point "x", with % the precision K, by summing terms of the % Taylor series for sin(z), 0 < z < PI/4. % X is a BIG-FLOAT representation of any rael "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'sin!: else if bfzerop!: x then conv!:i2bf 0 else if minusp!: x then minus!: sin!:(minus!: x, k) else begin integer k2, m; scalar pi4, sign, q, r, y; k2 := k + 2; m := preci!: x; % pi4 := times!:(!:pi(k2 + m), conv!:s2bf "0.25"); %constant pi4 := times!:(!:pi(k2 + m), !:bf!-0!.25); %JBM if lessp!:(x, pi4) then << m := 0; r := x >> else << m := conv!:bf2i(q := quotient!:(x, pi4)); r := difference!:(x, times!:(q, pi4)) >>; sign := conv!:i2bf 1; if m >= 8 then m := remainder(m, 8); if m >= 4 then << sign := minus!: sign; m := m - 4>>; if m = 0 then goto sn else if onep m then goto m1 else if m = 2 then goto m2 else goto m3; m1: r := cut!:mt(difference!:(pi4, r), k2); return times!:(sign, cos!:(r, k)); m2: r := cut!:mt(r, k2); return times!:(sign, cos!:(r, k)); m3: r := cut!:mt(difference!:(pi4, r), k2); sn: begin integer j, n, ncut; scalar dcut, fctrial, ri, tm; ncut := k2 - min(0, order!: r + 1); dcut := make!:bf(10, - ncut); y := ri := tm := r; r := minus!: cut!:ep(times!:(r, r), - ncut); m := j := 1; while greaterp!:(abs!: tm, dcut) do << j := j + 2; fctrial := conv!:i2bf(m := m * j * (j - 1)); ri := cut!:ep(times!:(ri, r), - ncut); n := max(1, k2 - order!: fctrial + order!: ri); tm := divide!:(ri, fctrial, n); y := plus!:(y, tm); if zerop remainder(j,20) then y := cut!:ep(y,-ncut)>>; end; return round!:mt(times!:(sign, y), k); end$ symbolic procedure cos!:(x, k); % This function calculates cos(x), the value of % the cosine function at the point "x", with % the precision K, by summing terms of the % Taylor series for cos(z), 0 < z < PI/4. % X is a BIG-FLOAT representation of any real "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'cos!: else if bfzerop!: x then conv!:i2bf 1 else if minusp!: x then cos!:(minus!: x, k) else begin integer k2, m; scalar pi4, sign, q, r, y; k2 := k + 2; m := preci!: x; % pi4 := times!:(!:pi(k2 + m), conv!:s2bf "0.25"); %constant pi4 := times!:(!:pi(k2 + m), !:bf!-0!.25); %JBM if lessp!:(x, pi4) then << m := 0; r := x >> else << m := conv!:bf2i(q := quotient!:(x, pi4)); r := difference!:(x, times!:(q, pi4)) >>; sign := conv!:i2bf 1; if m >= 8 then m := remainder(m, 8); if m >= 4 then << sign := minus!: sign; m := m - 4 >>; if m >= 2 then sign := minus!: sign; if m = 0 then goto cs else if m = 1 then goto m1 else if m = 2 then goto m2 else goto m3; m1: r := cut!:mt(difference!:(pi4, r), k2); return times!:(sign, sin!:(r, k)); m2: r := cut!:mt(r, k2); return times!:(sign, sin!:(r, k)); m3: r := cut!:mt(difference!:(pi4, r), k2); cs: begin integer j, n; scalar dcut, fctrial, ri, tm; dcut := make!:bf(10, - k2); y := ri := tm := conv!:i2bf 1; r := minus!: cut!:ep(times!:(r, r), - k2); m := 1; j := 0; while greaterp!:(abs!: tm, dcut) do << j := j + 2; fctrial := conv!:i2bf(m := m * j * (j - 1)); ri := cut!:ep(times!:(ri, r), - k2); n := max(1, k2 - order!: fctrial + order!: ri); tm := divide!:(ri, fctrial, n); y := plus!:(y, tm); if zerop remainder(j,20) then y := cut!:ep(y,-k2)>>; end; return round!:mt(times!:(sign, y), k); end$ symbolic procedure tan!:(x, k); % This function calculates tan(x), the value of % the tangent function at the point "x", % with the precision K, by calculating % sin(x) or cos(x) = sin(PI/2-x). % X is a BIG-FLOAT representation of any real "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'tan!: else if bfzerop!: x then conv!:i2bf 0 else if minusp!: x then minus!: tan!:(minus!: x, k) else begin integer k2, m; scalar one, pi4, sign, q, r; k2 := k + 2; one := conv!:i2bf 1; m := preci!: x; % pi4 := times!:(!:pi(k2 + m), conv!:s2bf "0.25"); %constant pi4 := times!:(!:pi(k2 + m), !:bf!-0!.25); %JBM if lessp!:(x, pi4) then << m := 0; r := x >> else << m := conv!:bf2i(q := quotient!:(x, pi4)); r := difference!:(x, times!:(q, pi4)) >>; if m >= 4 then m := remainder(m, 4); if m >= 2 then sign := minus!: one else sign := one; if m = 1 or m = 3 then r := difference!:(pi4, r); r := cut!:mt(r, k2); if m = 0 or m = 3 then goto m03 else goto m12; m03: r := sin!:(r, k2); q := difference!:(one, times!:(r, r)); q := sqrt!:(cut!:mt(q, k2), k2); return times!:(sign, divide!:(r, q, k)); m12: r := sin!:(r, k2); q := difference!:(one, times!:(r, r)); q := sqrt!:(cut!:mt(q, k2), k2); return times!:(sign, divide!:(q, r, k)); end$ symbolic procedure asin!:(x, k); % This function calculates asin(x), the value of % the arcsine function at the point "x", % with the precision K, by calculating % atan(x/SQRT(1-x**2)) by ATAN!:. % The answer is in the range [-PI/2 , PI/2]. % X is a BIG-FLOAT representation of "x", IxI <= 1, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or greaterp!:(abs!: x, conv!:i2bf 1) or not fixp k or k <= 0 then bflerrmsg 'asin!: else if minusp!: x then minus!: asin!:(minus!: x, k) else begin integer k2; scalar one, y; k2 := k + 2; one := conv!:i2bf 1; if lessp!:(difference!:(one, x), make!:bf(10, - k2)) % then return round!:mt(times!:(!:pi(k+1),conv!:s2bf "0.5"),k); then return round!:mt(times!:(!:pi add1 k,!:bf!-0!.5),k); %JBM y := cut!:mt(difference!:(one, times!:(x, x)), k2); y := divide!:(x, sqrt!:(y, k2), k2); return atan!:(y, k); end$ symbolic procedure acos!:(x, k); % This function calculates acos(x), the value of % the arccosine function at the point "x", % with the precision K, by calculating % atan(SQRT(1-x**2)/x) if x > 0 or % atan(SQRT(1-x**2)/x) + PI if x < 0. % The answer is in the range [0 , PI]. % X is a BIG-FLOAT representation of "x", IxI <= 1, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or greaterp!:(abs!: x, conv!:i2bf 1) or not fixp k or k <= 0 then bflerrmsg 'acos!: else begin integer k2; scalar y; k2 := k + 2; if lessp!:(abs!: x, make!:bf(50, - k2)) % then return round!:mt(times!:(!:pi(k+1),conv!:s2bf "0.5"),k); then return round!:mt(times!:(!:pi add1 k,!:bf!-0!.5),k); %JBM y := difference!:(conv!:i2bf 1, times!:(x, x)); y := cut!:mt(y, k2); y := divide!:(sqrt!:(y, k2), abs!: x, k2); return (if minusp!: x then round!:mt(difference!:(!:pi(k + 1), atan!:(y, k)), k) else atan!:(y, k) ); end$ symbolic procedure atan!:(x, k); % This function calculates atan(x), the value of the % arctangent function at the point "x", with % the precision K, by summing terms of the % Taylor series for atan(z) if 0 < z < 0.42. % Otherwise the following identities are used: % atan(x) = PI/2 - atan(1/x) if 1 < x and % atan(x) = 2*atan(x/(1+SQRT(1+x**2))) % if 0.42 <= x <= 1. % The answer is in the range [-PI/2 , PI/2]. % X is a BIG-FLOAT representation of any real "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'atan!: else if bfzerop!: x then conv!:i2bf 0 else if minusp!: x then minus!: atan!:(minus!: x, k) else begin integer k2; scalar one, pi4, y, z; k2 := k + 2; one := conv!:i2bf 1; % pi4 := times!:(!:pi k2, conv!:s2bf "0.25"); %constant pi4 := times!:(!:pi k2, !:bf!-0!.25); %JBM if equal!:(x, one) then return round!:mt(pi4, k); if greaterp!:(x, one) then return round!:mt(difference!:(plus!:(pi4, pi4), atan!:(divide!:(one,x,k2),k + 1)),k); % if lessp!:(x, conv!:s2bf "0.42") then goto at; %constant if lessp!:(x, !:bf!-0!.42) then goto at; %JBM y := plus!:(one, cut!:mt(times!:(x, x), k2)); y := plus!:(one, sqrt!:(y, k2)); y := atan!:(divide!:(x, y, k2), k + 1); return round!:mt(times!:(y, conv!:i2bf 2), k); at: begin integer m, n, ncut; scalar dcut, tm, zi; ncut := k2 - min(0, order!: x + 1); y := tm := zi := x; z := minus!: cut!:ep(times!:(x, x), - ncut); dcut := make!:bf(10, - ncut); m := 1; while greaterp!:(abs!: tm, dcut) do << zi := cut!:ep(times!:(zi, z), - ncut); n := max(1, k2 + order!: zi); tm := divide!:(zi, conv!:i2bf(m := m + 2), n); y := plus!:(y, tm); if zerop remainder(m,20) then y := cut!:ep(y,-ncut)>>; end; return round!:mt(y, k) end$ symbolic procedure arcsin!:(x, k); % This function calculates arcsin(x), the value of % the arcsine function at the point "x", with % the precision K, by solving % x = sin(y) if 0 < x <= 0.72, or % SQRT(1-x**2) = sin(y) if 0.72 < x, % by Newton's iteration method. % The answer is in the range [-PI/2 , PI/2]. % X is a BIG-FLOAT representation of "x", IxI <= 1, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or greaterp!:(abs!: x, conv!:i2bf 1) or not fixp k or k <= 0 then bflerrmsg 'arcsin!: else if bfzerop!: x then conv!:i2bf 0 else if minusp!: x then minus!: arcsin!:(minus!: x, k) else begin integer k2; scalar dcut, one, pi2, y; k2 := k + 2; dcut := make!:bf(10, - k2 + order!: x + 1); one := conv!:i2bf 1; % pi2 := times!:(!:pi(k2 + 2), conv!:s2bf "0.5"); %constant pi2 := times!:(!:pi(k2 + 2), !:bf!-0!.5); %JBM if lessp!:(difference!:(one, x), dcut) then return round!:mt(pi2, k); % if greaterp!:(x, conv!:s2bf "0.72") then goto ac if greaterp!:(x, !:bf!-0!.72) then goto ac %JBM else goto as; ac: y := cut!:mt(difference!:(one, times!:(x, x)), k2); y := arcsin!:(sqrt!:(y, k2), k); return round!:mt(difference!:(pi2, y), k); as: begin integer nfig,n; scalar cx, dx, dy, x0; dy := one; y := x; nfig := 1; while nfig < k2 or greaterp!:(abs!: dy, dcut) do << if (nfig := 2 * nfig) > k2 then nfig := k2; x0 := sin!:(y, nfig); cx := difference!:(one, times!:(x0, x0)); cx := cut!:mt(cx, nfig); cx := sqrt!:(cx, nfig); dx := difference!:(x, x0); n := max(1, nfig + order!: dx); dy := divide!:(dx, cx, n); y := plus!:(y, dy) >>; end; return round!:mt(y, k); end$ symbolic procedure arccos!:(x, k); % This function calculates arccos(x), the value of % the arccosine function at the point "x", with % the precision K, by calculating % arcsin(SQRT(1-x**2)) if x > 0.72 and % PI/2 - arcsin(x) otherwise by ARCSIN!:. % The answer is in the range [0 , PI]. % X is a BIG-FLOAT representation of "x", IxI <= 1, % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or greaterp!:(abs!: x, conv!:i2bf 1) or not fixp k or k <= 0 then bflerrmsg 'arccos!: % else if leq!:(x, conv!:s2bf "0.72") then else if leq!:(x, !:bf!-0!.72) then %JBM round!:mt(difference!: % (times!:(!:pi(k + 1), conv!:s2bf "0.5"), (times!:(!:pi add1 k, !:bf!-0!.5), %JBM arcsin!:(x, k) ), k) else arcsin!:(sqrt!:(cut!:mt (difference!:(conv!:i2bf 1, times!:(x, x)), k + 2), k + 2), k)$ symbolic procedure arctan!:(x, k); % This function calculates arctan(x), the value of % the arctangent function at the point "x", % with the precision K, by calculating % arcsin(x/SQRT(1+x**2)) by ARCSIN!: % The answer is in the range [-PI/2 , PI/2]. % X is a BIG-FLOAT representation of any real "x", % otherwise it is converted to a <BIG-FLOAT>. % K is a positive integer. if not bfp!:(x := conv!:a2bf x) or not fixp k or k <= 0 then bflerrmsg 'arctan!: else if minusp!: x then minus!: arctan!:(minus!: x, k) else arcsin!:(divide!:(x, sqrt!:(cut!:mt (plus!:(conv!:i2bf 1, times!:(x, x)), k + 2), k + 2), k + 2), k)$ %Miscellaneous constants (added by JBM). !:bf!-pi := make!:bf(314159265358979323846, -20); !:bf!-0 := make!:bf(0, 0); !:bf!-1 := make!:bf(1, 0); !:bf!-e := make!:bf(271828182845904523536, -20); !:bf!-0!.5 := conv!:s2bf "0.5"; !:bf!-0!.25 := conv!:s2bf "0.25"; !:bf!-0!.1 := conv!:s2bf "0.1"; !:bf!-1!.72 := conv!:s2bf "1.72"; !:bf!-0!.42 := conv!:s2bf "0.42"; !:bf!-0!.72 := conv!:s2bf "0.72"; endmodule; module gbf; % Support for gaussian bigfloats. % Author: Eberhard Schruefer. global '(domainlist!*); fluid '(!*big!_complex); domainlist!* := union('(!:gbf!:),domainlist!*); put('big!_complex,'tag,'!:gbf!:); put('!:gbf!:,'dname,'big!_complex); put('!:gbf!:,'i2d,'!*i2gbf); put('!:gbf!:,'minusp,'gbfminusp!:); put('!:gbf!:,'zerop,'gbfzerop!:); put('!:gbf!:,'onep,'gbfonep!:); put('!:gbf!:,'plus,'gbfplus!:); put('!:gbf!:,'difference,'gbfdifference!:); put('!:gbf!:,'times,'gbftimes!:); put('!:gbf!:,'quotient,'gbfquotient!:); put('!:gbf!:,'rationalizefn,'girationalize!:); put('!:gbf!:,'prepfn,'gbfprep!:); put('!:gbf!:,'prifn,'gbfprn!:); put('!:bf!:,'!:gbf!:,'bf2gbf); put('!:rn!:,'!:gbf!:,'rn2gbf); put('!:ft!:,'!:gbf!:,'ft2gbf); put('!:gbf!:,'!:bf!:,'gbf2bf); put('!:gbf!:,'cmpxfn,'mkgbf); put('!:gbf!:,'ivalue,'mkdgbf); put('!:gbf!:,'realtype,'!:bf!:); flag('(!:gbf!:),'field); symbolic procedure mkdgbf u; ('!:gbf!: . (i2bf!: 0 . i2bf!: 1)) ./ 1; smacro procedure mkgbf(rp,ip); '!:gbf!: . (rp . ip); symbolic procedure bf2gbf u; mkgbf(u,i2bf!: 0); symbolic procedure rn2gbf u; mkgbf(!*rn2bf u,i2bf!: 0); symbolic procedure ft2gbf u; mkgbf(!*ft2bf u,i2bf!: 0); symbolic procedure gbf2bf u; if bfzerop!: cddr u then cadr u else rederr "conversion to bigfloat requires zero imaginary part"; symbolic procedure !*i2gbf u; '!:gbf!: . (i2bf!: u . i2bf!: 0); symbolic procedure gbfminusp!: u; %this makes not much sense; if bfzerop!: cddr u then minusp!: cadr u else minusp!: cddr u; symbolic procedure gbfzerop!: u; bfzerop!:(cadr u) and bfzerop!:(cddr u); symbolic procedure gbfonep!: u; bfonep!:(cadr u) and bfzerop!:(cddr u); symbolic procedure gbfplus!:(u,v); mkgbf(bfplus!:(cadr u,cadr v),bfplus!:(cddr u,cddr v)); symbolic procedure gbfdifference!:(u,v); mkgbf(tdifference!:(cadr u,cadr v), tdifference!:(cddr u,cddr v)); symbolic procedure gbftimes!:(u,v); begin scalar r1,i1,r2,i2,rr,ii; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; rr := tdifference!:(ttimes!:(r1,r2),ttimes!:(i1,i2)); ii := bfplus!:(ttimes!:(r1,i2),ttimes!:(r2,i1)); return mkgbf(rr,ii) end; symbolic procedure gbfquotient!:(u,v); begin scalar r1,i1,r2,i2,rr,ii,d; r1 := cadr u; i1 := cddr u; r2 := cadr v; i2 := cddr v; d := bfplus!:(ttimes!:(r2,r2),ttimes!:(i2,i2)); rr := bfplus!:(ttimes!:(r1,r2),ttimes!:(i1,i2)); ii := tdifference!:(ttimes!:(i1,r2),ttimes!:(i2,r1)); return mkgbf(bfquotient!:(rr,d),bfquotient!:(ii,d)) end; symbolic procedure gbfprep!: u; gbfprep1 cdr u; %symbolic procedure simpgbf u; %('!:gbf!: . u) ./ 1; %put('!:gbf!:,'simpfn,'simpgbf); symbolic procedure gbfprep1 u; if bfzerop!: cdr u then if bfonep!: car u then 1 else car u else if bfzerop!: car u then if bfonep!: cdr u then 'i else list('times,cdr u,'i) else list('plus,car u,if bfonep!: cdr u then 'i else list('times,cdr u,'i)); symbolic procedure gbfprn!: u; (lambda v; if atom v or car v eq 'times or car v memq domainlist!* then maprin v else <<prin2!* "("; maprin v; prin2!* ")">>) gbfprep1 u; %*** elementary functions; % All functions below return the principal value. Be aware of certain % pecularities in this respect. E.g. if you raise a complex quantity % to a complex power and then raise the result to the reciprocal power % you will not in general obtain the base, since (u**v)**(1/v) is % different from u in general. deflist('((e gbfe!*) (pi gbfpi!*)),'!:gbf!:); symbolic procedure gbfe!*; bf2gbf e!*(); symbolic procedure gbfpi!*; bf2gbf pi!*(); deflist('((expt gbfexpt) (sin gbfsin) (cos gbfcos) (tan gbftan) (asin gbfasin) (acos gbfacos) (atan gbfatan) (log gbflog)),'!:gbf!:); symbolic procedure gbfexpt(u,v); begin scalar norm,ang,angr; norm := sqrt!*(bfplus!:(ttimes!:(cadr u,cadr u), ttimes!:(cddr u,cddr u))); ang := bfarg!: u; angr := bfplus!:(ttimes!:(cddr v,log!* norm), ttimes!:(cadr v,ang)); norm := ttimes!:(texpt!:any(norm,cadr v), exp!* ttimes!:('!:bf!: . (-cadddr v) . cddddr v,ang)); return mkgbf(ttimes!:(norm,cos!* angr), ttimes!:(norm,sin!* angr)) end; symbolic procedure bfarg!: u; % Returns bfarg u in the range (-pi,+pi), as a bigfloat. (lambda x,y; if bfzerop!: y then if minusp!: x then pi!*() else i2bf!: 0 else if bfzerop!: x then if minusp!: y then ttimes!:(pi!*(),conv!:a2bf(-0.5)) else ttimes!:(pi!*(),conv!:a2bf 0.5) else if minusp!: x and minusp!: y then tdifference!:(atan!*(bfquotient!:(y,x)),pi!*()) else if minusp!: x and not minusp!: y then bfplus!:(atan!*(bfquotient!:(y,x)),pi!*()) else atan!*(bfquotient!:(y,x))) (cadr u,cddr u); %put('bfarg,'polyfn,'bfarg!:); %make it available to algebraic mode; symbolic procedure gbfsin u; mkgbf(ttimes!:(sin!* cadr u,cosh!* cddr u), ttimes!:(cos!* cadr u,sinh!* cddr u)); symbolic procedure gbfcos u; mkgbf(ttimes!:(cos!* cadr u,cosh!* cddr u), !:minus ttimes!:(sin!* cadr u,sinh!* cddr u)); symbolic procedure gbftan u; begin scalar v; v := bfplus!:(cos!* ttimes!:(conv!:a2bf 2.0,cadr u), cosh!* ttimes!:(conv!:a2bf 2.0,cddr u)); return mkgbf(bfquotient!:(sin!* ttimes!:(conv!:a2bf 2.0,cadr u),v), bfquotient!:(sinh!* ttimes!:(conv!:a2bf 2.0,cddr u),v)) end; symbolic procedure gbfasin u; begin scalar a,b,c; a := ttimes!:(conv!:a2bf 0.5, sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!: 1),i2bf!: 2), ttimes!:(cddr u,cddr u)))); b := ttimes!:(conv!:a2bf 0.5, sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!:(-1)),i2bf!: 2), ttimes!:(cddr u,cddr u)))); c := bfplus!:(a,b); b := tdifference!:(a,b); a := c; c := bfplus!:(a,sqrt!*(tdifference!:(ttimes!:(a,a),i2bf!: 1))); return mkgbf(asin!* b,log!* c) end; symbolic procedure gbfacos u; begin scalar a,b,c; a := ttimes!:(conv!:a2bf 0.5, sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!: 1),i2bf!: 2), ttimes!:(cddr u,cddr u)))); b := ttimes!:(conv!:a2bf 0.5, sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!:(-1)),i2bf!: 2), ttimes!:(cddr u,cddr u)))); c := bfplus!:(a,b); b := tdifference!:(a,b); a := c; c := bfplus!:(a,sqrt!*(tdifference!:(ttimes!:(a,a),i2bf!: 1))); return mkgbf(acos!* b,ttimes!:(log!* c,i2bf!:(-1))) end; symbolic procedure gbfatan u; gbftimes!:(gbflog(gbfquotient!:( gbfplus!:(!*i2gbf 1,gbftimes!:(mkgbf(0,-1),u)), gbfplus!:(!*i2gbf 1,gbftimes!:(mkgbf(0,1),u)))), mkgbf(0,conv!:a2bf 0.5)); symbolic procedure gbflog u; %Returns the principal value of log u; if realp u then mkgbf(log!* u,i2bf!: 0) else begin scalar norm; norm := sqrt!* bfplus!:(ttimes!:(cadr u,cadr u), ttimes!:(cddr u,cddr u)); return mkgbf(log!* norm,bfarg!: u) end; initdmode 'big!_complex; endmodule; end; |
Added r33/boot.sl version [4fc226a118].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Standard LISP equivalent of BOOT.RED. (fluid '(!*blockp !*mode)) (global '(oldchan!*)) (global '(crchar!* cursym!* fname!* nxtsym!* ttype!* !$eol!$)) (put '!; 'switch!* '(nil !*semicol!*)) (put '!( 'switch!* '(nil !*lpar!*)) (put '!) 'switch!* '(nil !*rpar!*)) (put '!, 'switch!* '(nil !*comma!*)) (put '!. 'switch!* '(nil cons)) (put '!: 'switch!* '(((!= nil setq)) !*colon!*)) (put '!*comma!* 'infix 1) (put 'setq 'infix 2) (put 'cons 'infix 3) (flag '(!*comma!*) 'nary) (flag '(!*colon!* !*semicol!* end then else) 'delim) (put 'begin 'stat 'blockstat) (put 'if 'stat 'ifstat) (put 'symbolic 'stat 'procstat) (de begin2 nil (prog nil (setq cursym!* '!*semicol!*) a (cond ((eq cursym!* 'end) (progn (rds oldchan!*) (return nil))) (t (prin2 (errorset '(eval (form (xread nil))) t t)) )) (go a))) (de form (u) u) (de xread (u) (progn (scan) (xread1 u))) (de xread1 (u) (prog (v w x y z z2) a (setq z cursym!*) a1 (cond ((or (null (atom z)) (numberp z)) (setq y nil)) ((flagp z 'delim) (go end1)) ((eq z '!*lpar!*) (go lparen)) ((eq z '!*rpar!*) (go end1)) ((setq y (get z 'infix)) (go infx)) ((setq y (get z 'stat)) (go stat))) a3 (setq w (cons z w)) next (setq z (scan)) (go a1) lparen(setq y nil) (cond ((eq (scan) '!*rpar!*) (and w (setq w (cons (list (car w)) (cdr w)))) ) ((eqcar (setq z (xread1 'paren)) '!*comma!*) (setq w (cons (cons (car w) (cdr z)) (cdr w)))) (t (go a3))) (go next) infx (setq z2 (mkvar (car w) z)) un1 (setq w (cdr w)) (cond ((null w) (go un2)) (t (setq z2 (cons (car w) (list z2)))) ) (go un1) un2 (setq v (cons z2 v)) preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2))) pr1 (setq x (cons (cons y z) x)) (go next) pr2 (setq v (cons (cond ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary)) (cons (cdar x) (cons (cadr v) (cdar v)))) (t (cons (cdar x) (list (cadr v) (car v)))) ) (cdr (cdr v)))) (setq x (cdr x)) (go preced) stat (setq w (cons (eval (list y)) w)) (setq y nil) (go a) end1 (cond ((and (and (null v) (null w)) (null x)) (return nil)) (t (setq y 0))) (go infx) pr4 (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) )) (de eqcar (u v) (and (null (atom u)) (eq (car u) v))) (de mksetq (u v) (list 'setq u v)) (de mkvar (u v) u) (de rread nil (prog (x) (setq x (token)) (return (cond ((and (equal ttype!* 3) (eq x '!()) (rrdls)) (t x)))) ) (de rrdls nil (prog (x) (setq x (rread)) (cond ((null (equal ttype!* 3)) (go a)) ((eq x '!)) (return nil)) ((null (eq x '!.)) (go a))) (setq x (rread)) (token) (return x) a (return (cons x (rrdls)))) ) (de token nil (prog (x y) (setq x crchar!*) a (cond ((seprp x) (go sepr)) ((digit x) (go number)) ((liter x) (go letter)) ((eq x '!%) (go coment)) ((eq x '!!) (go escape)) ((eq x '!') (go quote)) ((eq x '!") (go string))) (setq ttype!* 3) (cond ((delcp x) (go d))) (setq nxtsym!* x) a1 (setq crchar!* (readch)) (go c) escape(setq y (cons x y)) (setq x (readch)) letter(setq ttype!* 0) let1 (setq y (cons x y)) (cond ((or (digit (setq x (readch))) (liter x)) (go let1)) ((eq x '!!) (go escape))) (setq nxtsym!* (intern (compress (reverse y)))) b (setq crchar!* x) c (return nxtsym!*) number(setq ttype!* 2) num1 (setq y (cons x y)) (cond ((digit (setq x (readch))) (go num1))) (setq nxtsym!* (compress (reverse y))) (go b) quote (setq crchar!* (readch)) (setq nxtsym!* (list 'quote (rread))) (setq ttype!* 4) (go c) string(prog (raise) (setq raise !*raise) (setq !*raise nil) strinx(setq y (cons x y)) (cond ((null (eq (setq x (readch)) '!")) (go strinx))) (setq y (cons x y)) (setq nxtsym!* (mkstrng (compress (reverse y)))) (setq !*raise raise)) (setq ttype!* 1) (go a1) coment(cond ((null (eq (readch) !$eol!$)) (go coment))) sepr (setq x (readch)) (go a) d (setq nxtsym!* x) (setq crchar!* '! ) (go c))) (setq crchar!* '! ) (de delcp (u) (or (eq u '!;) (eq u '!$))) (de mkstrng (u) u) (de seprp (u) (or (eq u '! ) (eq u !$eol!$))) (de scan nil (prog (x y) (cond ((null (eq cursym!* '!*semicol!*)) (go b))) a (setq nxtsym!* (token)) b (cond ((or (null (atom nxtsym!*)) (numberp nxtsym!*)) (go l)) ((and (setq x (get nxtsym!* 'newnam)) (setq nxtsym!* x)) (go b)) ((eq nxtsym!* 'comment) (go comm)) ((and (eq nxtsym!* '!') (setq cursym!* (list 'quote (rread)))) (go l1)) ((null (setq x (get nxtsym!* 'switch!*))) (go l)) ((eq (cadr x) '!*semicol!*) (return (setq cursym!* (cadr x)))) ) sw1 (setq nxtsym!* (token)) (cond ((or (null (car x)) (null (setq y (assoc nxtsym!* (car x)))) ) (return (setq cursym!* (cadr x)))) ) (setq x (cdr y)) (go sw1) comm (cond ((eq (readch) '!;) (setq crchar!* '! )) (t (go comm))) (go a) l (setq cursym!* (cond ((null (eqcar nxtsym!* 'string)) nxtsym!*) (t (cons 'quote (cdr nxtsym!*)))) ) l1 (setq nxtsym!* (token)) (return cursym!*))) (de ifstat nil (prog (condx condit) a (setq condx (xread t)) (setq condit (nconc condit (list (list condx (xread t)))) ) (cond ((null (eq cursym!* 'else)) (go b)) ((eq (scan) 'if) (go a)) (t (setq condit (nconc condit (list (list t (xread1 t)))) ))) b (return (cons 'cond condit)))) (de procstat nil (prog (x y) (cond ((eq cursym!* 'symbolic) (scan))) (cond ((eq cursym!* '!*semicol!*) (return (null (setq !*mode 'symbolic)))) ) (setq fname!* (scan)) (cond ((atom (setq x (xread1 nil))) (setq x (list x)))) (setq y (xread nil)) (cond ((flagp (car x) 'lose) (return nil))) (putd (car x) 'expr (list 'lambda (cdr x) y)) (setq fname!* nil) (return (list 'quote (car x)))) ) (de blockstat nil (prog (x hold varlis !*blockp) a0 (setq !*blockp t) (scan) (cond ((null (or (eq cursym!* 'integer) (eq cursym!* 'scalar))) (go a))) (setq x (xread nil)) (setq varlis (nconc (cond ((eqcar x '!*comma!*) (cdr x)) (t (list x))) varlis)) (go a0) a (setq hold (nconc hold (list (xread1 nil)))) (setq x cursym!*) (scan) (cond ((not (eq x 'end)) (go a))) (return (mkprog varlis hold)))) (de mkprog (u v) (cons 'prog (cons u v))) (de gostat nil (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x)))) (put 'go 'stat 'gostat) (de rlis nil (prog (x) (setq x cursym!*) (return (cond ((not (flagp (scan) 'delim)) (list x (list 'quote (list (xread1 t))))) (t (list x)))))) (rds oldchan!*) |
Added r33/build.sl version [17143cf8a4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PSL dependent file for complete rebuild of REDUCE fasl file set % Author: Anthony C. Hearn. (setq modules!* '(prolog rlisp rend arith mathlib alg1 alg2 entry matr hephys util int solve ezgcd factor rcref rsltnt algint anum gentran groebner spde mkfasl bfloat excalc)) % Note that excalc changes the meaning of various infix % operators, and so must be defined last. % The following assignments are PSL dependent. (setq *fastcar t) (setq *usermode nil) (setq *verboseload t) (load compiler) % The following is PSL dependent. (setq !*int nil) % prevents input buffer being saved (setq !*msg nil) (setq oldchan!* in!*) %%%(setq !*comp t) % It's faster if we compile the boot file. (flag '(eqcar) 'lose) % PSL dependent. (setq *syslisp t) % This makes a small difference to rlisp and rend. (dskin "symget.dat") % For fast plist access. (dskin "boot.sl") % Note that the call of "rds" at the end of the boot file seems to be % needed to make the system continue reading this input file after later % exits from calls of rds. %%(setq !*comp t) (setq *argnochk t) (begin2) rds open("prolog.red",'input); (begin2) rds open("rlisp.red",'input); (begin2) infile "rend.red"$ infile "mkfasl.red"$ end; (initreduce) (begin2) on gc,msg; ipl!* := list("util/build.sl" . oldchan!*); %to fool IN !*quotenewnam := nil; % We need to compile prolog with this off. for each x in modules!* do <<if x eq 'bfloat then load nbig else if x eq 'alg2 then eval list('load,bldmsg("%w%w",rfasl!*,"alg1")) else if x eq 'solve then eval list('load,bldmsg("%w%w",rfasl!*,"alg2")); terpri(); terpri(); semic!* := '!$; % to fool IN mkfasl x; !*quotenewnam := t>>$ bye; |
Added r33/compat.sl version [e8df961d83].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Compat.sl. Useful definitions for Cray and Sun 4 PSL versions. % Author: Winfried Neun. (remflag '(digit) 'lose) (ds digit (u) ((lambda (x) (eq 1 (wshift (wand (wdifference 8#057 (inf x)) (wdifference (inf x) 8#072)) -31))) u)) (flag '(digit) 'lose) (ds orderp (u v) (not (wgreaterp (inf u) (inf v)))) (flag '(orderp) 'lose) (ds flagp** (u v) (flagp u v)) (flag '(flagp**) 'lose) (dm terminalp (u) '(and *int (null ifl*))) (flag '(terminalp) 'lose) (ds liter (u) ((lambda (&u& &infu&) (setq &infu& (inf &u&)) (eq 0 (wor (wxor (tag &u&) id-tag) (wshift (wand (wor (wdifference &infu& 8#141) % a (wdifference 8#172 &infu&)) % z (wor (wdifference &infu& 8#101) % A (wdifference 8#132 &infu&)) % Z ) -31)))) u 0)) |
Added r33/dbuild.sl version [4faa8ced56].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Build a PSL REDUCE "in core" without the use of fasl files. (setq modules!* '(prolog rlisp rend arith alg1 rend alg2 % entry matr hephys)) % util int solve ezgcd factor rcref % rsltnt bfloat)) % The following three assignments are PSL dependent. (setq *fastcar t) (setq *usermode nil) (setq *verboseload t) (load compiler) (setq !*int nil) % prevents input buffer being saved (setq !*msg nil) (setq oldchan!* in!*) (setq !*comp nil) (flag '(eqcar) 'lose) (dskin "symget.dat") % For fast plist access. (dskin "boot.sl") % Note that the call of "rds" at the end of the boot file seems to be % needed to make the system continue reading this input file after later % exits from calls of rds. (setq !*comp t) (setq *argnochk t) (begin2) rds open("prolog.red",'input); (begin2) rds open("rlisp.red",'input); (begin2) rds open("rend.red",'input); (begin2) put('!~imports,'stat,'rlis); for each x in cdddr modules!* do infile concat(string!-downcase x,".red"); end; (load nbig) (load init!-file) (setq !*comp nil) (setq !*verboseload nil) (initreduce) |
Added r33/dosrend.red version [d043457fdf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module rend; % 386 MS-DOS PSL REDUCE "back-end". % Authors: Martin L. Griss, Anthony C. Hearn and Winfried Neun. % Except where noted, this works with both PSL 3.2 and PSL 3.4. fluid '(!*break !*eolinstringok !*gc !*int !*mode !*usermode currentreadmacroindicator!* currentscantable!* % current!-modulus errout!* lispscantable!* promptstring!* rlispscantable!*); global '(!$eol!$ !$cr!$ !*echo !*extraecho !*loadversion !*raise !*rlisp2 crchar!* date!* esc!* e!-value!* ft!-tolerance!* ifl!* ipl!* largest!-small!-modulus ofl!* pi!-value!* spare!* statcounter systemname!*); setq(!$cr!$,int2id 13); switch break,gc,usermode,verboseload; !*fastcar := t; % Since REDUCE doesn't use car and cdr on atoms. % One inessential reference to REVERSIP in this module (left unchanged). % This file defines the system dependent code necessary to run REDUCE % under PSL. Comment The following functions, which are referenced in the basic REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to complete the definition of REDUCE: BYE DELCP ERROR1 FILETYPE MKFIL ORDERP QUIT SEPRP SETPCHAR. Prototypical descriptions of these functions are as follows; remprop('bye,'stat); symbolic procedure bye; %Returns control to the computer's operating system command level. %The current REDUCE job cannot be restarted; <<close!-output!-files(); exitlisp()>>; deflist('((bye endstat)),'stat); symbolic procedure delcp u; %Returns true if U is a semicolon, dollar sign, or other delimiter. %This definition replaces one in the BOOT file; u eq '!; or u eq '!$; symbolic procedure seprp u; %returns true if U is a blank or other separator (eg, tab or ff). %This definition replaces one in the BOOT file; u eq '! or u eq '! or u eq !$eol!$ or u eq !$cr!$; symbolic procedure error1; %This is the simplest error return, without a message printed. It can %be defined as ERROR(99,NIL) if necessary; throw('!$error!$,99); symbolic procedure filetype u; %determines if string U has a specific file type. begin scalar v,w; v := cdr explode u; while v and not(car v eq '!.) do <<if car v eq '!< then while not(car v eq '!>) do v := cdr v; v := cdr v>>; if null v then return nil; v := cdr v; while v and not(car v eq '!") do <<w := car v . w; v := cdr v>>; return intern compress reversip w end; symbolic procedure mkfil u; %converts file descriptor U into valid system filename; if stringp u then u else if not idp u then typerr(u,"file name") else string!-downcase id2string u; % The following is a pretty crude definition, but since it isn't used % very much, its performance doesn't really matter. symbolic procedure string!-downcase u; begin scalar z; if not stringp u then u := id2string u; for each x in explode u do if x memq '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) then z := cdr atsoc(x, '((A . !a) (B . !b) (C . !c) (D . !d) (E . !e) (F . !f) (G . !g) (H . !h) (I . !i) (J . !j) (K . !k) (L . !l) (M . !m) (N . !n) (O . !o) (P . !p) (Q . !q) (R . !r) (S . !s) (T . !t) (U . !u) (V . !v) (W . !w) (X . !x) (Y . !y) (Z . !z))) . z else z := x . z; return compress reverse z end; symbolic procedure orderp8(u,v); % Returns true if U has same or higher order than id V by some % consistent convention (eg unique position in memory). wleq(inf u,inf v); % PSL 3.4 form. % id2int u <= id2int v; % PSL 3.2 form. loadtime copyd('orderp,'orderp8); procedure setpchar c; % Set prompt, return old one. begin scalar oldprompt; oldprompt := promptstring!*; promptstring!* := if stringp c then c else if idp c then copystring id2string c else bldmsg("%W", c); return oldprompt end; Comment The following functions are only referenced if various flags are set, or the functions are actually defined. They are defined in another module, which is not needed to build the basic system. The name of the flag follows the function name, enclosed in parentheses: BFQUOTIENT!: (BIGFLOAT) CEDIT (?) COMPD (COMP) EDIT1 This function provides a link to an editor. However, a definition is not necessary, since REDUCE checks to see if it has a function value. EMBFN (?) EZGCDF (EZGCD) FACTORF (FACTOR) LOAD!-MODULE (defined in prolog) PRETTYPRINT (DEFN --- also called by DFPRINT) This function is used in particular for output of RLISP expressions in LISP syntax. If that feature is needed, and the prettyprint module is not available, then it should be defined as PRINT RPRINT (PRET) TEXPT!: (BIGFLOAT) TEXPT!:ANY (BIGFLOAT) TIME (TIME) returns elapsed time from some arbitrary initial point in milliseconds; Comment The FACTOR module also requires a definition for GCTIME. Since this is currently undefined in PSL, we provide the following definition; symbolic procedure gctime; gctime!*; Comment The following operator is used to save a REDUCE session as a file for later use; symbolic procedure savesession u; savesystem("Saved session",u,nil); flag('(savesession),'opfn); flag('(savesession),'noval); Comment make "cd" and "system" available as operators; flag('(cd system),'opfn); flag('(cd system),'noval); Comment The current REDUCE model allows for the availability of fast arithmetical operations on small integers (called "inums"). All modern LISPs provide such support. However, the program will still run without these constructs. The relevant functions that should be defined for this purpose are as follows; remflag('(iplus itimes),'lose); remprop('iplus,'infix); % to allow for redefinition. remprop('itimes,'infix); symbolic macro procedure iplus u; expand(cdr u,'iplus2); symbolic macro procedure itimes u; expand(cdr u,'itimes2); flag('(iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp idifference iquotient iremainder ilessp igreaterp), 'lose); Comment There are also a number of system constants required for each implementation. In systems that don't support inums, the equivalent single precision integers should be used; % E!-VALUE and PI!-VALUE are values for these constants that fit in % the single precision floating point range of the machine. % FT!-TOLERANCE is the tolerance of floating point calculations. % LARGEST!-SMALL!-MODULUS is the largest power of two that can % fit in the fast arithmetic (inum) range of the implementation. % These four are constant for the life of the system and could be % compiled in-line if the compiler permits it. e!-value!* := 2.718282; pi!-value!* := 3.141593; ft!-tolerance!* := 0.000001; largest!-small!-modulus := 2**23; % If the (small) modular arithmetic is always limited to LARGEST-SMALL- % MODULUS, it all fits in the inum range of the machine, with the % exception of modular-times, that needs to use generic arithmetic for % the multiplication. However, on some machines (e.g., the VAX), it is % possible to 'borrow' the extra precision needed, so that the following % definition works. This will not work of course for non-inums. % remflag('(modular!-times),'lose); % smacro procedure modular!-times(u,v); % iremainder(itimes2(u,v),current!-modulus); % flag('(modular!-times),'lose); % The following two definitions are commented out as they lead to % unchecked vector ranges; % symbolic smacro procedure getv(a,b); igetv(a,b); % symbolic smacro procedure putv(a,b,c); iputv(a,b,c); flag('(intersection),'lose); Comment PSL Specific patches; Comment We need to define a function BEGIN, which acts as the top-level call to REDUCE, and sets the appropriate variables; % global '(startuproutine!* toploopread!* toploopeval!* toploopprint!* % toploopname!*); remflag('(begin),'go); symbolic procedure begin; begin !*echo := not !*int; !*extraecho := t; ifl!* := ipl!* := ofl!* := nil; if null date!* then go to a; if !*loadversion then errorset('(load entry),nil,nil); !*gc := nil; !*usermode := nil; linelength if !*int then 80 else 115; prin2 "REDUCE 3.3, "; prin2 date!*; prin2t " ..."; !*mode := if getd 'addsq then 'algebraic else 'symbolic; if !*mode eq 'algebraic then !*break := nil; %since most REDUCE users won't use LISP date!* := nil; a: crchar!* := '! ; if errorp errorset('(begin1),nil,nil) then go to a; %until PSL fixed prin2t "Entering LISP ... " end; flag('(begin),'go); Comment Initial setups for REDUCE; spare!* := 11; % We need this for bootstrapping. symbolic procedure initreduce; % Initial declarations for REDUCE <<statcounter := 0; spare!* := 11; !*int := t; !*eolinstringok := t; % we don't want the "string continued" msg. remd 'main; copyd('main,'rlispmain); date!* := date()>>; symbolic procedure rlispmain; begin scalar l; rlispscantable!* := mkvect 128; l := '(17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 11 11 11 20 11 00 01 02 03 04 05 06 07 08 09 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 rlispdipthong); for i:=0:128 do <<putv(rlispscantable!*,i,car l); l := cdr l>>; currentreadmacroindicator!* := 'rlispreadmacro; currentscantable!* := rlispscantable!*; errout!* := 1; % Errors to standard output, not special stream; eval '(begin); currentscantable!* := lispscantable!*; % But Slisp should use same % syntax as RLISP? standardlisp() end; flag('(dskin savesystem reclaim),'opfn); flag('(dskin savesystem),'noval); flag('(load),'noform); deflist('((load rlis)),'stat); flag('(tr trst untr untrst),'noform); deflist('((tr rlis) (trst rlis) (untr rlis) (untrst rlis)),'stat); % The following is PSL 3.4 specific. switch fulltrace; % Prevents node renaming in trace output. !*fulltrace := t; % Since we usually want it this way. Comment The global variable ESC* is used by the interactive string editor (defined in CEDIT) as a terminator for input strings. In PSL we use the escape character; esc!* := '!; Comment The following declarations are needed to build various modules; flag('(nth pnth spaces subla),'lose); % used in ALG1 flag('(explode2 explode21),'lose); % used in RPRINT flag('(flag1 remflag1),'lose); % used in RCREF Comment The following are only needed for PSL 3.2; % symbolic fexpr procedure definebop u; u; % symbolic fexpr procedure definerop u; u; Comment Specific Optimizations for Cray and Sun 4 version; remflag('(quotdd),'lose); symbolic procedure quotdd(u,v); % U and V are domain elements. Value is U/V if division is exact, % NIL otherwise. if atom u then if atom v %%% then if remainder(u,v)=0 then u/v else nil then (if cdr div = 0 then car div else NIL) where div = divide (u,v) else quotdd(apply1(get(car v,'i2d),u),v) else if atom v then quotdd(u,apply1(get(car u,'i2d),v)) else dcombine(u,v,'quotient); flag('(quotdd),'lose); remflag('(mchk),'lose); symbolic procedure mchk(u,v); IF u eq v then cons(nil,nil) else mchk!-aux (u,v); symbolic procedure mchk!-aux(U,V); if not idp u and not idp v and u=v then cons(nil,nil) else if atom v then if v memq frlis!* then list list (v . u) else nil else if atom u %special check for negative number match; then if numberp u and u<0 then mchk!-aux(list('minus,-u),v) else nil else if car u eq car v then mcharg(cdr u,cdr v,car u) else nil; flag('(mchk),'lose); remflag('(update!-pline),'lose); symbolic procedure update!-pline(x,y,pline); for each j in pline collect ((iplus2(caaar j,x) . iplus2(cdaar j,x)) . iplus2(cdar j ,y)) . cdr j; flag('(update!-pline),'lose); remflag('(peq ordpp noncomp),'lose); symbolic smacro procedure peq(u,v); %tests for equality of powers U and V; (( eq(cdu1,cdu2) and if eq(cu1,cu2) then t else if atom cu1 or atom cu2 then NIL else equal(cu1,cu2) ) where cu1 = car u1,cu2 = car u2,cdu1 = cdr u1,cdu2 = cdr u2 ) where u1 = u,u2 = v; symbolic smacro procedure ordpp(uu,vv); % This used to check (incorrectly) for NCMP!*; ((if caru eq carv then igreaterp(cdru,cdrv) else ordop(caru,carv) ) where caru = car u, carv = car v, cdru = cdr u, cdrv = cdr v )where u=uu,v=vv; symbolic smacro procedure noncomp uu; ( pairp u and ((idp caru and flagp(caru,'noncom) )where caru = car u)) where u = uu; flag('(peq ordpp noncomp),'lose); Comment Now set the system name; systemname!* := 'sparc; endmodule; end; |
Added r33/entry.red version [aeee3f82a5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module entry; % Table of entry points of self-loading modules. % Author: Anthony C. Hearn. % Using a modified version of the defautoload function of Eric Benson % and Martin L. Griss. global '(!*msg modules!* systemname!* system!*); symbolic procedure safe!-putd(name,type,body); % So that stubs will not clobber REAL entries preloaded. if getd name then !*msg and printf("%n*** Autoload stub for %p not defined%n",name) else putd(name,type,body); symbolic macro procedure defautoload u; % (defautoload name), (defautoload name loadname), % (defautoload name loadname fntype), or % (defautoload name loadname fntype numargs) % Default is 1 Arg EXPR in module of same name; begin scalar name,numargs,loadname,fntype,x; u := cdr u; name := car u; u := cdr u; if u then <<loadname := car u; u :=cdr u>> else loadname := name; if eqcar(name, 'quote) then name := cadr name; if atom loadname then if (x := get(loadname,'loadnames)) then loadname := x else loadname := list loadname else if car loadname eq 'quote then loadname := cadr loadname; if u then <<fntype := car u; u := cdr u>> else fntype := 'expr; if u then numargs := car u else numargs := 1; numargs := if numargs=0 then nil else if numargs=1 then '(x1) else if numargs=2 then '(x1 x2) else if numargs=3 then '(x1 x2 x3) else if numargs=4 then '(x1 x2 x3 x4) else error(99,list(numargs,"too large in defautoload")); return list('safe!-putd, mkquote name, mkquote fntype, list('function, list('lambda, numargs, 'progn . aconc(for each j in loadname collect list('load!-module,mkquote j), list('apply, mkquote name, 'list . numargs))))) end; COMMENT Actual Entry Point Definitions; % Bigfloat module entry point. put('bigfloat,'module!-name,'bfloat); % Compiler and LAP entry points. % defautoload(compd,compiler,expr,3); defautoload(compile,compiler); defautoload(lap,compiler); % Cross-reference module entry points. put('cref,'simpfg,'((t (crefon)) (nil (crefoff)))); defautoload(crefon,rcref,expr,0); % Factorizer module entry points. remprop('factor,'stat); defautoload(ezgcdf,ezgcd,expr,2); defautoload(factorf,'(ezgcd factor)); defautoload(factoreval,'(ezgcd factor)); put('factorize,'psopfn,'factoreval); defautoload(pfactor,'(ezgcd factor),expr,2); % defautoload(simpnprimitive,'(ezgcd factor)); % put('nprimitive,'simpfn,'simpnprimitive); defautoload(simpresultant,rsltnt); defautoload(resultant,rsltnt,expr,3); put('resultant,'simpfn,'simpresultant); put('factor,'stat,'rlis); % FASL module entry points. %defautoload(faslout,compiler); flag('(faslout),'opfn); put('faslend,'stat,'endstat); % High energy physics module entry points. remprop('index,'stat); remprop('mass,'stat); remprop('mshell,'stat); remprop('vecdim,'stat); remprop('vector,'stat); defautoload(index,hephys); defautoload(mass,hephys); defautoload(mshell,hephys); defautoload(vecdim,hephys); defautoload(vector,hephys); put('index,'stat,'rlis); put('mshell,'stat,'rlis); put('mass,'stat,'rlis); put('vecdim,'stat,'rlis); put('vector,'stat,'rlis); flagop nospur; % Input editor entry points. defautoload(cedit,util); defautoload(display,util); put('display,'stat,'rlis); defautoload(editdef,util); put('editdef,'stat,'rlis); % Integrator module entry point. defautoload(simpint,int); put('int,'simpfn,'simpint); % Matrix module entry points. defautoload(detq,matr); defautoload(generateident,matr); defautoload(matp,matr); defautoload(matrix,matr); put('matrix,'stat,'rlis); flag('(mat),'struct); put('mat,'formfn,'formmat); defautoload(formmat,matr,expr,3); defautoload(lnrsolve,matr,expr,2); % Prettyprint module entry point. defautoload(prettyprint,util); % Rprint module entry point. defautoload(rprint,util); % SOLVE module entry point. defautoload(solveeval,solve); defautoload(solve0,solve,expr,2); put('solve,'psopfn,'solveeval); % Debug module entry points. % defautoload(embfn,debug,expr,3); endmodule; end; |
Added r33/excalc.red version [f2c96049e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module excalc; % header for EXCALC --- a differential geometry package. % Author: Eberhard Schruefer; %************ patches ***************; % Meaning of ^ and # changed. !!!! BE AWARE OF THIS "!!! remprop('!^,'newnam); % plus and difference changed because we are dealing with non- % homogenous terms deflist(' ((difference getrtypeor) (plus getrtypeor) ),'rtypefn); share bndeq!*,detm!*; %*********************************************************************; %*********************************************************************; % Differential Geometry Package ; %*********************************************************************; % This version runs in REDUCE 3.3 %*********************************************************************; % Version: 2.z ; % E.Schruefer 03/12/87 ; %*********************************************************************; % testsite copy ; % ====== this program must not be redistributed or copied ====== ; %*********************************************************************; endmodule; module indxprin; % Functions for special print. % Author: Eberhard Schruefer; global '(ycoord!* ymax!* ymin!* obrkp!* !*nat orig!* !*eraise !*revpri posn!* pline!* spare!* !*nero); symbolic procedure indvarprt u; if null !*nat then <<prin2!* car u; prin2!* "("; if cddr u then inprint('!*comma!*,0,cdr u) else maprin cadr u; prin2!* ")" >> else begin scalar y; integer l; l := flatsizec flatindxl u+length cdr u-1; if l>(linelength nil-spare!*)-posn!* then terpri!* t; %avoid breaking of an indexed variable over a line; y := ycoord!*; prin2!* car u; for each j on cdr u do <<ycoord!* := y + if atom car j then 1 else -1; if ycoord!*>ymax!* then ymax!* := ycoord!*; if ycoord!*<ymin!* then ymin!* := ycoord!*; prin2!* if atom car j then car j else cadar j; if cdr j then prin2!* " ">>; ycoord!* := y end; symbolic procedure rembras u; if !*nat and (atom u or null get(car u,'infix)) then <<prin2!* " "; maprin u>> else <<prin2!* "("; maprin u; prin2!* ")">>; put('form!-with!-free!-indices,'tag,'form!-with!-free!-indices); put('form!-with!-free!-indices,'prifn,'indxpri1); flag('(form!-with!-free!-indices),'sprifn); put('indvarprt,'expt,'inbrackets); endmodule; %*********************************************************************; %***** Global variables and declaration commands ****; %*********************************************************************; module exintro; % Author: Eberhard Schruefer; global '(dimex!* lftshft!* detm!* basisforml!* sgn!* wedgemtch!* bndeq!* depl!* basisvectorl!* indxl!* nosuml!* !*nosum coord!* keepl!* metricd!* metricu!* !*product!-rule); %Some initialiations; dimex!* := !*q2f simp 'dim; sgn!* := !*k2q 'sgn; !*product!-rule := t; rlistat('(pform fdomain remfdomain tvector spacedim forder remforder frame dualframe keep closedform xpnd noxpnd isolate remisolate)); symbolic procedure spacedim u; begin dimex!* := !*q2f simp car u end; symbolic procedure fdomain u; %Sets up implicit dependencies; while u do <<if not eqexpr car u then errpri2(car u,'hold) else begin scalar y; rmsubs(); y := get(cadar u,'rtype); remprop(cadar u,'rtype); for each x in cdr caddar u do <<if indvarp x then for each j in mkaindxc flatindxl cdr x do depend1(cadar u,prepsq simpindexvar sublis(pair(flatindxl cdr x,j),x),t) else depend1(cadar u,x,t)>>; flag(list cadar u,'impfun); if y then put(cadar u,'rtype,y) end; u := cdr u>>; smacro procedure get!-impfun!-args u; cdr assoc(u,depl!*); symbolic procedure remfdomain u; %Removes implicit dependencies; begin scalar x; for each j in u do if x := assoc(j,depl!*) then <<depl!* := delete(x,depl!*); remflag(list j,'impfun)>> else rederr list(j," had no dependencies"); end; symbolic procedure putform(u,v); if atom u then put(!*a2k u,'fdegree,list !*q2f simp v) else begin scalar x,y; integer n; n := length cdr u; if (x := get(car u,'ifdegree)) and (y := assoc(n,x)) then x := delete(y,x); put(car u,'ifdegree,if x then (n . !*q2f simp v) . x else list(n . !*q2f simp v)); x := car u; flag(list x,'indexvar); %this should go. put(x,'rtype,'indexed!-form); put(x,'simpfn,'simpindexvar); put(x,'partitfn,'partitindexvar); flag(list x,'full); put(x,'prifn,'indvarprt); if null numr simp v then flag(list x,'covariant) end; symbolic procedure pform u; begin rmsubs(); for each j in u do if not eqexpr j then errpri2(j,'hold) else putform(cadr j,caddr j) end; symbolic procedure tvector u; for each j in u do putform(j,-1); symbolic procedure getlower u; cdr atsoc(u,metricd!*); symbolic procedure getupper u; cdr atsoc(u,metricu!*); symbolic procedure xpnd u; <<rmsubs(); remflag(u,'noxpnd)>>; symbolic procedure noxpnd u; <<rmsubs(); flag(u,'noxpnd)>>; symbolic procedure closedform u; <<rmsubs(); flag(u,'closed)>>; symbolic procedure memqcar(u,v); null atom u and car u memq v; smacro procedure lowerind u; list('minus,u); smacro procedure raiseind u; list('minus,u); endmodule; %*********************************************************************; %***** Functions for calculating the degree of a form ****; %*********************************************************************; module degform; % Author: Eberhard Schruefer; global '(frlis!*); symbolic procedure deg!*farg u; %Calculates the sum of degrees of the elements of the list u; if null cdr u then deg!*form car u else begin scalar z; for each j in u do z := addf(deg!*form j,z); return z end; smacro procedure get!*fdeg u; (if x then car x else nil) where x = get!*(u,'fdegree); smacro procedure get!*ifdeg u; (if x then cdr x else nil) where x = assoc(length cdr u,get(car u,'ifdegree)); symbolic procedure deg!*form u; %U is a prefix expression. Result is the degree of u; if atom u then get!*fdeg u else (if flagp(x,'indexvar) then get!*ifdeg u else if x eq 'wedge then deg!*farg cdr u else if x eq 'd then addd(1,deg!*form cadr u) else if x eq 'hodge then addf(dimex!*,negf deg!*form cadr u) else if x eq 'partdf then if cddr u then nil else -1 else if x eq 'liedf then deg!*form caddr u else if x eq 'innerprod then addd(-1,deg!*form caddr u) else if x memq '(plus minus difference quotient) then deg!*form cadr u else if x eq 'times then deg!*farg cdr u else nil) where x = car u; symbolic procedure exformp u; %test for exterior forms and vectors in prefix expressions; if null u or numberp u then nil else if atom u and u memq frlis!* then t else if atom u then get(u,'fdegree) else if flagp(car u,'indexvar) then assoc(length cdr u,get(car u,'ifdegree)) else if car u eq '!*sq then exformp prepsq cadr u else if car u memq '(wedge d partdf hodge innerprod liedf) then t else if get(car u,'dname) then nil else lexformp cdr u or exformp car u; symbolic procedure lexformp u; u and (exformp car u or lexformp cdr u); endmodule; %*********************************************************************; %**** Partitioned standard forms ****; %*********************************************************************; module partitsf; % Author: Eberhard Schruefer; fluid '(alglist!* !*exp); smacro procedure ldpf u; %selector for leading standard form in patitioned sf; caar u; smacro procedure tpsf u; %selector for leading term in partitioned sf; car u; smacro procedure !*k2pf u; u .* (1 ./ 1) .+ nil; smacro procedure negpf u; multpfsq(u,(-1) ./ 1); symbolic procedure partitop u; begin scalar x,alglist!*; return if atom u then if x := get(u,'avalue) then partitsq!* simp!* cadr x else if get!*fdeg u then mkupf u else if numr(x := simp!* u) then 1 .* x .+ nil else nil else if x := get(car u,'partitfn) then if flagp(car u,'full) then apply1(x,u) else apply1(x,cdr u) else if car u eq '!*sq then partitsq!* simp!* u else if car u eq 'plus then <<for each j in cdr u do x := addpf(partitop j,x); x>> else if car u eq 'minus then negpf partitop cadr u else if car u eq 'difference then addpf(partitop cadr u, negpf partitop caddr u) else if car u eq 'times then <<x := partitop cadr u; for each j in cddr u do x := multpfs(partitop j,x); x>> else if car u eq 'quotient then multpfsq(partitop cadr u,simprecip cddr u) else if car u eq 'recip then 1 .* simprecip cdr u .+ nil else if numr(x := simp!* u) then 1 .* x .+ nil else nil end; symbolic procedure mkupf u; begin scalar x; x := mksq(u,1); return if null numr x then nil else if (denr x = 1) and (lc numr x = 1) and null red numr x and null sfp mvar numr x then !*k2pf mvar numr x else partitsq!* x end; symbolic procedure partitsq(u,v); %U is a standardquotient. Result is a form in which expressions %satisfying the test v are distributed and the rest is kept %recursive. Leaves unexpanded structure if possible; (if null x then nil else if domainp x then 1 .* u .+ nil else addpsf(if sfp mvar x and apply1(v,mvar x) then multpsf(exptpsf(partitsq(mvar x ./ 1,v), ldeg x), partitsq(cancel(lc x ./ y),v)) else if null sfp mvar x and apply1(v,!*k2f mvar x) then multpsf(!*p2f lpow x .* (1 ./ 1) .+ nil, partitsq(cancel(lc x ./ y),v)) else multsqpsf(!*p2q lpow x, partitsq(cancel(lc x ./ y),v)), partitsq(cancel(red x ./ y),v))) where x = numr u, y = denr u; symbolic procedure exptpsf(u,n); begin scalar x; x := u; while (n := n-1) > 0 do x := multpsf(u,x); return x end; symbolic procedure exptpf(u,n); begin scalar x; x := u; while (n := n-1) > 0 do x := multpfs(u,x); return x end; symbolic procedure addpsf(u,v); if null u then v else if null v then u else if domainp ldpf u then addmpsf(u,v) else if domainp ldpf v then addmpsf(v,u) else if ldpf u = ldpf v then (lambda x,y; if null numr x then y else ldpf u .* x .+ y) (addsq(lc u,lc v),addpsf(red u,red v)) else if ordpp(lpow ldpf u,lpow ldpf v) then lt u .+ addpsf(red u,v) else lt v .+ addpsf(u,red v); symbolic procedure addpf(u,v); if null u then v else if null v then u else if ldpf u = 1 then addmpf(u,v) else if ldpf v = 1 then addmpf(v,u) else if ldpf u = ldpf v then (lambda x,y; if null numr x then y else ldpf u .* x .+ y) (addsq(lc u,lc v),addpf(red u,red v)) else if ordop(ldpf u,ldpf v) then lt u .+ addpf(red u,v) else lt v .+ addpf(u,red v); symbolic procedure addmpf(u,v); if null v then u else if ldpf v = 1 then 1 .* addsq(lc u,lc v) .+ nil else lt v .+ addmpf(u,red v); symbolic procedure addmpsf(u,v); if null v then u else if domainp ldpf v then 1 .* addsq(multsq(ldpf u ./ 1,lc u), multsq(ldpf v ./ 1,lc v)) .+ nil else lt v .+ addmpsf(u,red v); symbolic procedure multpsf(u,v); if null u or null v then nil else addpsf(addpsf(multtpsf(lt u,lt v),multpsf(red u,v)), multpsf(!*t2f lt u,red v)); symbolic procedure multpfs(u,v); if null u or null v then nil else if ldpf u = 1 then multpfsq(v,lc u) else if ldpf v = 1 then multpfsq(u,lc v) else addpf(addpf(multttpf(lt u,lt v),multpfs(red u,v)), multpfs(lt u .+ nil,red v)); symbolic procedure multttpf(u,v); if car u = 1 then car v .* multsq(tc u,tc v) .+ nil else if car v = 1 then car u .* multsq(tc u,tc v) .+ nil else rederr "illegal factor in pf"; symbolic procedure multpfsq(u,v); if null u or null numr v then nil else ldpf u .* multsq(lc u,v) .+ multpfsq(red u,v); symbolic procedure multtpsf(u,v); begin scalar x,xexp; xexp := !*exp; !*exp := t; x := if car u = 1 then car v else if car v = 1 then car u else multf(tpsf u,tpsf v); !*exp := xexp; return multsqpsf(multsq(tc u,tc v),x .* (1 ./ 1) .+ nil) end; symbolic procedure multsqpsf(u,v); if null numr u or null v then nil else ldpf v .* multsq(u,lc v) .+ multsqpsf(u,red v); symbolic procedure repartit u; if null u then nil else addpf(multpfsq(partitop ldpf u,lc u),repartit red u); symbolic procedure partitsq!* u; %U is a standardquotient. Partitfunction for *sq's. %Leaves unexpanded structure if possible; (if null x then nil else if domainp x then 1 .* u .+ nil else addpf(if sfp mvar x and sfexform1p lt mvar x then multpfsq(exptpf(partitsq!*(mvar x ./ 1), ldeg x), cancel(lc x ./ y)) else if null sfp mvar x and deg!*form mvar x then mvar x .* cancel(lc x ./ y) .+ nil else multpfsq(partitsq!*(lc x ./ y), !*p2q lpow x), partitsq!*(red x ./ y))) where x = numr u, y = denr u; symbolic procedure sfexform1p u; (if sfp tvar u then sfexform1p lt tvar u else deg!*form tvar u) or (null domainp tc u and sfexform1p lt tc u); symbolic procedure !*pf2sq u; begin scalar res; res := nil ./ 1; if null u then return res; for each j on u do res := addsq(multsq(if ldpf j = 1 then 1 ./ 1 else !*k2q ldpf j,lc j),res); return res end; symbolic procedure mk!*sqpf u; if null u then nil else ldpf u .* mk!*sq lc u .+ mk!*sqpf red u; symbolic procedure !*pfsq2pf u; if null u then nil else (lambda x; if numr x then ldpf u .* x .+ !*pfsq2pf red u else !*pfsq2pf red u) simp!* lc u; endmodule; %*********************************************************************; %****** Functions for ordering *****; %*********************************************************************; module forder; % Author: Eberhard Schruefer; global '(wedgemtch!* lftshft!* indxl!* subfg!*); fluid '(kord!*); symbolic procedure add2l(u,v); !*a2k u . if u memq v then delete(u,v) else v; symbolic procedure forder u; forder1 u; symbolic procedure forder1 u; (lambda x; while x do <<kord!* := add2l(car x,kord!*); if eqcar(car x,'wedge) then for each j in reverse cdar x do kord!* := add2l(j,kord!*); x:=cdr x>>) reverse u; symbolic procedure remforder u; for each j in u do kord!* := delete(j,kord!*); symbolic procedure isolate u; rederr "Sorry, ISOLATE not supported in this version"; % for each j in u do % <<lftshft!* := !*a2k car u . lftshft!*; % kord!* := !*a2k car u . kord!*>>; symbolic procedure remisolate u; for each j in u do lftshft!* := delete(j,lftshft!*); smacro procedure wedgeordp(u,v); worderp(u,v); symbolic procedure worderp(x,y); %Needs more work! if null atom x and flagp(car x,'indexvar) and null atom y and flagp(car y,'indexvar) then if atom cadr x and (cadr x member indxl!*) and atom cadr y and (cadr y member indxl!*) then if (car x eq car y) then indordp(cadr x,cadr y) else ordop(car x,car y) else ordop(x,y) else if atom x or (x memq kord!*) then if atom y or (y memq kord!*) then ordop(x,y) else worderp(x,peel y) else if atom y or (y memq kord!*) then worderp(peel x,y) else worderp(peel x,peel y); symbolic procedure indexvarordp(u,v); if null(car u eq car v) then ordop(car u,car v) else indordlp(flatindxl cdr u,flatindxl cdr v); symbolic procedure indordlp(u,v); if null u then nil else if null v then t else if car u eq car v then indordlp(cdr u, cdr v) else indordp(car u,car v); symbolic procedure peel u; if car u memq '(liedf innerprod) then u := caddr u else if car u eq 'quotient then if worderp(cadr u,caddr u) then u:=cadr u else u:=caddr u else u:=cadr u; symbolic procedure indordp(u,v); begin scalar x; x := indxl!*; if null(u memq x) then return t; a: if null x then return orderp(u,v); if u eq car x then return t else if v eq car x then return nil; x:=cdr x; go to a end; symbolic procedure indordn u; if null u then nil else if null cdr u then u else if null cddr u then indord2(car u,cadr u) else indordad(car u,indordn cdr u); symbolic procedure indord2(u,v); if indordp(u,v) then list(u,v) else list(v,u); symbolic procedure indordad(a,u); if null u then list a else if indordp(a,car u) then a . u else car u . indordad(a,cdr u); symbolic procedure keep u; while u do <<if not eqexpr car u then errpri2(car u,'hold) else begin scalar x,y,z; z := subfg!*; subfg!* := nil; x := !*a2k cadar u; y := !*a2k caddar u; forder1 list(x,y); keepl!* := (x . y) . keepl!*; flag(list x,'keep); put(x,'keepl,list y); subfg!* := z; putdep(x,y); if null exdfk y then flag(list x,'closed); if eqcar(y,'wedge) then <<wedgemtch!*:=(cdr y . x) . wedgemtch!*; for each j in cdr y do wedgemtch!* := (list(x,j) . nil) . wedgemtch!*>> else let2(y,x,nil,t) end; u := cdr u>>; symbolic procedure putdep(u,v); for each j in cdr v do if atom j then depend1(u,j,t) else putdep(u,j); endmodule; %*********************************************************************; %***** Exterior multiplication ****; %*********************************************************************; module wedge; % Author: Eberhard Schruefer; global '(dimex!* lftshft!* wedgemtch!*); newtok '((!^) wedge); flag('(wedge),'nary); infix wedge; precedence wedge,times; put('wedge,'simpfn,'simpwedge); put('wedge,'rtypefn,'getrtypeor); put('wedge,'partitfn,'partitwedge); symbolic procedure partitwedge u; if null cdr u then partitop car u else mkuniquewedge xpndwedge u; symbolic procedure oddp m; fixp m and remainder(m,2)=1; symbolic procedure mksgnsq u; if null (u := evenfree u) then 1 ./ 1 else if u = 1 then (-1) ./ 1 else simpexpt list(-1,mk!*sq(u ./ 1)); symbolic procedure evenfree u; if null u then nil else if numberp u then absf cdr qremd(u,2) else addf(absf cdr qremd(!*t2f lt u,2),evenfree red u); smacro procedure lwf u; %selector for leading factor in wedge. car u; smacro procedure rwf u; %selector for the rest of factors in wedge. cdr u; smacro procedure lftshftp u; smemqlp(lftshft!*,u); symbolic procedure mkwedge u; !*k2pf u; symbolic procedure wedgemtch u; begin scalar x,y,z; y := u; a: x := car y . x; if z := assoc(reverse x,wedgemtch!*) then return if cdr z then if cdr y then 'wedge . append(cdr z,cdr y) else cdr z else 0; y := cdr y; if y then go to a else return nil end; symbolic procedure simpwedge u; !*pf2sq partitwedge u; symbolic procedure xpndwedge u; if null cdr u then mkunarywedge partitop car u else wedgepf2(partitop car u,xpndwedge cdr u); symbolic procedure mkunarywedge u; if null u then nil else list ldpf u .* lc u .+ mkunarywedge red u; symbolic procedure mkuniquewedge u; if null u then nil else addpf(multpfsq(mkuniquewedge1 ldpf u,lc u), mkuniquewedge red u); symbolic procedure mkuniquewedge1 u; if null cdr u then mkupf car u else begin scalar x; return if wedgemtch!* and (x := wedgemtch u) then partitop x else mkupf('wedge . u) end; symbolic procedure wedgepf2(u,v); %Basic binary exterior product routine. %v is an exterior product (without wedge tag), u a form. if null u or null v then nil else addpf(wedget2(lt u,lt v), addpf(wedgepf2(lt u .+ nil,red v),wedgepf2(red u,v))); smacro procedure multwedgesq(u,v); %possible entry for lazy multiplication. multsq(u,v); symbolic procedure wedget2(u,v); if car u = 1 then car v .* multsq(cdr u,cdr v) .+ nil else if caar v = 1 then list car u .* multsq(cdr u,cdr v) .+ nil else multpfsq(wedgek2(car u,car v,nil),multwedgesq(tc u,tc v)); symbolic procedure wedgek2(u,v,w); if u eq car v and null eqcar(u,'wedge) then if oddp deg!*form u then nil else multpfsq(wedgef(u . v),mksgnsq w) else if eqcar(car v,'wedge) then wedgek2(u,cdar v,w) else if eqcar(u,'wedge) then multpfsq(wedgewedge(cdr u,v),mksgnsq w) else if wedgeordp(u,car v) then multpfsq(wedgef(u . v),mksgnsq w) else if cdr v then wedgepf2(!*k2pf car v, wedgek2(u,cdr v,addf(w,multf(deg!*form u, deg!*form car v)))) else multpfsq(wedgef list(car v,u), mksgnsq addf(w,multf(deg!*form u,deg!*form car v))); symbolic procedure wedgewedge(u,v); if null cdr u then wedgepf2(!*k2pf car u,!*k2pf v) else wedgepf2(!*k2pf car u,wedgewedge(cdr u,v)); symbolic procedure wedgef u; if dim!<deg u then nil else if eqcar(car u,'hodge) then (if m = deg!*farg cdr u then multpfsq(wedgepf2(!*k2pf cadar u, mkunarywedge hodgepf if cddr u then mkuniquewedge1 cdr u else !*k2pf cadr u), mksgnsq multf(m,addf(m,negf dimex!*))) else mkwedge u) where m = deg!*form cadar u else if eqcar(car u,'d) and (flagp('d,'noxpnd) or lftshftp cadar u) then addpf(mkunarywedge dwedge(cadar u . cdr u), multpfsq(wedgepf2(!*k2pf cadar u, mkunarywedge if cddr u then dwedge cdr u else exdfk cadr u), negsq mksgnsq deg!*form cadar u)) else mkwedge u; endmodule; %*********************************************************************; %***** Exterior differentiation ****; %*********************************************************************; module exdf; % Author: Eberhard Schruefer; global '(naturalframe2coframe dbaseform2base2form basisforml!* dimex!* subfg!*); put('d,'simpfn,'simpexdf); put('d,'rtypefn,'getrtypecar); put('d,'partitfn,'partitexdf); symbolic procedure partitexdf u; exdfpf partitop car u; symbolic procedure simpexdf u; !*pf2sq partitexdf u; symbolic procedure mkexdf u; begin scalar x,y; return if x := opmtch(y := list('d,u)) then partitop x else mkupf y end; symbolic procedure exdfpf u; if null u then nil else addpf(if ldpf u = 1 then exdf0 lc u else addpf(multpfsq(exdfk ldpf u,lc u), mkuniquewedge wedgepf2(exdf0 lc u, !*k2pf list ldpf u)), exdfpf red u); symbolic procedure exdfk u; if u = 1 or eqcar(u,'d) or dim!<!=deg u or flagp(lid u,'closed) then nil else if flagp('d,'noxpnd) or lftshftp u then mkexdf u else if atomf u then if (not flagp('partdf,'noxpnd)) and flagp(lid u,'impfun) then dimpfun(u,get!-impfun!-args lid u) else if coordp u then if subfg!* then !*pfsq2pf cdr atsoc(u,naturalframe2coframe) else mkexdf u else if basisformp u and dbaseform2base2form then !*pfsq2pf cdr atsoc(u,dbaseform2base2form) else mkexdf u else if (car u eq 'wedge) then dwedge cdr u else if car u memq '(hodge innerprod liedf) then mkexdf u else if car u eq 'partdf then if not flagp('partdf,'noxpnd) and atomf cadr u then dimpfun(u,get!-impfun!-args lid cadr u) else mkexdf u else begin scalar x,y,z; if null(x := get(car u,'dfn)) then return mkexdf u; z := cdr u; for each j in for each k in z collect partitexdf list k do <<if j then y := addpf(multpfsq(j,simp subla(pair(caar x,z),cdar x)), y); x := cdr x>>; return y end; symbolic procedure lid u; if atom u then u else car u; symbolic procedure atomf u; atom u or flagp(car u,'indexvar); symbolic procedure dim!<!=deg u; (null x or (fixp x and x<=0)) where x = addf(dimex!*,negf deg!*form u); symbolic procedure dim!<deg u; begin scalar x; x := addf(dimex!*,negf deg!*farg u); return if numberp x and minusp x then t else nil end; symbolic procedure dimpfun(u,v); if null v then nil else addpf(multpfsq(exdfp0(car v . 1),partdfsq(simp u,car v)), dimpfun(u,cdr v)); symbolic procedure exdf0 u; multpfsq(addpf(exdff0 numr u,multpfsq(exdff0 negf denr u,u)), 1 ./ denr u); symbolic procedure exdff0 u; if domainp u then nil else addpf(addpf(multpfsq(exdff0 lc u,!*p2q lpow u), multpfsq(exdfp0 lpow u,lc u ./ 1)), exdff0 red u); symbolic procedure exdfp0 u; %weighted vars ?? begin scalar pv,n,z; pv := car u; n := pdeg u; return if (sfp pv or exformp pv or null subfg!*) and (z := if sfp pv then exdff0 pv else exdfk pv) then if n = 1 then z else multpfsq(z,!*t2q((pv to (n - 1)) .* n)) else nil end; symbolic procedure dwedge u; %u is a wedge argument, result is a pf. mkuniquewedge dwedge1(u,nil); symbolic procedure dwedge1(u,v); if null rwf u then mkunarywedge multpfsq(exdfk lwf u,mksgnsq v) else addpf(wedgepf2(!*k2pf lwf u, dwedge1(rwf u,addf(v,deg!*form lwf u))), multpfsq(wedgepf2(exdfk lwf u,!*k2pf rwf u),mksgnsq v)); symbolic procedure exdfprn u; <<prin2!* "d"; rembras cadr u>>; put('d,'prifn,'exdfprn); endmodule; %*********************************************************************; %***** Partial differentiation ****; %*********************************************************************; module partdf; % Author: Eberhard Schruefer; %adapted df module; global '(naturalvector2framevector depl!* wtl!* keepl!*); fluid '(alglist!*); newtok '((!@) partdf); symbolic procedure simppartdf0 u; begin scalar v; if null cdr u then if coordp(u := reval car u) and (v := atsoc(u,naturalvector2framevector)) then return !*pf2sq !*pfsq2pf cdr v else return mksq(list('partdf,u),1); if null subfg!* or freeindp car u or freeindp cadr u or (cddr u and freeindp caddr u) then return mksq('partdf . revlis u,1); v := cdr u; u := simp!* car u; for each j in v do u := partdfsq(u,!*a2k j); return u end; put('partdf,'simpfn,'simppartdf); put('partdf,'rtypefn,'getrtypeor); put('partdf,'partitfn,'partitpartdf); symbolic procedure partitpartdf u; if null cdr u then mknatvec !*a2k car u else 1 .* simppartdf0 u .+ nil; symbolic procedure simppartdf u; !*pf2sq partitpartdf u; symbolic procedure mknatvec u; begin scalar x,y; return if x := atsoc(u,naturalvector2framevector) then !*pfsq2pf cdr x else if x := opmtch(y := list('partdf,u)) then partitop x else mkupf y end; symbolic procedure partdfsq(u,v); multsq(addsq(partdff(numr u,v), multsq(u,partdff(negf denr u,v))), 1 ./ denr u); symbolic procedure partdff(u,v); if domainp u then nil ./ 1 else addsq(if null !*product!-rule then partdft(lt u,v) else addsq(multpq(lpow u,partdff(lc u,v)), multsq(partdfpow(lpow u,v),lc u ./ 1)), partdff(red u,v)); symbolic procedure partdft(u,v); begin scalar x,y; x := partdft1(!*t2q u,v); y := nil ./ 1; for each j on x do if null domainp ldpf j then y := addsq(multsq(if domainp lc ldpf j then multsq(partdfpow(lpow ldpf j,v), lc ldpf j ./ 1) else mksq(list('partdf,prepf ldpf j,v),1), lc j),y); return y end; symbolic procedure partdft1(u,v); (if null x then nil else if domainp x then 1 .* u .+ nil else addpsf(if sfp mvar x and numr partdfpow(lpow mvar x,v) then multpsf(exptpsf(partdft1(mvar u ./ 1,v), ldeg x), partdft1(cancel(lc x ./ y),v)) else if null sfp mvar x and numr partdfpow(lpow x,v) then multpsf(!*p2f lpow x .* (1 ./ 1) .+ nil, partdft1(cancel(lc x ./ y),v)) else multsqpsf(!*p2q lpow x, partdft1(cancel(lc x ./ y),v)), partdft1(cancel(red x ./ y),v))) where x = numr u, y = denr u; symbolic procedure partdfpow(u,v); begin scalar x,z; integer n; n := cdr u; u := car u; z := nil ./ 1; if u eq v then z := 1 ./ 1 else if atomf u then if x := assoc(u,keepl!*) then begin scalar alglist!*; z := partdfsq(simp0 cdr x,v) end else if ndepends(if x := get(lid u,'varlist) then lid u . cdr x else lid u,v) then z := mksq(list('partdf,u,v),1) else return nil ./ 1 else if sfp u then z := partdff(u,v) else if car u eq '!*sq then z := partdfsq(cadr u,v) else if x := get(car u,'dfn) then for each j in for each k in cdr u collect partdfsq(simp k,v) do <<if numr j then z := addsq(multsq(j,simp subla(pair(caar x,cdr u),cdar x)), z); x := cdr x>> else if car u eq 'partdf then if ndepends(lid cadr u,v) then if assoc(list('partdf,cadr u,v), get('partdf,'kvalue)) then <<z := mksq(list('partdf,cadr u,v),1); for each j in cddr u do z := partdfsq(z,j)>> else <<z := 'partdf . cadr u . ordn(v . cddr u); z := if x := opmtch z then simp x else mksq(z,1)>> else return nil ./ 1; if x := atsoc(u,wtl!*) then z := multpq('k!* to (-cdr x),z); return if n=1 then z else multsq(!*t2q((u to (n-1)) .* n),z) end; symbolic procedure ndepends(u,v); if null u or numberp u or numberp v then nil else if u=v then u else if atom u and u memq frlis!* then t else if (lambda x; x and lndepends(cdr x,v)) assoc(u,depl!*) then t else if not atom u and idp car u and get(car u,'dname) then nil else if not atomf u and (lndepends(cdr u,v) or ndepends(car u,v)) then t else if atomf v or idp car v and get(car v,'dname) then nil else ndependsl(u,cdr v); symbolic procedure lndepends(u,v); u and (ndepends(car u,v) or lndepends(cdr u,v)); symbolic procedure ndependsl(u,v); u and (ndepends(u,car v) or ndependsl(u,cdr v)); symbolic procedure partdfprn u; if null !*nat then <<prin2!* '!@; prin2!* "("; if cddr u then inprint('!*comma!*,0,cdr u) else maprin cadr u; prin2!* ")" >> else begin scalar y; integer l; l := flatsizec flatindxl cdr u+1; if l>(linelength nil-spare!*)-posn!* then terpri!* t; %avoids breaking of the operator over a line; y := ycoord!*; prin2!* '!@; ycoord!* := y - if (null cddr u and indexvp cadr u) or (cddr u and indexvp caddr u) then 2 else 1; if ycoord!*<ymin!* then ymin!* := ycoord!*; if null cddr u then <<maprin cadr u; ycoord!* := y>> else <<for each j on cddr u do <<maprin car j; if cdr j then prin2!* " ">>; ycoord!* := y; if atom cadr u then prin2!* cadr u else <<prin2!* "("; maprin cadr u; prin2!* ")">>>> end; put('partdf,'prifn,'partdfprn); symbolic procedure indexvp u; null atom u and flagp(car u,'indexvar); endmodule; %*********************************************************************; %***** Hodge-* duality operator ****; %*********************************************************************; module hodge; % Author: Eberhard Schruefer; global '(dimex!* sgn!* detm!* basisforml!*); symbolic procedure formhodge(u,vars,mode); if mode eq 'symbolic then 'hash . formlis(cdr u,vars,mode) else 'list . mkquote 'hodge . formlis(cdr u,vars,mode); put('hash,'formfn,'formhodge); put('hodge,'simpfn,'simphodge); put('hodge,'rtypefn,'getrtypecar); put('hodge,'partitfn,'partithodge); symbolic procedure partithodge u; hodgepf partitop car u; symbolic procedure simphodge u; !*pf2sq partithodge u; symbolic procedure mkhodge u; begin scalar x,y; return if x := opmtch(y := list('hodge,u)) then partitop x else if deg!*form u = dimex!* then 1 .* mksq(y,1) .+ nil else mkupf y end; smacro procedure mkbaseform u; mkupf list(caar basisforml!*,u); symbolic procedure basisformp u; null atom u and (u memq basisforml!*); symbolic procedure hodgepf u; if null u then nil else addpf(multpfsq(hodgek ldpf u,lc u),hodgepf red u); symbolic procedure hodgek u; if eqcar(u,'hodge) then cadr u .* multsq(mksgnsq multf(deg!*form cadr u, addf(dimex!*,negf deg!*form cadr u)), sgn!*) .+ nil else if basisformp u then dual list u else if eqcar(u,'wedge) and boundindp(cdr u,basisforml!*) then dual cdr u else mkhodge u; symbolic procedure dual u; (multpfsq(mkdual xpnddual u, simpexpt list(mk!*sq(absf numr x ./ absf denr x),'(quotient 1 2)))) where x = simp!* detm!*; symbolic procedure !*met2pf u; metpf1 getupper cadr u; symbolic procedure xpnddual u; if null cdr u then mkunarywedge !*met2pf car u else wedgepf2(!*met2pf car u,xpnddual cdr u); symbolic procedure metpf1 u; if null u then nil else addpf(multpfsq(mkbaseform caar u,simp cdar u),metpf1 cdr u); symbolic procedure mkdual u; if null u then nil else addpf(multpfsq(((if null x then nil else if cdr ldpf x then multpfsq(mkuniquewedge1 ldpf x, lc x) else car ldpf x .* lc x .+ nil) where x = dualk ldpf u), lc u),mkdual red u); symbolic procedure dualk u; begin scalar x; x := !*k2pf basisforml!*; a: x := dualk2(car u,x); if null(u := cdr u) then return x; go to a end; symbolic procedure dualk2(u,v); dualk0(u,v,nil); symbolic procedure dualk0(u,v,w); if u eq car ldpf v then if null cdr ldpf v then list 1 .* multsq(mksgnsq w,lc v) .+ nil else cdr ldpf v .* multsq(mksgnsq w,lc v) .+ nil else if null cdr ldpf v then nil else wedgepf2(!*k2pf ldpf car v, dualk0(u,cdr ldpf v .* lc v .+ nil,addf(w,1))); symbolic procedure hodgeprn u; <<prin2!* "#"; rembras cadr u>>; put('hodge,'prifn,'hodgeprn); endmodule; %*********************************************************************; %***** Inner product ****; %*********************************************************************; module innerprod; % Author: Eberhard Schruefer; newtok '((!_ !|) innerprod); infix innerprod; precedence innerprod,times; %flag('(innerprod),'nary); %not done for now, but might be worthwhile. put('innerprod,'simpfn,'simpinnerprod); put('innerprod,'rtypefn,'getrtypeor); put('innerprod,'partitfn,'partitinnerprod); symbolic procedure partitinnerprod u; innerprodpf(partitop car u, partitop cadr u); symbolic procedure mkinnerprod(u,v); begin scalar x,y; return if x := opmtch(y := list('innerprod,u,v)) then partitop x else if deg!*form v = 1 then if numr(x := mksq(y,1)) then 1 .* x .+ nil else nil else mkupf y end; symbolic procedure simpinnerprod u; !*pf2sq partitinnerprod u; symbolic procedure innerprodpf(u,v); if null u or null v then nil else if ldpf v = 1 then nil else begin scalar res,x; for each j on u do for each k on v do if x := innerprodf(ldpf j,ldpf k) then res := addpf(multpfsq(x,multsq(lc j,lc k)),res); return res end; symbolic procedure basisvectorp u; null atom u and u memq basisvectorl!*; symbolic procedure tvectorp u; (numberp x and x<0) where x = deg!*form ldpf u; symbolic procedure innerprodf(u,v); %Inner product dispatching routine. if null tvectorp !*k2pf u then rederr "first argument of inner product must be a vector" else if v = 1 then nil %is this test necessary?? else if eqcar(v,'wedge) then innerprodwedge(u,cdr v) else if eqcar(u,'partdf) and null freeindp cadr u then innerprodnvec(u,v) else if basisvectorp u and basisformp v then innerprodbasis(u,v) else if eqcar(v,'innerprod) then if u eq cadr v then nil else if ordop(u,cadr v) then mkinnerprod(u,v) else negpf innerprodpf(!*k2pf cadr v, innerprodf(u,caddr v)) else mkinnerprod(u,v); symbolic procedure innerprodwedge(u,v); mkuniquewedge innerprodwedge1(u,v,nil); symbolic procedure innerprodwedge1(u,v,w); if null rwf v then mkunarywedge multpfsq(innerprodf(u,lwf v),mksgnsq w) else addpf(if null rwf rwf v and (deg!*form lwf rwf v = 1) then multpfsq(!*k2pf list lwf v, multsq(mksgnsq addf(deg!*form lwf v,w), !*pf2sq innerprodf(u,lwf rwf v))) else wedgepf2(!*k2pf lwf v, innerprodwedge1(u,rwf v, addf(w,deg!*form lwf v))), if deg!*form lwf v = 1 then multpfsq(!*k2pf rwf v, multsq(!*pf2sq innerprodf(u,lwf v), mksgnsq w)) else wedgepf2(innerprodf(u,lwf v), rwf v .* mksgnsq w .+ nil)); symbolic procedure innerprodnvec(u,v); if eqcar(v,'d) and null deg!*form cadr v and null freeindp cadr v then if cadr u eq cadr v then 1 .* (1 ./ 1) .+ nil else nil else if basisformp v then begin scalar x,osubfg; osubfg := subfg!*; subfg!* := nil; x := innerprodpf(!*k2pf u, partitop cdr assoc(v,keepl!*)); subfg!* := osubfg; return repartit x end; symbolic procedure innerprodbasis(u,v); if freeindp u or freeindp v then mkinnerprod(u,v) else if cadadr u eq cadr v then 1 .* (1 ./ 1) .+ nil else nil; endmodule; %*********************************************************************; %***** Lie derivative ****; %*********************************************************************; module liedf; % Author: Eberhard Schruefer; global '(commutator!-of!-framevectors); newtok '((!| !_ ) liedf); infix liedf; %flag('(liedf),'nary); %Not done for now, but should be considered. precedence liedf,innerprod; put('liedf,'simpfn,'simpliedf); put('liedf,'rtypefn,'getrtypeor); symbolic procedure simpliedf u; !*pf2sq partitliedf u; put('liedf,'partitfn,'partitliedf); symbolic procedure partitliedf u; liedfpf(partitop car u,partitop cadr u); symbolic procedure mkliedf(u,v); begin scalar x,y; return if x := opmtch(y := list('liedf,u,v)) then partitop x else mkupf y end; symbolic procedure liedfpf(u,v); if null tvectorp u then rederr "first argument of lie derivative must be a vector" else if null tvectorp v then addpf(exdfpf innerprodpf(u,v), innerprodpf(u,exdfpf v)) else begin scalar x; for each k on u do for each l on v do x := addpf(liedftt(lt k,lt l),x); return x end; symbolic procedure liedftt(u,v); begin scalar x; return addpf(multpfsq(liedfk(car u,car v),multsq(tc u,tc v)), addpf(if x := innerprodpf(!*k2pf car u,exdf0 tc v) then car v .* multsq(!*pf2sq x,tc u) .+ nil else nil, if x := innerprodpf(!*k2pf car v,exdf0 tc u) then car u .* negsq multsq(!*pf2sq x,tc v) .+ nil else nil)) end; symbolic procedure liedfk(u,v); if u eq v then nil else if eqcar(u,'partdf) and eqcar(v,'partdf) then nil else if basisvectorp u and basisvectorp v then if null ordop(u,v) then negpf liedfk(v,u) else if commutator!-of!-framevectors then get!-structure!-const(u,v) else mkliedf(u,v) else if eqcar(v,'liedf) then if ordop(u,cadr v) then mkliedf(u,v) else addpf(liedfpf(liedfk(u,cadr v),!*k2pf caddr v), liedfpf(!*k2pf cadr v, liedfpf(!*k2pf u,!*k2pf caddr v))) else if worderp(u,v) then mkliedf(u,v) else negpf mkliedf(v,u); symbolic procedure get!-structure!-const(u,v); %We currently assume that only the basis has structure consts. begin scalar x; return if x := assoc(list(cadadr u,cadadr v), commutator!-of!-framevectors) then !*pfsq2pf cdr x else nil end; endmodule; %*********************************************************************; %***** Variational derivative ****; %*********************************************************************; module vardf; % Author: Eberhard Schruefer; global '(depl!* keepl!* bndeq!*); fluid '(kord!*); symbolic procedure simpvardf u; if indvarpf numr simp0 cadr u then mksq('vardf . u,1) else begin scalar b,r,v,w,x,y,z; v := !*a2k cadr u; if null cddr u then w := intern compress append(explode '!', explode if atom v then v else car v) else w := caddr u; if null atom v then w := w . cdr v; putform(w,deg!*form v); kord!* := append(list(w := !*a2k w),kord!*); if x := assoc(v,depl!*) then for each j in cdr x do depend1(w,j,t); x := varysq(simp!* car u,v,w); b := y := nil ./ 1; while x do if (z := mvar ldpf x) eq w then <<y := addsq(lc x,y); x := red x>> else if eqcar(z,'wedge) then if cadr z eq w then <<y := addsq(multsq(!*k2q('wedge . cddr z), lc x),y); x := red x>> else if eqcar(cadr z,'d) then <<y := addsq(simp list('wedge,list('d, list('times,'wedge . cddr z, prepsq lc x))),y); b := addsq(multsq(!*k2q('wedge . w . cddr z),lc x), b); x := red x>> else rederr list("wrong ordering ",z) else if eqcar(z,'partdf) then <<r := reval list('innerprod, list('partdf,caddr z), prepsq lc x); x := addpsf((if cdddr z then !*k2f('partdf . w . cdddr z) else !*k2f w) .* negsq simp list('d,r) .+ nil,red x); b := addsq(multsq(if cdddr z then !*k2q('partdf . w . cdddr z) else !*k2q w,simp r),b)>> else << b := addsq(multsq(simp cadr z,lc x),b); x := red x>>; kord!* := cdr kord!*; bndeq!* := mk!*sq b; return y end; put('vardf,'simpfn,'simpvardf); put('vardf,'rtypefn,'getrtypeor); put('vardf,'partitfn,'partitvardf); symbolic procedure partitvardf u; partitsq!* simpvardf u; symbolic procedure varysq(u,v,w); multpsf(addpsf(varyf(numr u,v,w), multpsf(1 .* u .+ nil,varyf(negf denr u,v,w))), 1 .* (1 ./ denr u) .+ nil); symbolic procedure varyf(u,v,w); if domainp u then nil else addpsf(addpsf(multpsf(1 .* !*p2q lpow u .+ nil, varyf(lc u,v,w)), multpsf(varyp(lpow u,v,w), 1 .* (lc u ./ 1) .+ nil)), varyf(red u,v,w)); symbolic procedure varyp(u,v,w); begin scalar x,z; integer n; n := cdr u; u := car u; if u eq v then z := !*k2f w .* (1 ./ 1) .+ nil else if atomf u then if x := assoc(u,keepl!*) then begin scalar alglist!*; z := varysq(simp0 cdr x,v,w) end else if null atom u and null atom v then if u=v then !*k2f w .* (1 ./ 1) .+ nil else nil else if null atom v then nil else if depends(u,v) then z := !*k2f w .* simp list('partdf,u,v) .+ nil else nil else if sfp u then z := varyf(u,v,w) else if car u eq '!*sq then z := varysq(cadr u,v,w) else if x := get(car u,'dfn) then for each j in for each k in cdr u collect varysq(simp k,v,w) do <<if j then z := addpsf(multpsf(j,1 .* simp subla(pair(caar x,cdr u),cdar x) .+ nil),z); x := cdr x>> else if x := get(car u,'varyfn) then z := apply3(x,cdr u,v,w) else if ndepends(u,v) then z := !*k2f w .* simp list('partdf,u,v) .+ nil else nil; return if n=1 then z else multpsf(1 .* !*t2q((u to (n-1)) .* n) .+ nil,z) end; symbolic procedure varywedge(u,v,w); begin scalar x,y,z; x := list 'wedge; for each j on u do <<y := varysq(simp car j,v,w); if y then z := addpsf(if deg!*form w then !*a2f append(x,prepf ldpf y . cdr j) .* lc y .+ nil else ldpf y .* multsq(1 ./ denr lc y,simp append(x,prepf numr lc y . cdr j)) .+ nil,z); x := append(x,list car j)>>; return z end; put('wedge,'varyfn,'varywedge); symbolic procedure varyexdf(u,v,w); begin scalar x; for each j on varysq(simp car u,v,w) do if j then x := addpsf(!*a2f list('d,mvar ldpf j) .* lc j .+ nil,x); return x end; put('d,'varyfn,'varyexdf); symbolic procedure varyhodge(u,v,w); begin scalar x; for each j on varysq(simp car u,v,w) do if j then x := addpsf(!*a2f list('hodge,mvar ldpf j) .* lc j .+ nil,x); return x end; put('hodge,'varyfn,'varyhodge); symbolic procedure varypartdf(u,v,w); begin scalar x; for each j on varysq(simp car u,v,w) do if j then x := addpsf(!*a2f('partdf . mvar ldpf j . cdr u) .* lc j .+ nil, x); return x end; put('partdf,'varyfn,'varypartdf); symbolic procedure simpnoether u; if indvarpf numr simp0 caddr u then mksq('noether . u,1) else begin scalar x,y; simpvardf list(car u,cadr u); x := simp!* bndeq!*; y := intern compress append(explode '!', explode if atom cadr u then cadr u else caadr u); if null atom cadr u then y := y . cdadr u; y := list(y . list('liedf,caddr u,cadr u)); return addsq(multsq(subf(numr x,y),1 ./ denr x), negsq simp list('innerprod,caddr u,car u)) end; put('noether,'simpfn,'simpnoether); symbolic procedure noetherind u; caddr u; put('noether,'indexfun,'noetherind); put('noether,'rtypefn,'getrtypeor); endmodule; %**********************************************************************; %****** Non-scalar valued forms ******; %**********************************************************************; module indices; % Author: Eberhard Schruefer; fluid '(!*exp !*sub2 alglist!*); global '(!*msg frasc!* mcond!*); symbolic procedure indexeval(u,u1); %toplevel evaluation function for indexed quantities; begin scalar v,x,alglist!*; v := simp!* u; x := subfg!*; subfg!* := nil; %we don't substitute values here, since indexsymmetries can %save us a lot of work; v := quotsq(xpndind partitsq(numr v ./ 1,'indvarpf), xpndind partitsq(denr v ./ 1,'indvarpf)); subfg!* := x; %if there are no free indices, we have already the result; %otherwise indxlet does the further simplification; if numr v and null indvarpf !*t2f lt numr v then v := exc!-mk!*sq2 resimp v else v := prepsqxx v; % We have to convert to prefix here, since we don't have a tag. % This is a big source of inefficency. return v end; symbolic procedure exc!-mk!*sq2 u; %this is taken from matr; begin scalar x; x := !*sub2; %since we need value for each element; u := subs2 u; !*sub2 := x; return mk!*sq u end; symbolic procedure xpndind u; %performs the implied summation over repeated indices; begin scalar x,y; y := nil ./ 1; a: if null u then return y; if null(x := contind ldpf u) then y := addsq(multsq(!*f2q ldpf u,lc u),y) else for each k in mkaindxc x do y := addsq(multsq(subcindices(ldpf u,pair(x,k)),lc u),y); u := red u; go to a end; symbolic procedure subcindices(u,l); %Substitutes dummy indices from a-list l into s.f. u; %discriminates indices from variables; begin scalar alglist!*; return if domainp u then u ./ 1 else addsq(multsq( exptsq(if flagp(car mvar u,'indexvar) then simpindexvar subla(l,mvar u) else simp subindk(l,mvar u),ldeg u), subcindices(lc u,l)), subcindices(red u,l)) end; symbolic procedure subindk(l,u); %Substitutes indices from a-list l into kernel u; %discriminates indices from variables; car u . for each j in cdr u collect if atom j then j else if idp car j and get(car j,'dname) then j else if flagp(car j,'indexvar) then car j . subla(l,cdr j) else subindk(l,j); put('form!-with!-free!-indices,'evfn,'indexeval); put('indexed!-form,'rtypefn,'freeindexchk); put('form!-with!-free!-indices,'setprifn,'indxpri); symbolic procedure freeindexchk u; if u and indxl!* and indxchk u then 'form!-with!-free!-indices else nil; symbolic procedure indvarp u; %typechecking for variables with free indices on prefix forms; null !*nosum and indxl!* and if eqcar(u,'!*sq) then indvarpf numr cadr u or indvarpf denr cadr u else freeindp u; symbolic procedure indvarpf u; %typechecking for free indices in s.f.'s; if domainp u then nil else or(if sfp mvar u then indvarpf mvar u else freeindp mvar u, indvarpf lc u,indvarpf red u); symbolic procedure freeindp u; begin scalar x; return if null u or numberp u then nil else if atom u then nil else if car u eq '!*sq then freeindp prepsq cadr u else if idp car u and get(car u,'dname) then nil else if flagp(car u,'indexvar) then indxchk cdr u else if (x := get(car u,'indexfun)) then freeindp apply1(x,cdr u) else if car u eq 'partdf then if null cddr u then freeindp cadr u else freeindp cadr u or freeindp caddr u else lfreeindp cdr u or freeindp car u end; symbolic procedure lfreeindp u; u and (freeindp car u or lfreeindp cdr u); symbolic procedure indxchk u; %returns t if u contains at least one free index; begin scalar x,y; x := u; y := union(indxl!*,nosuml!*); a: if null x then return nil; if null ((if atom car x then if numberp car x then !*num2id abs car x else car x else if numberp cadar x then !*num2id cadar x else cadar x) memq y) then return t; x := cdr x; go to a end; symbolic procedure indexrange u; <<indxl!* := mkindxl u; nil>>; symbolic procedure nosum u; <<nosuml!* := union(mkindxl u,nosuml!*); nil>>; symbolic procedure renosum u; <<nosuml!* := setdiff(mkindxl u,nosuml!*); nil>>; symbolic procedure mkindxl u; for each j in u collect if numberp j then !*num2id j else j; rlistat('(indexrange nosum renosum)); smacro procedure upindp u; %tests if u is a contravariant index; atom revalind u; symbolic procedure allind u; %returns a list of all unbound indices found in standard form u; allind1(u,nil); symbolic procedure allind1(u,v); if domainp u then v else allind1(red u,allind1(lc u,append(v,allindk mvar u))); symbolic procedure allindk u; begin scalar x; return if atom u then nil else if flagp(car u,'indexvar) then <<for each j in cdr u do if atom(j := revalind j) then if null(j memq indxl!*) then x := j . x else nil else if null(cadr j memq indxl!*) then x := j . x; reverse x>> else if (x := get(car u,'indexfun)) then allindk apply1(x,cdr u) else if car u eq 'partdf then if null cddr u then for each j in allindk cdr u collect lowerind j else append(allindk cadr u, for each j in allindk cddr u collect lowerind j) else append(allindk car u,allindk cdr u) end; symbolic procedure contind u; %returns a list of indices over which summation has to be performed; begin scalar dnlist,uplist; for each j in allind u do if upindp j then uplist := j . uplist else dnlist := cadr j . dnlist; return setdiff(xn(uplist,dnlist),nosuml!*) end; symbolic procedure mkaindxc u; %u is a list of free indices. result is a list of lists of all %possible index combinations; begin scalar r,x; r := list u; for each k in u do if x := getindexr k then r := mappl(x,k,r); return r end; symbolic procedure mappl(u,v,w); if null u then nil else append(subst(car u,v,w),mappl(cdr u,v,w)); symbolic procedure getindexr u; %Kludge to indexclasses; if memq(u,indxl!*) then nil else indxl!*; symbolic procedure flatindxl u; for each j in u collect if atom j then j else cadr j; symbolic procedure indexlet(u,v,ltype,b,rtype); if flagp(car u,'indexvar) then if b then setindexvar(u,v) else begin scalar y,z,msg; msg := !*msg; !*msg := nil; %for now. u := mvar numr simp0 u; %is this right? z := flatindxl cdr u; for each j in if flagp(car u,'antisymmetric) then comb(indxl!*,length z) else mkaindxc z do let2(mvar numr simp0 subla(pair(z,j),u),nil,nil,nil); !*msg := msg; y := get(car u,'ifdegree); z := assoc(length cdr u,y); y := delete(z,y); remprop(car u,'ifdegree); if y then put(car u,'ifdegree,y) else <<remprop(car u,'rtype); remflag(list car u,'indexvar)>> end else if subla(frasc!*,u) neq u then put(car(u := subla(frasc!*,u)),'opmtch, xadd!*((for each j in cdr u collect revalind j) . list(nil . (if mcond!* then mcond!* else t),v,nil), get(car u,'opmtch),b)) else setindexvar(u,v); put('form!-with!-free!-indices,'typeletfn,'indexlet); symbolic procedure setindexvar(u,v); begin scalar r,s,w,x,y,z,z1,alglist!*; x := metricu!* . flagp(car u,'covariant); metricu!* := nil; %index position must not be changed here; if cdr x then remflag(list car u,'covariant); u := simp0 u; if red numr u or (denr u neq 1) then rederr "illegal assignment"; u := numr u; r := cancel(1 ./ lc u); u := mvar u; metricu!* := car x; if cdr x then flag(list car u,'covariant); z1 := allindk u; z := flatindxl z1; if indxl!* and metricu!* then <<z1 := for each j in z1 collect if flagp(car u,'covariant) then if upindp j then <<u := car u . subst(lowerind j,j,cdr u); 'lower . j>> else cadr j else if upindp j then j else <<u := car u . subst(j,cadr j,cdr u); 'raise . cadr j>>; u := car u . for each j in cdr u collect revalind j>> else z1 := z; r := multsq(simp!* v,r); w := for each j in if flagp(car u,'antisymmetric) then comb(indxl!*,length z) else mkaindxc z collect <<x := mkletindxc pair(z1,j); s := nil ./ 1; y := subfg!*; subfg!* := nil; for each k in x do s := addsq(multsq(car k,subfindices(numr r,cdr k)),s); subfg!* := y; y := !*q2f simp0 subla(pair(z,j),u); mvar y . exc!-mk!*sq2 multsq(subf(if minusf y then negf numr s else numr s,nil), invsq subf(multf(denr r,denr s),nil))>>; for each j in w do let2(car j,cdr j,nil,t) end; symbolic procedure mkletindxc u; %u is a list of dotted pairs. Left part is unbound index and action. %Right part is bound index. begin scalar r; integer n; r := list((1 ./ 1) . for each j in u collect if atom car j then car j else cdar j); for each k in u do <<n := n + 1; if atom car k then r := for each j in r collect car j . subindexn(k,n,cdr j) else r := mapletind(if caar k eq 'raise then getupper cdr k else getlower cdr k, cdar k,r,n)>>; return r end; symbolic procedure subindexn(u,n,v); if n=1 then u . cdr v else car v . subindexn(u,n-1,cdr v); symbolic procedure mapletind(u,v,w,n); if null u then nil else append(for each j in w collect multsq(simp!* cdar u,car j) . subindexn(v . caar u,n,cdr j), mapletind(cdr u,v,w,n)); put('form!-with!-free!-indices,'setelemfn,'setindexvar); symbolic procedure clear u; begin rmsubs(); remflag('(t),'reserved); %t is very often used as a coordinate; for each x in u do <<let2(x,nil,nil,nil); let2(x,nil,t,nil); if atom x and get(x,'fdegree) then <<remprop(x,'fdegree); remprop(x,'rtype)>>>>; mcond!* := frasc!* := nil; flag('(t),'reserved) end; symbolic procedure subfindices(u,l); %Substitutes free indices from a-list l into s.f. u; %discriminates indices from variables; begin scalar alglist!*; return if domainp u then u ./ 1 else addsq(multsq(if atom mvar u then !*p2q lpow u else if sfp mvar u then exptsq(subfindices(mvar u,l),ldeg u) else if flagp(car mvar u,'indexvar) then exptsq(simpindexvar subla(l,mvar u),ldeg u) else if car mvar u memq '(wedge d partdf innerprod liedf hodge vardf) then exptsq(simp subindk(l,mvar u),ldeg u) else !*p2q lpow u,subfindices(lc u,l)), subfindices(red u,l)) end; symbolic procedure indxpri1 u; begin scalar metricu,il,dnlist,uplist,r,x,y,z; metricu := metricu!*; metricu!* := nil; il := allind !*t2f lt numr simp0 u; for each j in il do if upindp j then uplist := j . uplist else dnlist := cadr j . dnlist; for each j in xn(uplist,dnlist) do il := delete(j,delete(revalind lowerind j,il)); metricu!* := metricu; y := flatindxl il; r := simp!* u; for each j in mkaindxc y do <<x := pair(y,j); z := exc!-mk!*sq2 multsq(subfindices(numr r,x),1 ./ denr r); maprin list('setq,subla(x,'ns . il),z); if not !*nat then prin2!* "$"; terpri!* t>> end; symbolic procedure indxpri(v,u); begin scalar x,y,z; y := flatindxl allindk v; for each j in if flagp(car v,'antisymmetric) and coposp cdr v then comb(indxl!*,length y) else mkaindxc y do <<x := pair(y,j); z := aeval subla(x,v); maprin list('setq,subla(x,v),z); if not !*nat then prin2!* "$"; terpri!* t>> end; symbolic procedure coposp u; %checks if all indices in list u are either in a covariant or %a contravariant position.; null cdr u or if atom car u then contposp cdr u else covposp cdr u; symbolic procedure contposp u; %checks if all indices in list u are contravariant; null u or (atom car u and contposp cdr u); symbolic procedure covposp u; %checks if all indices in list u are covariant; null u or (null atom car u and covposp cdr u); put('ns,'prifn,'indvarprt); symbolic procedure simpindexvar u; %simplification function for indexed quantities; !*pf2sq partitindexvar u; symbolic procedure partitindexvar u; %partition function for indexed quantities; begin scalar freel,x,y,z,v,sgn,w; x := for each j in cdr u collect (if atom k then if numberp k then if minusp k then lowerind !*num2id abs k else !*num2id k else k else if numberp cadr k then lowerind !*num2id cadr k else k) where k = revalind j; w := deg!*form u; if null metricu!* then go to a; z := x; if null flagp(car u,'covariant) then <<while z and (atom car z or not(cadar z memq indxl!*)) do <<y := car z . y; if null atom car z then freel := cadar z . freel; z := cdr z>>; if z then <<v := nil; y := reverse y; for each j in getlower cadar z do v := addpf(multpfsq(partitindexvar(car u . append(y,car j . cdr z)), simp cdr j),v); return v>>>> else <<while z and (null atom car z or not(car z memq indxl!*)) do <<y := car z . y; if atom car z then freel := car z . freel; z := cdr z>>; if z then <<v := nil; y := reverse y; for each j in getupper car z do v := addpf(multpfsq(partitindexvar(car u . append(y,lowerind car j . cdr z)), simp cdr j),v); return v>>>>; a: if null coposp x or (null flagp(car u,'symmetric) and null flagp(car u,'antisymmetric)) then return if w then mkupf(car u . x) else 1 .* mksq(car u . x,1) .+ nil; x := for each j in x collect if atom j then j else cadr j; if flagp(car u,'symmetric) then x := indordn x else if flagp(car u,'antisymmetric) then <<if repeats x then return nil else if not permp(z := indordn x,x) then sgn := t; x := z>>; if flagp(car u,'covariant) then x := for each j in x collect if j memq freel then j else lowerind j else if null metricu!* and null atom cadr u then x := for each j in x collect lowerind j else x := for each j in x collect if j memq freel then lowerind j else j; return if w then if sgn then negpf mkupf(car u . x) else mkupf(car u . x) else if sgn then 1 .* negsq mksq(car u . x,1) .+ nil else 1 .* mksq(car u . x,1) .+ nil end; symbolic procedure !*num2id u; %converts a numeric index to an id; %if u = 0 then rederr "0 not allowed as index" else if u<10 then intern cdr assoc(u, '((0 . !0) (1 . !1) (2 . !2) (3 . !3) (4 . !4) (5 . !5) (6 . !6) (7 . !7) (8 . !8) (9 . !9))) else intern compress append(explode '!!,explode u); symbolic procedure revalind u; begin scalar x,y,alglist!*; alglist!* := list(0 . (nil . mksq(!*num2id 0,1))); %the above line is used to avoid the simplifaction of -0 to 0. x := subfg!*; subfg!* := nil; y := prepsq simp u; subfg!* := x; return y end; endmodule; %**********************************************************************; %***** Cartan frames ******; %**********************************************************************; module frames; % Author: Eberhard Schruefer; global '(naturalframe2coframe dbaseform2base2form dimex!* indxl!* naturalvector2framevector subfg!* metricd!* metricu!* coord!* cursym!* detm!* commutator!-of!-framevectors); fluid '(alglist!* kord!*); symbolic procedure coframestat; begin scalar framel,metric; flag('(with),'delim); framel := cdr rlis(); remflag('(with),'delim); if cursym!* eq '!*semicol!* then go to a; if scan() eq 'metric then metric := xread t else if cursym!* eq 'signature then metric := rlis() else symerr('coframe,t); a: cofram(framel,metric) end; put('coframe,'stat,'coframestat); %put('cofram,'formfn,'formcofram); symbolic procedure cofram(u,v); begin scalar alglist!*; rmsubs(); u := for each j in u collect if car j eq 'equal then cdr j else list j; putform(caar u,1); basisforml!* := for each j in u collect !*a2k car j; indxl!* := for each j in basisforml!* collect cadr j; dimex!* := length u; basisvectorl!* := nil; if null v then metricd!* := nlist(1,dimex!*) else if car v eq 'signature then metricd!* := for each j in cdr v collect aeval j; if null v or (car v eq 'signature) then <<detm!* := simp car metricd!*; for each j in cdr metricd!* do detm!* := multsq(simp j,detm!*); detm!* := mk!*sq detm!*; metricu!* := metricd!*:= pair(indxl!*,for each j in pair(indxl!*,metricd!*) collect list j)>> else mkmetric v; if flagp('partdf,'noxpnd) then remflag('(partdf),'noxpnd); putform('eps . indxl!*,0); flag('(eps),'antisymmetric); flag('(eps),'covariant); setk('eps . for each j in indxl!* collect lowerind j,1); if null cdar u then return; keepl!* := append(for each j in u collect !*a2k car j . cadr j,keepl!*); coframe1 for each j in u collect cadr j end; symbolic procedure coframe1 u; begin scalar osubfg,coords,v,y,w; osubfg := subfg!*; subfg!* := nil; v := for each j in u collect <<y := partitop j; coords := pickupcoords(y,coords); y>>; if length coords neq dimex!* then rederr "badly formed basis"; w := !*pf2matwrtcoords(v,coords); naturalvector2framevector := v; subfg!* := nil; naturalframe2coframe := pair(coords, for each j in lnrsolve(w,for each k in basisforml!* collect list !*k2q k) collect mk!*sqpf partitsq!* car j); subfg!* := osubfg; coord!* := coords; dbaseform2base2form := pair(basisforml!*, for each j in v collect mk!*sqpf repartit exdfpf j) end; symbolic procedure pickupcoords(u,v); %u is a pf, v a list. Picks up vars in exdf and declares them as %zero forms. if null u then v else if null eqcar(ldpf u,'d) then rederr "badly formed basis" else if null v then <<putform(cadr ldpf u,0); pickupcoords(red u,cadr ldpf u . nil)>> else if ordop(cadr ldpf u,car v) then if cadr ldpf u eq car v then pickupcoords(red u,v) else <<putform(cadr ldpf u,0); pickupcoords(red u,cadr ldpf u . v)>> else pickupcoords(red u,car v . pickupcoords(!*k2pf ldpf u,cdr v)); symbolic procedure !*pf2matwrtcoords(u,v); if null u then nil else !*pf2colwrtcoords(car u,v) . !*pf2matwrtcoords(cdr u,v); symbolic procedure !*pf2colwrtcoords(u,v); if null v then nil else if u and (cadr ldpf u eq car v) then lc u . !*pf2colwrtcoords(red u,cdr v) else (nil ./ 1) . !*pf2colwrtcoords(u,cdr v); symbolic procedure coordp u; u memq coord!*; symbolic procedure mkmetric u; begin scalar x,y,okord; putform(list(cadr u,nil,nil),0); flag(list cadr u,'symmetric); flag(list cadr u,'covariant); okord := kord!*; kord!* := basisforml!*; x := simp!* caddr u; y := indxl!*; metricu!* := t; %to make simpindexvar work; for each j in indxl!* do <<for each k in y do setk(list(cadr u,lowerind j,lowerind k),0); y := cdr y>>; for each j on partitsq(x,'basep) do if ldeg ldpf j = 2 then setk(list(cadr u,lowerind cadr mvar ldpf j, lowerind cadr mvar ldpf j), mk!*sq lc j) else setk(list(cadr u,lowerind cadr mvar ldpf j, lowerind cadr mvar lc ldpf j), mk!*sq multsq(lc j,1 ./ 2)); kord!* := okord; x := for each j in indxl!* collect for each k in indxl!* collect simpindexvar list(cadr u,lowerind j,lowerind k); y := lnrsolve(x,generateident length indxl!*); metricd!* := mkasmetric x; metricu!* := mkasmetric y; detm!* := mk!*sq detq x end; symbolic procedure mkasmetric u; for each j in pair(indxl!*,u) collect car j . begin scalar w,z; w := indxl!*; for each k in cdr j do <<if numr k then z := (car w . mk!*sq k) . z; w := cdr w>>; return z end; symbolic procedure frame u; begin scalar y; putform(list(car u,nil),-1); flag(list car u,'covariant); basisvectorl!* := for each j in indxl!* collect !*a2k list(car u,lowerind j); if null dbaseform2base2form then return; commutator!-of!-framevectors := for each j in pickupwedges dbaseform2base2form collect list(cadadr j,cadadr cdr j) . mk!*sqpf mkcommutatorfv(j, dbaseform2base2form); y := pair(basisvectorl!*, naturalvector2framevector); naturalvector2framevector := for each j in coord!* collect j . mk!*sqpf mknat2framv(j,y) end; symbolic procedure pickupwedges u; pickupwedges1(u,nil); Symbolic procedure pickupwedges1(u,v); if null u then v else if null cdar u then pickupwedges1(cdr u,v) else if null v then pickupwedges1((caar u . red cdar u) . cdr u, ldpf cdar u . nil) else if ldpf cdar u memq v then pickupwedges1(if red cdar u then (caar u . red cdar u) . cdr u else cdr u,v) else pickupwedges1(if red cdar u then (caar u . red cdar u) . cdr u else cdr u,ldpf cdar u . v); symbolic procedure mkbasevector u; !*a2k list(caar basisvectorl!*,lowerind u); symbolic procedure mkcommutatorfv(u,v); if null v then nil else addpf(mkcommutatorfv1(u,mkbasevector cadaar v,cdar v), mkcommutatorfv(u,cdr v)); symbolic procedure mkcommutatorfv1(u,v,w); if null w then nil else if u eq ldpf w then v .* negsq simp!* lc w .+ nil else if ordop(u,ldpf w) then nil else mkcommutatorfv1(u,v,red w); symbolic procedure mknat2framv(u,v); if null v then nil else addpf(mknat2framv1(u,caar v,cdar v),mknat2framv(u,cdr v)); symbolic procedure mknat2framv1(u,v,w); if null w then nil else if u eq cadr ldpf w then v .* lc w .+ nil else if ordop(u,cadr ldpf w) then nil else mknat2framv1(u,v,red w); symbolic procedure dualframe u; rederr "dualframe no longer supported - use frame instead"; symbolic procedure riemannconx u; riemconnection car u; put('riemannconx,'stat,'rlis); smacro procedure mkbasformsq u; mksq(list(caar basisforml!*,u),1); symbolic procedure riemconnection u; %calculates the riemannian connection and stores it in u; begin scalar indx1,indx2,indx3,covbaseform,varl,w,x,z,dgkl; putform(list(u,nil,nil),1); flag(list u,'covariant); flag(list u,'antisymmetric); for each j in indxl!* do for each k in indxl!* do if (j neq k) and indordp(j,k) then setk(list(u,lowerind j,lowerind k),0); for each l in dbaseform2base2form do <<covbaseform := partitindexvar list(caar l, lowerind cadar l); for each j on cdr l do <<varl := cdr ldpf j; indx1 := cadar varl; indx2 := cadadr varl; for each y on covbaseform do <<w := list(u,lowerind indx1,lowerind indx2); z := multsq(-1 ./ 2,!*pf2sq multpfsq(lt y .+ nil, simp!* lc j)); setk(w,mk!*sq addsq(z,mksq(w,1))); indx3 := cadr ldpf y; z := multsq(-1 ./ 2,multsq(lc y,simp!* lc j)); if indx1 neq indx3 then if indordp(indx1,indx3) then <<w := list(u,lowerind indx1,lowerind indx3); setk(w,mk!*sq addsq(multsq(z,mkbasformsq indx2), mksq(w,1)))>> else <<w := list(u,lowerind indx3,lowerind indx1); setk(w,mk!*sq addsq(multsq(negsq z, mkbasformsq indx2),mksq(w,1)))>>; if indx2 neq indx3 then if indordp(indx2,indx3) then <<w := list(u,lowerind indx2,lowerind indx3); setk(w,mk!*sq addsq(multsq(negsq z, mkbasformsq indx1),mksq(w,1)))>> else <<w := list(u,lowerind indx3,lowerind indx2); setk(w,mk!*sq addsq(multsq(z, mkbasformsq indx1),mksq(w,1)))>> >>>>>>; if dgkl := mkmetricconx metricd!* then <<for each j in dgkl do <<for each y on cdr j do <<varl := ldpf y; indx1 := cadar varl; indx2 := cadadr varl; w := list(u,lowerind indx1,lowerind indx2); z := multsq(-1 ./ 2,multsq(!*k2q car j,lc y)); setk(w,mk!*sq addsq(z,mksq(w,1)))>>>>; remflag(list u,'antisymmetric); for each j in indxl!* do for each k in indxl!* do if indordp(j,k) then <<w := list(u,lowerind j,lowerind k); x := if j eq k then nil ./ 1 else mksq(w,1); z := atsoc(j,cdr atsoc(k,metricd!*)); if z then z := exdf0 simp!* cdr z; z := multsq(1 ./ 2,!*pf2sq z); setk(w,mk!*sq addsq(z,x)); w := list(u,lowerind k,lowerind j); setk(w,mk!*sq addsq(z,negsq x))>>>> end; symbolic procedure mkmetricconx u; if null u then nil else (if x then (ldpf mkupf list(caar basisforml!*,caar u) . x) . mkmetricconx cdr u else mkmetricconx cdr u) where x = mkmetricconx1 cdar u; symbolic procedure mkmetricconx1 u; if null u then nil else addpf(wedgepf2(exdf0 simp!* cdar u, !*k2pf list ldpf mkupf list(caar basisforml!*,caar u)), mkmetricconx1 cdr u); symbolic procedure basep u; if domainp u then nil else or(if sfp mvar u then basep mvar u else eqcar(mvar u,caar basisforml!*), basep lc u,basep red u); symbolic procedure wedgefp u; if domainp u then nil else or(if sfp mvar u then wedgefp mvar u else eqcar(mvar u,'wedge), wedgefp lc u,wedgefp red u); endmodule; %**********************************************************************; %********** Auxiliary functions ************; %**********************************************************************; module aux; % Author: Eberhard Schruefer; symbolic procedure boundindp(u,v); if null u then t else member(car u,v) and boundindp(cdr u,v); symbolic procedure memblp(u,v); if null u then nil else if atom u then member(u,v) else memblp(car u,v) or memblp(cdr u,v); symbolic procedure displayframe; begin scalar x,coords; terpri!* t; coords := coord!*; coord!* := nil; for each j in basisforml!* do <<x := assoc(j,keepl!*); maprin car x; prin2!* " = "; maprin reval cdr x; terpri!* t>>; %was varpri(reval cdr x,list mkquote car x,t)>>; if !*nat then terpri!* t; coord!* := coords end; put('displayframe,'stat,'endstat); %symbolic procedure form!*coeff u; %begin scalar x,inds; %integer n; %inds:=cdr u; %n:=length inds; %x:=simp!* car u; %y:=dstrsdf numr x; %put('fcoeff,'simpfn,'form!*coeff); endmodule; %*********************************************************************; % Lie-Algebra valued forms ; %*********************************************************************; module lievalform; % Author: Eberhard Schruefer symbolic procedure liebrackstat; begin scalar x; x := xread nil; scan(); return 'lie . cdr x end; flag(list '!},'delim); %Since Liebrackets can be nested we can't %remove the flag in the stat proc; put('!{,'stat,'liebrackstat); %We'd rather liked to use squarebrackets; %but they are not available on most terminals; put('lie,'prifn,'lieprn); symbolic procedure lieprn u; <<prin2!* "{"; inprint('!*comma!*,0,u); prin2!* "}">>; endmodule; %********************************************************************; %**** Exterior Ideals *****; %********************************************************************; module idexf; % Author: Eberhard Schruefer global '(exfideal!*); symbolic procedure exterior!-ideal u; begin scalar x,y; rmsubs(); for each j in u do if indexvp j then for each k in mkaindxc(y := flatindxl cdr j) do x := partitsq(simpindexvar(car j . subla(pair(y,k),cdr j)), 'wedgefp) . x else x := partitsq(simp!* j,'wedgefp) . x; exfideal!* := append(x,exfideal!*); end; rlistat '(exterior!-ideal); symbolic procedure remexf(u,v); begin scalar lu,lv,x,y,z; lv := ldpf v; a: if null u or domainp(lu := ldpf u) then return u; if x := divexf(lu,lv) then <<y := partitsq(simp list('wedge,prepf v,x),'wedgefp); z := negsq quotsq(lc u,lc y); u := addpsf(u,multpsf(1 .* z .+ nil,y))>> else return u; go to a end; symbolic procedure divexf(u,v); begin scalar x,y; x := prepf u; y := prepf v; if atom x then x := list x else if car x eq 'wedge then x := cdr x; if atom y then y := list y else if car y eq 'wedge then y := cdr y; a: if null y then return 'wedge . x; if null(x := delform(car y,x)) then return nil; y := cdr y; go to a end; symbolic procedure delform(u,v); delform1(u,v,nil); symbolic procedure delform1(u,v,w); if null v then nil else if u = car v then if w or cdr v then append(reverse w,cdr v) else list 1 else delform1(u,cdr v,car v . w); symbolic procedure exf!-mod!-ideal u; begin for each j in exfideal!* do u := remexf(u,j); return u end; endmodule; %*********************************************************************; % 3-d Vectoranalysis Interface ; %*********************************************************************; module vectoranalys; %author: Eberhard Schruefer; symbolic procedure basis u; cofram(for each j in u collect cdr j,nil); rlistat '(basis); symbolic procedure simpgrad u; simp!*('d . u); put('grad,'simpfn,'simpgrad); symbolic procedure simpcurl u; simp!* list('hodge,'d . u); put('curl,'simpfn,'simpcurl); symbolic procedure simpdiv u; simp!* list('hodge,list('d,'hodge . u)); put('div,'simpfn,'simpdiv); newtok '((!. !* !.) crossprod); infix crossprod; symbolic procedure simpcrossprod u; simp!* list('hodge,'wedge . u); put('crossprod,'simpfn,'simpcrossprod); symbolic procedure simpdotprod u; simp!* list('hodge,list('wedge,car u,list('hodge,cadr u))); put('cons,'simpfn,'simpdotprod); symbolic procedure hodge3dpri u; %converts the form notation to vector notation for output; if caar u eq 'd then if eqcar(cadar u,'hodge) then maprin('div . cdadar u) else maprin('curl . cdar u) else if caar u eq 'wedge then if eqcar(cadar u,'hodge) then inprint('cons,0,cdadar u) else inprint('crossprod,0,cdar u); endmodule; end; |
Added r33/ezgcd.red version [16eb2cc935].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 | module fac!-intro; % Support for factorizer. % Authors: A. C. Norman and P. M. A. Moore, 1981. fluid '(!*timings !*trallfac !*trfac factor!-level factor!-trace!-list); global '(!*ifactor posn!* spare!*); switch ifactor,overview,timings,trallfac,trfac; factor!-level:=0; % start with a numeric value; comment This factorizer should be used with a system dependent file containing a setting of the variable LARGEST!-SMALL!-MODULUS. If at all possible the integer arithmetic operations used here should be mapped onto corresponding ones available in the underlying Lisp implementation, and the support for modular arithmetic (perhaps based on these integer arithmetic operations) should be reviewed. This file provides placeholder definitions of functions that are used on some implementations to support block compilation, car/cdr access checks and the like. The front-end files on the systems that can use these features will disable the definitions given here by use of a 'LOSE flag; deflist('((minus!-one -1)),'newnam); %so that it EVALs properly; symbolic smacro procedure carcheck u; nil; symbolic procedure errorf u; rederr list("Factorizer error:",u); symbolic smacro procedure factor!-trace action; begin scalar stream; if !*trallfac or (!*trfac and factor!-level = 1) then stream := nil . nil else stream := assoc(factor!-level,factor!-trace!-list); if stream then << stream:=wrs cdr stream; action; wrs stream >> end; symbolic smacro procedure irecip u; 1/u; symbolic smacro procedure isdomain u; domainp u; symbolic smacro procedure readgctime; gctime(); symbolic smacro procedure readtime; time()-gctime(); symbolic smacro procedure ttab n; spaces(n-posn()); % ***** The remainder of this module used to be in FLUIDS. % Macro definitions for functions that create and access reduce-type % datastructures. smacro procedure tvar a; caar a; smacro procedure polyzerop u; null u; smacro procedure didntgo q; null q; smacro procedure depends!-on!-var(a,v); (lambda !#!#a; (not domainp !#!#a) and (mvar !#!#a=v)) a; smacro procedure l!-numeric!-c(a,vlist); lnc a; % Macro definitions for use in berlekamps algorithm. % SMACROs used in linear equation package. smacro procedure getm2(a,i,j); % Store by rows, to ease pivoting process. getv(getv(a,i),j); smacro procedure putm2(a,i,j,v); putv(getv(a,i),j,v); %%%smacro procedure !*d2n a; %%%% converts domain elt into number. %%% (lambda !#a!#; %%% if null !#a!# then 0 else !#a!#) a; symbolic procedure !*d2n a; if null a then 0 else a; smacro procedure !*num2f n; % converts number to s.f. (lambda !#n!#; if !#n!#=0 then nil else !#n!#) n; smacro procedure !*mod2f u; u; smacro procedure !*f2mod u; u; smacro procedure comes!-before(p1,p2); % Similar to the REDUCE function ORDPP, but does not cater for % non-commutative terms and assumes that exponents are small integers. (car p1=car p2 and igreaterp(cdr p1,cdr p2)) or (not car p1=car p2 and ordop(car p1,car p2)); %%%smacro procedure adjoin!-term (p,c,r); %%% (lambda !#c!#; % Lambda binding prevents repeated evaluation of C. %%% if null !#c!# then r else (p .* !#c!#) .+ r) c; symbolic procedure adjoin!-term (p,c,r); if null c then r else (p .* c) .+ r; % A load of access smacros for image sets follow: smacro procedure get!-image!-set s; car s; smacro procedure get!-chosen!-prime s; cadr s; smacro procedure get!-image!-lc s; caddr s; smacro procedure get!-image!-mod!-p s; cadr cddr s; smacro procedure get!-image!-content s; cadr cdr cddr s; smacro procedure get!-image!-poly s; cadr cddr cddr s; smacro procedure get!-f!-numvec s; cadr cddr cdddr s; smacro procedure put!-image!-poly!-and!-content(s,imcont,impol); list(get!-image!-set s, get!-chosen!-prime s, get!-image!-lc s, get!-image!-mod!-p s, imcont, impol, get!-f!-numvec s); % !*timings:=nil; % Default not to displaying timings. % !*overshoot:=nil; % Default not to show overshoot occurring. % reconstructing!-gcd:=nil; % This is primarily a factorizer! symbolic procedure ttab!* n; <<if n>(linelength nil - spare!*) then n:=0; if posn!* > n then terpri!*(nil); while not(posn!*=n) do prin2!* '! >>; smacro procedure printstr l; << prin2!* l; terpri!*(nil) >>; smacro procedure printvar v; printstr v; smacro procedure prinvar v; prin2!* v; symbolic procedure printvec(str1,n,str2,v); << for i:=1:n do << prin2!* str1; prin2!* i; prin2!* str2; printsf getv(v,i) >>; terpri!*(nil) >>; smacro procedure display!-time(str,mt); % Displays the string str followed by time mt (millisecs). << prin2 str; prin2 mt; printc " millisecs." >>; % trace control package. smacro procedure trace!-time action; if !*timings then action; smacro procedure new!-level(n,c); (lambda factor!-level; c) n; symbolic procedure set!-trace!-factor(n,file); factor!-trace!-list:=(n . (if file=nil then nil else open(mkfil file,'output))) . factor!-trace!-list; symbolic procedure clear!-trace!-factor n; begin scalar w; w := assoc(n,factor!-trace!-list); if w then << if cdr w then close cdr w; factor!-trace!-list:=delasc(n,factor!-trace!-list) >>; return nil end; symbolic procedure close!-trace!-files(); << while factor!-trace!-list do clear!-trace!-factor(caar factor!-trace!-list); nil >>; endmodule; module alphas; % Authors: A. C. Norman and P. M. A. Moore, 1981; fluid '(alphalist current!-modulus hensel!-growth!-size number!-of!-factors); %********************************************************************; % % this section contains access and update functions for the alphas; symbolic procedure get!-alpha poly; % gets the poly and its associated alpha from the current alphalist % if poly is not on the alphalist then we force an error; begin scalar w; w:=assoc!-alpha(poly,alphalist); if null w then errorf list("Alpha not found for ",poly," in ", alphalist); return w end; symbolic procedure divide!-all!-alphas n; % multiply the factors by n mod p and alter the alphas accordingly; begin scalar om,m; om:=set!-modulus hensel!-growth!-size; m:=modular!-expt( modular!-reciprocal modular!-number n, number!-of!-factors #- 1); alphalist:=for each a in alphalist collect (times!-mod!-p(n,car a) . times!-mod!-p(m,cdr a)); set!-modulus om end; symbolic procedure multiply!-alphas(n,oldpoly,newpoly); % multiply all the alphas except the one associated with oldpoly % by n mod p. also replace oldpoly by newpoly in the alphalist; begin scalar om,faca; om:=set!-modulus hensel!-growth!-size; n:=modular!-number n; oldpoly:=reduce!-mod!-p oldpoly; faca:=get!-alpha oldpoly; alphalist:=delete(faca,alphalist); alphalist:=for each a in alphalist collect car a . times!-mod!-p(cdr a,n); alphalist:=(reduce!-mod!-p newpoly . cdr faca) . alphalist; set!-modulus om end; symbolic procedure multiply!-alphas!-recip(n,oldpoly,newpoly); % multiply all the alphas except the one associated with oldpoly % by the reciprocal mod p of n. also replace oldpoly by newpoly; begin scalar om,w; om:=set!-modulus hensel!-growth!-size; n:=modular!-reciprocal modular!-number n; w:=multiply!-alphas(n,oldpoly,newpoly); set!-modulus om; return w end; endmodule; module coeffts; % Authors: A. C. Norman and P. M. A. Moore, 1981; fluid '(!*timings !*trfac alphalist best!-known!-factor!-list best!-known!-factors coefft!-vectors deg!-of!-unknown difference!-for!-unknown divisor!-for!-unknown factor!-level factor!-trace!-list full!-gcd hensel!-growth!-size image!-factors m!-image!-variable multivariate!-factors multivariate!-input!-poly non!-monic number!-of!-factors polyzero reconstructing!-gcd true!-leading!-coeffts unknown unknowns!-list); %**********************************************************************; % code for trying to determine more multivariate coefficients % by inspection before using multivariate hensel construction. ; symbolic procedure determine!-more!-coeffts(); % ...; begin scalar unknowns!-list,uv,r,w,best!-known!-factor!-list; best!-known!-factors:=mkvect number!-of!-factors; uv:=mkvect number!-of!-factors; for i:=number!-of!-factors step -1 until 1 do putv(uv,i,convert!-factor!-to!-termvector( getv(image!-factors,i),getv(true!-leading!-coeffts,i))); r:=red multivariate!-input!-poly; % we know all about the leading coeffts; if not depends!-on!-var(r,m!-image!-variable) or null(w:=try!-first!-coefft( ldeg r,lc r,unknowns!-list,uv)) then << for i:=1:number!-of!-factors do putv(best!-known!-factors,i,force!-lc( getv(image!-factors,i),getv(true!-leading!-coeffts,i))); coefft!-vectors:=uv; return nil >>; factor!-trace << printstr "By exploiting any sparsity wrt the main variable in the"; printstr "factors, we can try guessing some of the multivariate"; printstr "coefficients." >>; try!-other!-coeffts(r,unknowns!-list,uv); w:=convert!-and!-trial!-divide uv; trace!-time if full!-gcd then printc "Possible gcd found" else printc "Have found some coefficients"; return set!-up!-globals(uv,w) end; symbolic procedure convert!-factor!-to!-termvector(u,tlc); % ...; begin scalar termlist,res,n,slist; termlist:=(ldeg u . tlc) . list!-terms!-in!-factor red u; res:=mkvect (n:=length termlist); for i:=1:n do << slist:=(caar termlist . i) . slist; putv(res,i,car termlist); termlist:=cdr termlist >>; putv(res,0,(n . (n #- 1))); unknowns!-list:=(reversewoc slist) . unknowns!-list; return res end; symbolic procedure try!-first!-coefft(n,c,slist,uv); % ...; begin scalar combns,unknown,w,l,d,v,m; combns:=get!-term(n,slist); if (combns='no) or not null cdr combns then return nil; l:=car combns; for i:=1:number!-of!-factors do << w:=getv(getv(uv,i),car l); % degree . coefft ; if null cdr w then << if unknown then <<c := nil; i := number!-of!-factors + 1>> else <<unknown := i . car l; d := car w>>>> else << c:=quotf(c,cdr w); if didntgo c then i := number!-of!-factors+1>>; l:=cdr l >>; if didntgo c then return nil; putv(v:=getv(uv,car unknown),cdr unknown,(d . c)); m:=getv(v,0); putv(v,0,(car m . (cdr m #- 1))); if cdr m = 1 and factors!-complete uv then return 'complete; return c end; symbolic procedure solve!-next!-coefft(n,c,slist,uv); % ...; begin scalar combns,w,unknown,deg!-of!-unknown,divisor!-for!-unknown, difference!-for!-unknown,v; difference!-for!-unknown:=polyzero; divisor!-for!-unknown:=polyzero; combns:=get!-term(n,slist); if combns='no then return 'nogood; while combns do << w:=split!-term!-list(car combns,uv); if w='nogood then combns := nil else combns:=cdr combns >>; if w='nogood then return w; if null unknown then return; w:=quotf(addf(c,negf difference!-for!-unknown), divisor!-for!-unknown); if didntgo w then return 'nogood; putv(v:=getv(uv,car unknown),cdr unknown,(deg!-of!-unknown . w)); n:=getv(v,0); putv(v,0,(car n . (cdr n #- 1))); if cdr n = 1 and factors!-complete uv then return 'complete; return w end; symbolic procedure split!-term!-list(term!-combn,uv); % ...; begin scalar a,v,w; a:=1; for i:=1:number!-of!-factors do << w:=getv(getv(uv,i),car term!-combn); % degree . coefft ; if null cdr w then if v or (unknown and not((i.car term!-combn)=unknown)) then <<v:='nogood; i := number!-of!-factors+1>> else << unknown:=(i . car term!-combn); deg!-of!-unknown:=car w; v:=unknown >> else a:=multf(a,cdr w); if not(v eq 'nogood) then term!-combn:=cdr term!-combn >>; if v='nogood then return v; if v then divisor!-for!-unknown:=addf(divisor!-for!-unknown,a) else difference!-for!-unknown:=addf(difference!-for!-unknown,a); return 'ok end; symbolic procedure factors!-complete uv; % ...; begin scalar factor!-not!-done,r; r:=t; for i:=1:number!-of!-factors do if not(cdr getv(getv(uv,i),0)=0) then if factor!-not!-done then <<r:=nil; i:=number!-of!-factors+1>> else factor!-not!-done:=t; return r end; symbolic procedure convert!-and!-trial!-divide uv; % ...; begin scalar w,r,fdone!-product!-mod!-p,om; om:=set!-modulus hensel!-growth!-size; fdone!-product!-mod!-p:=1; for i:=1:number!-of!-factors do << w:=getv(uv,i); w:= if (cdr getv(w,0))=0 then termvector2sf w else merge!-terms(getv(image!-factors,i),w); r:=quotf(multivariate!-input!-poly,w); if didntgo r then best!-known!-factor!-list:= ((i . w) . best!-known!-factor!-list) else if reconstructing!-gcd and i=1 then <<full!-gcd:=if non!-monic then car primitive!.parts( list w,m!-image!-variable,nil) else w; i := number!-of!-factors+1>> else << multivariate!-factors:=w . multivariate!-factors; fdone!-product!-mod!-p:=times!-mod!-p( reduce!-mod!-p getv(image!-factors,i), fdone!-product!-mod!-p); multivariate!-input!-poly:=r >> >>; if full!-gcd then return; if null best!-known!-factor!-list then multivariate!-factors:= primitive!.parts(multivariate!-factors,m!-image!-variable,nil) else if null cdr best!-known!-factor!-list then << if reconstructing!-gcd then if not(caar best!-known!-factor!-list=1) then errorf("gcd is jiggered in determining other coeffts") else full!-gcd:=if non!-monic then car primitive!.parts( list multivariate!-input!-poly, m!-image!-variable,nil) else multivariate!-input!-poly else multivariate!-factors:=primitive!.parts( multivariate!-input!-poly . multivariate!-factors, m!-image!-variable,nil); best!-known!-factor!-list:=nil >>; factor!-trace << if null best!-known!-factor!-list then printstr "We have completely determined all the factors this way" else if multivariate!-factors then << prin2!* "We have completely determined the following factor"; printstr if (length multivariate!-factors)=1 then ":" else "s:"; for each ww in multivariate!-factors do printsf ww >> >>; set!-modulus om; return fdone!-product!-mod!-p end; symbolic procedure set!-up!-globals(uv,f!-product); if null best!-known!-factor!-list or full!-gcd then 'done else begin scalar i,r,n,k,flist!-mod!-p,imf,om,savek; n:=length best!-known!-factor!-list; best!-known!-factors:=mkvect n; coefft!-vectors:=mkvect n; r:=mkvect n; k:=if reconstructing!-gcd then 1 else 0; om:=set!-modulus hensel!-growth!-size; for each w in best!-known!-factor!-list do << i:=car w; w:=cdr w; if reconstructing!-gcd and i=1 then << savek:=k; k:=1 >> else k:=k #+ 1; % in case we are reconstructing gcd we had better know % which is the gcd and which the cofactor - so don't move % move the gcd from elt one; putv(r,k,imf:=getv(image!-factors,i)); flist!-mod!-p:=(reduce!-mod!-p imf) . flist!-mod!-p; putv(best!-known!-factors,k,w); putv(coefft!-vectors,k,getv(uv,i)); if reconstructing!-gcd and k=1 then k:=savek; % restore k if necessary; >>; if not(n=number!-of!-factors) then << alphalist:=for each modf in flist!-mod!-p collect (modf . remainder!-mod!-p(times!-mod!-p(f!-product, cdr get!-alpha modf),modf)); number!-of!-factors:=n >>; set!-modulus om; image!-factors:=r; return 'need! to! reconstruct end; symbolic procedure get!-term(n,l); % ...; if n#<0 then 'no else if null cdr l then get!-term!-n(n,car l) else begin scalar w,res; for each fterm in car l do << w:=get!-term(n#-car fterm,cdr l); if not(w='no) then res:= append(for each v in w collect (cdr fterm . v),res) >>; return if null res then 'no else res end; symbolic procedure get!-term!-n(n,u); if null u or n #> caar u then 'no else if caar u = n then list(cdar u . nil) else get!-term!-n(n,cdr u); endmodule; module ezgcdf; % Polynomial GCD algorithms. % Author: A. C. Norman, 1981; fluid '(!*exp !*gcd !*heugcd !*overview !*timings !*trfac alphalist bad!-case best!-known!-factors current!-modulus dmode!* factor!-level factor!-trace!-list full!-gcd hensel!-growth!-size image!-factors image!-set irreducible kord!* m!-image!-variable multivariate!-factors multivariate!-input!-poly non!-monic no!-of!-primes!-to!-try number!-of!-factors prime!-base reconstructing!-gcd reduced!-degree!-lclst reduction!-count target!-factor!-count true!-leading!-coeffts unlucky!-case); symbolic procedure ezgcdf(u,v); %entry point for REDUCE call in GCDF; begin scalar factor!-level; factor!-level := 0; return poly!-abs gcdlist list(u,v) end; %symbolic procedure simpezgcd u; % calculate the gcd of the polynomials given as arguments; % begin % scalar factor!-level,w; % factor!-level:=0; % u := for each p in u collect << % w := simp!* p; % if (denr w neq 1) then % rederr "EZGCD requires polynomial arguments"; % numr w >>; % return (poly!-abs gcdlist u) ./ 1 % end; %put('ezgcd,'simpfn,'simpezgcd); symbolic procedure simpnprimitive p; % Remove any simple numeric factors from the expression P; begin scalar np,dp; if atom p or not atom cdr p then rederr "NPRIMITIVE requires just one argument"; p := simp!* car p; if polyzerop(numr p) then return nil ./ 1; np := quotfail(numr p,numeric!-content numr p); dp := quotfail(denr p,numeric!-content denr p); return (np ./ dp) end; put('nprimitive,'simpfn,'simpnprimitive); symbolic procedure poly!-gcd(u,v); %U and V are standard forms. %Value is the gcd of U and V; begin scalar xexp,z; if polyzerop u then return poly!-abs v else if polyzerop v then return poly!-abs u else if u=1 or v=1 then return 1; xexp := !*exp; !*exp := t; % The case of one argument exactly dividing the other is % detected specially here because it is perhaps a fairly % common circumstance; if quotf1(u,v) then z := v else if quotf1(v,u) then z := u else if !*gcd then z := gcdlist list(u,v) else z := 1; !*exp := xexp; return poly!-abs z end; % moved('gcdf,'poly!-gcd); symbolic procedure ezgcd!-comfac p; %P is a standard form %CAR of result is lowest common power of leading kernel in %every term in P (or NIL). CDR is gcd of all coefficients of %powers of leading kernel; if domainp p then nil . poly!-abs p else if null red p then lpow p . poly!-abs lc p else begin scalar power,coeflist,var; % POWER will be the first part of the answer returned, % COEFLIST will collect a list of all coefs in the polynomial % P viewed as a poly in its main variable, % VAR is the main variable concerned; var := mvar p; while mvar p=var and not domainp red p do << coeflist := lc p . coeflist; p:=red p >>; if mvar p=var then << coeflist := lc p . coeflist; if null red p then power := lpow p else coeflist := red p . coeflist >> else coeflist := p . coeflist; return power . gcdlist coeflist end; symbolic procedure gcd!-with!-number(n,a); % n is a number, a is a polynomial - return their gcd, given that % n is non-zero; if n=1 or not atom n or flagp(dmode!*,'field) then 1 else if domainp a then if a=nil then abs n else if not atom a then 1 else gcddd(n,a) else gcd!-with!-number(gcd!-with!-number(n,lc a),red a); % moved('gcdfd,'gcd!-with!-number); symbolic procedure contents!-with!-respect!-to(p,v); if domainp p then nil . poly!-abs p else if mvar p=v then ezgcd!-comfac p else begin scalar y,w; y := setkorder list v; p := reorder p; w := ezgcd!-comfac p; setkorder y; p := reorder p; return reorder w end; symbolic procedure numeric!-content form; % Find numeric content of non-zero polynomial; if domainp form then abs form else if null red form then numeric!-content lc form else begin scalar g1; g1 := numeric!-content lc form; if not (g1=1) then g1 := gcddd(g1,numeric!-content red form); return g1 end; symbolic procedure gcdlist l; % Return the GCD of all the polynomials in the list L. % % First find all variables mentioned in the polynomials in L, % and remove monomial content from them all. If in the process % a constant poly is found, take special action. If then there % is some variable that is mentioned in all the polys in L, and % which occurs only linearly in one of them establish that as % main variable and proceed to GCDLIST3 (which will take % a special case exit). Otherwise, if there are any variables that % do not occur in all the polys in L they can not occur in the GCD, % so take coefficients with respect to them to get a longer list of % smaller polynomials - restart. Finally we have a set of polys % all involving exactly the same set of variables; if null l then nil else if null cdr l then poly!-abs car l else if domainp car l then gcdld(cdr l,car l) else begin scalar l1,gcont,x; % Copy L to L1, but on the way detect any domain elements % and deal with them specially; while not null l do << if null car l then l := cdr l else if domainp car l then << l1 := list list gcdld(cdr l,gcdld(mapcarcar l1,car l)); l := nil >> else << l1 := (car l . powers1 car l) . l1; l := cdr l >> >>; if null l1 then return nil else if null cdr l1 then return poly!-abs caar l1; % Now L1 is a list where each polynomial is paired with information % about the powers of variables in it; gcont := nil; % Compute monomial content on things in L; x := nil; % First time round flag; l := for each p in l1 collect begin scalar gcont1,gcont2,w; % Set GCONT1 to least power information, and W to power % difference; w := for each y in cdr p collect << gcont1 := (car y . cddr y) . gcont1; car y . (cadr y-cddr y) >>; % Now get the monomial content as a standard form (in GCONT2); gcont2 := numeric!-content car p; if null x then << gcont := gcont1; x := gcont2 >> else << gcont := vintersection(gcont,gcont1); % Accumulate monomial gcd; x := gcddd(x,gcont2) >>; for each q in gcont1 do if not cdr q=0 then gcont2 := multf(gcont2,!*p2f mksp(car q,cdr q)); return quotfail1(car p,gcont2,"Term content division failed") . w end; % Here X is the numeric part of the final GCD; for each q in gcont do x := multf(x,!*p2f mksp(car q,cdr q)); trace!-time << prin2!* "Term gcd = "; printsf x >>; return poly!-abs multf(x,gcdlist1 l) end; symbolic procedure gcdlist1 l; % Items in L are monomial-primitive, and paired with power information. % Find out what variables are common to all polynomials in L and % remove all others; begin scalar unionv,intersectionv,vord,x,l1,reduction!-count; unionv := intersectionv := cdar l; for each p in cdr l do << unionv := vunion(unionv,cdr p); intersectionv := vintersection(intersectionv,cdr p) >>; if null intersectionv then return 1; for each v in intersectionv do unionv := vdelete(v,unionv); % Now UNIONV is list of those variables mentioned that % are not common to all polynomials; intersectionv := sort(intersectionv,function lesspcdr); if cdar intersectionv=1 then << % I have found something that is linear in one of its variables; vord := mapcarcar append(intersectionv,unionv); l1 := setkorder vord; trace!-time << prin2 "Selecting "; prin2 caar intersectionv; printc " as main because some poly is linear in it" >>; x := gcdlist3(for each p in l collect reorder car p,nil,vord); setkorder l1; return reorder x >> else if null unionv then return gcdlist2(l,intersectionv); trace!-time << prin2 "The variables "; prin2 unionv; printc " can be removed" >>; vord := setkorder mapcarcar append(unionv,intersectionv); l1 := nil; for each p in l do l1:=split!-wrt!-variables(reorder car p,mapcarcar unionv,l1); setkorder vord; return gcdlist1(for each p in l1 collect (reorder p . total!-degree!-in!-powers(p,nil))) end; symbolic procedure gcdlist2(l,vars); % Here all the variables in VARS are used in every polynomial % in L. Select a good variable ordering; begin scalar x,x1,gg,lmodp,onestep,vord,oldmod,image!-set,gcdpow, unlucky!-case; % In the univariate case I do not need to think very hard about % the selection of a main variable!! ; if null cdr vars then return if !*heugcd then if (x:=heu!-gcd!-list(mapcarcar l)) then x else gcdlist3(mapcarcar l,nil,list caar vars) else gcdlist3(mapcarcar l,nil,list caar vars); oldmod := set!-modulus nil; % If some variable appears at most to degree two in some pair of the % polynomials then that will do as a main variable. Note that this is % not so useful if the two polynomials happen to be duplicates of each % other, but still... ; vars := mapcarcar sort(vars,function greaterpcdr); % Vars is now arranged with the variable that appears to highest % degree anywhere in L first, and the rest in descending order; l := for each p in l collect car p . sort(cdr p,function lesspcdr); l := sort(l,function lesspcdadr); % Each list of degree information in L is sorted with lowest degree % vars first, and the polynomial with the lowest degree variable % of all will come first; x := intersection(deg2vars(cdar l),deg2vars(cdadr l)); if not null x then << trace!-time << prin2 "Two inputs are at worst quadratic in "; printc car x >>; go to x!-to!-top >>; % Here I have found two polys with a common % variable that they are quadratic in; % Now generate modular images of the gcd to guess its degree wrt % all possible variables; % If either (a) modular gcd=1 or (b) modular gcd can be computed with % just 1 reduction step, use that information to choose a main variable; try!-again: % Modular images may be degenerate; set!-modulus random!-prime(); unlucky!-case := nil; image!-set := for each v in vars collect (v . modular!-number next!-random!-number()); trace!-time << prin2 "Select variable ordering using P="; prin2 current!-modulus; prin2 " and substitutions from "; printc image!-set >>; x1 := vars; try!-vars: if null x1 then go to images!-tried; lmodp := for each p in l collect make!-image!-mod!-p(car p,car x1); if unlucky!-case then go to try!-again; lmodp := sort(lmodp,function lesspdeg); gg := gcdlist!-mod!-p(car lmodp,cdr lmodp); if domainp gg or (reduction!-count<2 and (onestep:=t)) then << trace!-time << prin2 "Select "; printc car x1 >>; x := list car x1; go to x!-to!-top >>; gcdpow := (car x1 . ldeg gg) . gcdpow; x1 := cdr x1; go to try!-vars; images!-tried: % In default of anything better to do, use image variable such that % degree of gcd wrt it is as large as possible; vord := mapcarcar sort(gcdpow,function greaterpcdr); trace!-time << prin2 "Select order by degrees: "; printc gcdpow >>; go to order!-chosen; x!-to!-top: for each v in x do vars := delete(v,vars); vord := append(x,vars); order!-chosen: trace!-time << prin2 "Selected Var order = "; printc vord >>; set!-modulus oldmod; vars := setkorder vord; x := gcdlist3(for each p in l collect reorder car p,onestep,vord); setkorder vars; return reorder x end; symbolic procedure gcdlist!-mod!-p(gg,l); if null l then gg else if gg=1 then 1 else gcdlist!-mod!-p(gcd!-mod!-p(gg,car l),cdr l); symbolic procedure deg2vars l; if null l then nil else if cdar l>2 then nil else caar l . deg2vars cdr l; symbolic procedure vdelete(a,b); if null b then nil else if car a=caar b then cdr b else car b . vdelete(a,cdr b); symbolic procedure intersection(u,v); if null u then nil else if member(car u,v) then car u . intersection(cdr u,v) else intersection(cdr u,v); symbolic procedure vintersection(a,b); begin scalar c; return if null a then nil else if null (c:=assoc(caar a,b)) then vintersection(cdr a,b) else if cdar a>cdr c then if cdr c=0 then vintersection(cdr a,b) else c . vintersection(cdr a,b) else if cdar a=0 then vintersection(cdr a,b) else car a . vintersection(cdr a,b) end; symbolic procedure vunion(a,b); begin scalar c; return if null a then b else if null (c:=assoc(caar a,b)) then car a . vunion(cdr a,b) else if cdar a>cdr c then car a . vunion(cdr a,delete(c,b)) else c . vunion(cdr a,delete(c,b)) end; symbolic procedure mapcarcar l; for each x in l collect car x; symbolic procedure gcdld(l,n); % GCD of the domain element N and all the polys in L; if n=1 or n=-1 then 1 else if l=nil then abs n else if car l=nil then gcdld(cdr l,n) else gcdld(cdr l,gcd!-with!-number(n,car l)); symbolic procedure split!-wrt!-variables(p,vl,l); % Push all the coeffs in P wrt variables in VL onto the list L % Stop if 1 is found as a coeff; if p=nil then l else if not null l and car l=1 then l else if domainp p then abs p . l else if member(mvar p,vl) then split!-wrt!-variables(red p,vl,split!-wrt!-variables(lc p,vl,l)) else p . l; symbolic procedure gcdlist3(l,onestep,vlist); % GCD of the nontrivial polys in the list L given that they all % involve all the variables that any of them mention, % and they are all monomial-primitive. % ONESTEP is true if it is predicted that only one PRS step % will be needed to compute the gcd - if so try that PRS step; begin scalar unlucky!-case,image!-set,gg,gcont,l1,w, reduced!-degree!-lclst,p1,p2; % Make all the polys primitive; l1:=for each p in l collect p . ezgcd!-comfac p; l:=for each c in l1 collect quotfail1(car c,comfac!-to!-poly cdr c, "Content divison in GCDLIST3 failed"); % All polys in L are now primitive; % Because all polys were monomial-primitive, there should % be no power of V to go in the result; gcont:=gcdlist for each c in l1 collect cddr c; if domainp gcont then if not gcont=1 then errorf "GCONT has numeric part"; % GCD of contents complete now; % Now I will remove duplicates from the list; trace!-time << printc "GCDLIST3 on the polynomials"; for each p in l do print p >>; l := sort(for each p in l collect poly!-abs p,function ordp); w := nil; while l do << w := car l . w; repeat l := cdr l until null l or not car w = car l >>; l := reversewoc w; w := nil; trace!-time << printc "Made positive, with duplicates removed..."; for each p in l do print p >>; if null cdr l then return multf(gcont,car l); % That left just one poly; if domainp (gg:=car (l:=sort(l,function degree!-order))) then return gcont; % Primitive part of one poly is a constant (must be +/-1); if ldeg gg=1 then << % True gcd is either GG or 1; if division!-test(gg,l) then return multf(poly!-abs gg,gcont) else return gcont >>; % All polys are now primitive and nontrivial. Use a modular % method to extract GCD; if onestep then << % Try to take gcd in just one pseudoremainder step, because some % previous modular test suggests it may be possible; p1 := poly!-abs car l; p2 := poly!-abs cadr l; if p1=p2 then << if division!-test(p1,cddr l) then return multf(p1,gcont) >> else << trace!-time printc "Just one pseudoremainder step needed?"; gg := poly!-gcd(lc p1,lc p2); gg := ezgcd!-pp addf(multf(red p1, quotfail1(lc p2,gg, "Division failure when just one pseudoremainder step needed")), multf(red p2,negf quotfail1(lc p1,gg, "Division failure when just one pseudoremainder step needed"))); trace!-time printsf gg; if division!-test(gg,l) then return multf(gg,gcont) >> >>; return gcdlist31(l,vlist,gcont,gg,l1) end; symbolic procedure gcdlist31(l,vlist,gcont,gg,l1); begin scalar cofactor,lcg,old!-modulus,prime,w,w1,zeros!-list; old!-modulus:=set!-modulus nil; %Remember modulus; lcg:=for each poly in l collect lc poly; trace!-time << printc "L.C.S OF L ARE:"; for each lcpoly in lcg do printsf lcpoly >>; lcg:=gcdlist lcg; trace!-time << prin2!* "LCG (=GCD OF THESE) = "; printsf lcg >>; try!-again: unlucky!-case:=nil; image!-set:=nil; set!-modulus(prime:=random!-prime()); % Produce random univariate modular images of all the % polynomials; w:=l; if not zeros!-list then << image!-set:= zeros!-list:=try!-max!-zeros!-for!-image!-set(w,vlist); trace!-time << printc image!-set; prin2 " Zeros-list = "; printc zeros!-list >> >>; trace!-time printc list("IMAGE SET",image!-set); gg:=make!-image!-mod!-p(car w,car vlist); trace!-time printc list("IMAGE SET",image!-set," GG",gg); if unlucky!-case then << trace!-time << printc "Unlucky case, try again"; print image!-set >>; go to try!-again >>; l1:=list(car w . gg); make!-images: if null (w:=cdr w) then go to images!-created!-successfully; l1:=(car w . make!-image!-mod!-p(car w,car vlist)) . l1; if unlucky!-case then << trace!-time << printc "UNLUCKY AGAIN..."; printc l1; print image!-set >>; go to try!-again >>; gg:=gcd!-mod!-p(gg,cdar l1); if domainp gg then << set!-modulus old!-modulus; trace!-time print "Primitive parts are coprime"; return gcont >>; go to make!-images; images!-created!-successfully: l1:=reversewoc l1; % Put back in order with smallest first; % If degree of gcd seems to be same as that of smallest item % in input list, that item should be the gcd; if ldeg gg=ldeg car l then << gg:=poly!-abs car l; trace!-time << prin2!* "Probable GCD = "; printsf gg >>; go to result >> else if (ldeg car l=add1 ldeg gg) and (ldeg car l=ldeg cadr l) then << % Here it seems that I have just one pseudoremainder step to % perform, so I might as well do it; trace!-time << printc "Just one pseudoremainder step needed" >>; gg := poly!-gcd(lc car l,lc cadr l); gg := ezgcd!-pp addf(multf(red car l, quotfail1(lc cadr l,gg, "Division failure when just one pseudoremainder step needed")), multf(red cadr l,negf quotfail1(lc car l,gg, "Divison failure when just one pseudoremainder step needed"))); trace!-time printsf gg; go to result >>; w:=l1; find!-good!-cofactor: if null w then go to special!-case; % No good cofactor available; if domainp gcd!-mod!-p(gg,cofactor:=quotient!-mod!-p(cdar w,gg)) then go to good!-cofactor!-found; w:=cdr w; go to find!-good!-cofactor; good!-cofactor!-found: cofactor:=monic!-mod!-p cofactor; trace!-time printc "*** Good cofactor found"; w:=caar w; trace!-time << prin2!* "W= "; printsf w; prin2!* "GG= "; printsf gg; prin2!* "COFACTOR= "; printsf cofactor >>; image!-set:=sort(image!-set,function ordopcar); trace!-time << prin2 "IMAGE-SET = "; printc image!-set; prin2 "PRIME= "; printc prime; printc "L (=POLYLIST) IS:"; for each ll in l do printsf ll >>; gg:=reconstruct!-gcd(w,gg,cofactor,prime,image!-set,lcg); if gg='nogood then go to try!-again; go to result; special!-case: % Here I have to do the first step of a PRS method; trace!-time << printc "*** SPECIAL CASE IN GCD ***"; printc l; printc "----->"; printc gg >>; reduced!-degree!-lclst:=nil; try!-reduced!-degree!-again: trace!-time << printc "L1 ="; for each ell in l1 do print ell >>; w1:=reduced!-degree(caadr l1,caar l1); w:=car w1; w1:=cdr w1; trace!-time << prin2 "REDUCED!-DEGREE = "; printsf w; prin2 " and its image = "; printsf w1 >>; % reduce the degree of the 2nd poly using the 1st. Result is % a pair : (new poly . image new poly); if domainp w and not null w then << set!-modulus old!-modulus; return gcont >>; % we're done as they're coprime; if w and ldeg w = ldeg gg then << gg:=w; go to result >>; % possible gcd; if null w then << % the first poly divided the second one; l1:=(car l1 . cddr l1); % discard second poly; if null cdr l1 then << gg := poly!-abs caar l1; go to result >>; go to try!-reduced!-degree!-again >>; % haven't made progress yet so repeat with new polys; if ldeg w<=ldeg gg then << gg := poly!-abs w; go to result >> else if domainp gcd!-mod!-p(gg,cofactor:=quotient!-mod!-p(w1,gg)) then << w := list list w; go to good!-cofactor!-found >>; l1:= if ldeg w <= ldeg caar l1 then ((w . w1) . (car l1 . cddr l1)) else (car l1 . ((w . w1) . cddr l1)); % replace first two polys by the reduced poly and the first % poly ordering according to degree; go to try!-reduced!-degree!-again; % need to repeat as we still haven't found a good cofactor; result: % Here GG holds a tentative gcd for the primitive parts of % all input polys, and GCONT holds a proper one for the content; if division!-test(gg,l) then << set!-modulus old!-modulus; return multf(gg,gcont) >>; trace!-time printc list("Trial division by ",gg," failed"); go to try!-again end; symbolic procedure make!-a!-list!-of!-variables l; begin scalar vlist; for each ll in l do vlist:=variables!.in!.form(ll,vlist); return make!-order!-consistent(vlist,kord!*) end; symbolic procedure make!-order!-consistent(l,m); % L is a subset of M. Make its order consistent with that % of M; if null l then nil else if null m then errorf("Variable missing from KORD*") else if car m member l then car m . make!-order!-consistent(delete(car m,l),cdr m) else make!-order!-consistent(l,cdr m); symbolic procedure try!-max!-zeros!-for!-image!-set(l,vlist); if null vlist then error(50,"VLIST NOT SET IN TRY-MAX-ZEROS-...") else begin scalar z; z:=for each v in cdr vlist collect if domainp lc car l or null quotf(lc car l,!*k2f v) then (v . 0) else (v . modular!-number next!-random!-number()); for each ff in cdr l do z:=for each w in z collect if zerop cdr w then if domainp lc ff or null quotf(lc ff,!*k2f car w) then w else (car w . modular!-number next!-random!-number()) else w; return z end; symbolic procedure reconstruct!-gcd(full!-poly,gg,cofactor,p,imset,lcg); if null addf(full!-poly,negf multf(gg,cofactor)) then gg else (lambda factor!-level; begin scalar number!-of!-factors,image!-factors, true!-leading!-coeffts,multivariate!-input!-poly, no!-of!-primes!-to!-try, irreducible,non!-monic,bad!-case,target!-factor!-count, multivariate!-factors,hensel!-growth!-size,alphalist, best!-known!-factors,prime!-base, m!-image!-variable, reconstructing!-gcd,full!-gcd; if not(current!-modulus=p) then errorf("GCDLIST HAS NOT RESTORED THE MODULUS"); % *WARNING* GCDLIST does not restore the modulus so % I had better reset it here! ; if poly!-minusp lcg then error(50,list("Negative GCD: ",lcg)); full!-poly:=poly!-abs full!-poly; initialise!-hensel!-fluids(full!-poly,gg,cofactor,p,lcg); trace!-time << printc "TRUE LEADING COEFFTS ARE:"; for i:=1:2 do << printsf getv(image!-factors,i); prin2!* " WITH L.C.:"; printsf getv(true!-leading!-coeffts,i) >> >>; if determine!-more!-coeffts()='done then return full!-gcd; if null alphalist then alphalist:=alphas(2, list(getv(image!-factors,1),getv(image!-factors,2)),1); if alphalist='factors! not! coprime then errorf list("image factors not coprime?",image!-factors); if not !*overview then factor!-trace << printstr "The following modular polynomials are chosen such that:"; terpri(); prin2!* " a(2)*f(1) + a(1)*f(2) = 1 mod "; printstr hensel!-growth!-size; terpri(); printstr " where degree of a(1) < degree of f(1),"; printstr " and degree of a(2) < degree of f(2),"; printstr " and"; for i:=1:2 do << prin2!* " a("; prin2!* i; prin2!* ")="; printsf cdr get!-alpha getv(image!-factors,i); prin2!* "and f("; prin2!* i; prin2!* ")="; printsf getv(image!-factors,i); terpri!* t >> >>; reconstruct!-multivariate!-factors( for each v in imset collect (car v . modular!-number cdr v)); if irreducible or bad!-case then return 'nogood else return full!-gcd end) (factor!-level+1) ; symbolic procedure initialise!-hensel!-fluids(fpoly,fac1,fac2,p,lcf1); % ... ; begin scalar lc1!-image,lc2!-image; reconstructing!-gcd:=t; multivariate!-input!-poly:=multf(fpoly,lcf1); no!-of!-primes!-to!-try := 5; prime!-base:=hensel!-growth!-size:=p; number!-of!-factors:=2; lc1!-image:=make!-numeric!-image!-mod!-p lcf1; lc2!-image:=make!-numeric!-image!-mod!-p lc fpoly; % Neither of the above leading coefficients will vanish; fac1:=times!-mod!-p(lc1!-image,fac1); fac2:=times!-mod!-p(lc2!-image,fac2); image!-factors:=mkvect 2; true!-leading!-coeffts:=mkvect 2; putv(image!-factors,1,fac1); putv(image!-factors,2,fac2); putv(true!-leading!-coeffts,1,lcf1); putv(true!-leading!-coeffts,2,lc fpoly); % If the GCD is going to be monic, we know the lc % of both cofactors exactly; non!-monic:=not(lcf1=1); m!-image!-variable:=mvar fpoly end; symbolic procedure division!-test(gg,l); % Predicate to test if GG divides all the polynomials in the list L; if null l then t else if null quotf(car l,gg) then nil else division!-test(gg,cdr l); symbolic procedure degree!-order(a,b); % Order standard forms using their degrees wrt main vars; if domainp a then t else if domainp b then nil else ldeg a<ldeg b; symbolic procedure make!-image!-mod!-p(p,v); % Form univariate image, set UNLUCKY!-CASE if leading coefficient % gets destroyed; begin scalar lp; lp := degree!-in!-variable(p,v); p := make!-univariate!-image!-mod!-p(p,v); if not degree!-in!-variable(p,v)=lp then unlucky!-case := t; return p end; symbolic procedure make!-univariate!-image!-mod!-p(p,v); % Make a modular image of P, keeping only the variable V; if domainp p then if p=nil then nil else !*n2f modular!-number p else if mvar p=v then adjoin!-term(lpow p, make!-univariate!-image!-mod!-p(lc p,v), make!-univariate!-image!-mod!-p(red p,v)) else plus!-mod!-p( times!-mod!-p(image!-of!-power(mvar p,ldeg p), make!-univariate!-image!-mod!-p(lc p,v)), make!-univariate!-image!-mod!-p(red p,v)); symbolic procedure image!-of!-power(v,n); begin scalar w; w := assoc(v,image!-set); if null w then << w := modular!-number next!-random!-number(); image!-set := (v . w) . image!-set >> else w := cdr w; return modular!-expt(w,n) end; symbolic procedure make!-numeric!-image!-mod!-p p; % Make a modular image of P; if domainp p then if p=nil then 0 else modular!-number p else modular!-plus( modular!-times(image!-of!-power(mvar p,ldeg p), make!-numeric!-image!-mod!-p lc p), make!-numeric!-image!-mod!-p red p); symbolic procedure total!-degree!-in!-powers(form,powlst); % Returns a list where each variable mentioned in FORM is paired % with the maximum degree it has. POWLST collects the list, and should % normally be NIL on initial entry; if null form or domainp form then powlst else begin scalar x; if (x := atsoc(mvar form,powlst)) then ldeg form>cdr x and rplacd(x,ldeg form) else powlst := (mvar form . ldeg form) . powlst; return total!-degree!-in!-powers(red form, total!-degree!-in!-powers(lc form,powlst)) end; symbolic procedure powers1 form; % For each variable V in FORM collect (V . (MAX . MIN)) where % MAX and MIN are limits to the degrees V has in FORM; powers2(form,powers3(form,nil),nil); symbolic procedure powers3(form,l); % Start of POWERS1 by collecting power information for % the leading monomial in FORM; if domainp form then l else powers3(lc form,(mvar form . (ldeg form . ldeg form)) . l); symbolic procedure powers2(form,powlst,thismonomial); if domainp form then if null form then powlst else powers4(thismonomial,powlst) else powers2(lc form, powers2(red form,powlst,thismonomial), lpow form . thismonomial); symbolic procedure powers4(new,old); % Merge information from new monomial into old information, % updating MAX and MIN details; if null new then for each v in old collect (car v . (cadr v . 0)) else if null old then for each v in new collect (car v . (cdr v . 0)) else if caar new=caar old then << % variables match - do MAX and MIN on degree information; if cdar new>cadar old then rplaca(cdar old,cdar new); if cdar new<cddar old then rplacd(cdar old,cdar new); rplacd(old,powers4(cdr new,cdr old)) >> else if ordop(caar new,caar old) then << rplacd(cdar old,0); % Some variable not mentioned in new monomial; rplacd(old,powers4(new,cdr old)) >> else (caar new . (cdar new . 0)) . powers4(cdr new,old); symbolic procedure ezgcd!-pp u; %returns the primitive part of the polynomial U wrt leading var; quotf1(u,comfac!-to!-poly ezgcd!-comfac u); symbolic procedure ezgcd!-sqfrf p; %P is a primitive standard form; %value is a list of square free factors; begin scalar pdash,p1,d,v; pdash := diff(p,v := mvar p); d := poly!-gcd(p,pdash); % p2*p3**2*p4**3*... ; if domainp d then return list p; p := quotfail1(p,d,"GCD division in FACTOR-SQFRF failed"); p1 := poly!-gcd(p, addf(quotfail1(pdash,d,"GCD division in FACTOR-SQFRF failed"), negf diff(p,v))); return p1 . ezgcd!-sqfrf d end; symbolic procedure reduced!-degree(u,v); %U and V are primitive polynomials in the main variable VAR; %result is pair: (reduced poly of U by V . its image) where by % reduced I mean using V to kill the leading term of U; begin scalar var,w,x; trace!-time << printc "ARGS FOR REDUCED!-DEGREE ARE:"; printsf u; printsf v >>; if u=v or quotf1(u,v) then return (nil . nil) else if ldeg v=1 then return (1 . 1); trace!-time printc "CASE NON-TRIVIAL SO TAKE A REDUCED!-DEGREE:"; var := mvar u; if ldeg u=ldeg v then x := negf lc u else x:=(mksp(var,ldeg u - ldeg v) .* negf lc u) .+ nil; w:=addf(multf(lc v,u),multf(x,v)); trace!-time printsf w; if degr(w,var)=0 then return (1 . 1); trace!-time << prin2 "REDUCED!-DEGREE-LCLST = "; print reduced!-degree!-lclst >>; reduced!-degree!-lclst := addlc(v,reduced!-degree!-lclst); trace!-time << prin2 "REDUCED!-DEGREE-LCLST = "; print reduced!-degree!-lclst >>; if x := quotf1(w,lc w) then w := x else for each y in reduced!-degree!-lclst do while (x := quotf1(w,y)) do w := x; u := v; v := ezgcd!-pp w; trace!-time << printc "U AND V ARE NOW:"; printsf u; printsf v >>; if degr(v,var)=0 then return (1 . 1) else return (v . make!-univariate!-image!-mod!-p(v,var)) end; % moved('comfac,'ezgcd!-comfac); % moved('pp,'ezgcd!-pp); endmodule; module facmisc; % Miscellaneous routines used from several sections. % Authors: A. C. Norman and P. M. A. Moore, 1979. fluid '(base!-time current!-modulus gc!-base!-time image!-set!-modulus last!-displayed!-gc!-time last!-displayed!-time modulus!/2 othervars polyzero pt save!-zset zerovarset); global '(!*test exp!-value e!-value!* largest!-small!-modulus pseudo!-primes teeny!-primes); % (1) investigate variables in polynomial; symbolic procedure multivariatep(a,v); if domainp a then nil else if not(mvar a eq v) then t else if multivariatep(lc a,v) then t else multivariatep(red a,v); symbolic procedure variables!-in!-form a; % collect variables that occur in the form a; variables!.in!.form(a,nil); symbolic procedure get!.coefft!.bound(poly,degbd); % calculates a coefft bound for the factors of poly. this simple % bound is that suggested by paul wang and linda p. rothschild in % math.comp.vol29 july 75 p.940 due to gel'fond; % Note that for tiny polynomials the bound is forced up to be % larger than any prime that will get used in the mod-p splitting; max(get!-height poly * fixexpfloat sumof degbd,110); symbolic procedure sumof degbd; if null degbd then 0 else cdar degbd + sumof cdr degbd; % The following vector is used by FIXEXPFLOAT to compute 2+fix exp float % n using the appropriate constant values. If exp were available from % the underlying LISP support system, it would be better to use that so % that the code would be independent of the following table. exp!-value := mkvect 10; putv(exp!-value,0,1); putv(exp!-value,1,3); putv(exp!-value,2,8); putv(exp!-value,3,21); putv(exp!-value,4,55); putv(exp!-value,5,149); putv(exp!-value,6,404); putv(exp!-value,7,1097); putv(exp!-value,8,2981); putv(exp!-value,9,8104); putv(exp!-value,10,22027); symbolic procedure fixexpfloat n; % Compute exponential function e**n for potentially large N, % rounding result up somewhat. Note that exp(10)=22027 or so, % so if the basic floating point exponential function is accurate % to 6 or so digits we are protected here against roundoff. if n>10 then begin scalar n2; n2 := n/2; return fixexpfloat(n2)*fixexpfloat(n-n2) end % else 2+fix exp float n; else getv(exp!-value,n); % (2) timer services; symbolic procedure set!-time(); << last!-displayed!-time:=base!-time:=readtime(); last!-displayed!-gc!-time:=gc!-base!-time:=readgctime(); nil >>; symbolic procedure print!-time m; % display time used so far, with given message; begin scalar total,incr,gctotal,gcincr,w; if not !*test then return nil; w:=readtime(); total:=w-base!-time; incr:=w-last!-displayed!-time; last!-displayed!-time:=w; w:=readgctime(); gctotal:=w-gc!-base!-time; gcincr:=w-last!-displayed!-gc!-time; last!-displayed!-gc!-time:=w; if atom m then prin2 m else << prin2 car m; m:=cdr m; while not atom m do << prin2 '! ; prin2 car m; m:=cdr m >>; if not null m then << prin2 '! ; prin2 m >> >>; prin2 " after "; prinmilli incr; prin2 "+"; prinmilli gcincr; prin2 " seconds (total = "; prinmilli total; prin2 "+"; prinmilli gctotal; prin2 ")"; terpri() end; symbolic procedure prinmilli n; % print n/1000 as a decimal fraction with 2 decimal places; begin scalar u,d1,d01; n:=n+5; %rounding; n:=quotient(n,10); %now centiseconds; n:=divide(n,10); d01:=cdr n; n:=car n; n:=divide(n,10); d1:=cdr n; u:=car n; prin2 u; prin2 '!.; prin2 d1; prin2 d01; return nil end; % (3) minor variations on ordinary algebraic operations; symbolic procedure quotfail(a,b); % version of quotf that fails if the division does; if polyzerop a then polyzero else begin scalar w; w:=quotf(a,b); if didntgo w then errorf list("UNEXPECTED DIVISION FAILURE",a,b) else return w end; symbolic procedure quotfail1(a,b,msg); % version of quotf that fails if the division does, and gives % custom message; if polyzerop a then polyzero else begin scalar w; w:=quotf(a,b); if didntgo w then errorf msg else return w end; % (4) pseudo-random prime numbers - small and large; symbolic procedure set!-teeny!-primes(); begin scalar i; i:=-1; teeny!-primes:=mkvect 9; putv(teeny!-primes,i:=iadd1 i,3); putv(teeny!-primes,i:=iadd1 i,5); putv(teeny!-primes,i:=iadd1 i,7); putv(teeny!-primes,i:=iadd1 i,11); putv(teeny!-primes,i:=iadd1 i,13); putv(teeny!-primes,i:=iadd1 i,17); putv(teeny!-primes,i:=iadd1 i,19); putv(teeny!-primes,i:=iadd1 i,23); putv(teeny!-primes,i:=iadd1 i,29); putv(teeny!-primes,i:=iadd1 i,31) end; set!-teeny!-primes(); symbolic procedure random!-small!-prime(); begin scalar p; repeat <<p:=small!-random!-number(); if evenp p then p := iadd1 p>> until primep p; return p end; symbolic procedure small!-random!-number(); % Returns a smallish number from a distribution strongly favouring % smaller numbers; begin scalar w; % The next lines generate a random value in the range 0 to 1000000. w:=remainder(next!-random!-number(),1000) +1000*remainder(next!-random!-number(),1000); if w < 0 then w := w + 1000000; w:=1.0+1.5*float w/1000000.0; % 1.0 to 2.5 w:=times(w,w); % In range 1.0 to 6.25 return fix fac!-exp w; % Should be in range 3 to 518, % < 21 about half the time; end; symbolic procedure fac!-exp u; % Simple exp routine. Assumes that Lisp has a routine for % exponentiation of floats by integers. Relative accuracy 4.e-5. begin scalar x; integer n; n := fix u; if (x := (u - float n)) > 0.5 then <<x := x - 1.0; n := n + 1>>; u := e!-value!***n; return u*((x+6.0)*x+12.0)/((x-6.0)*x+12.0) end; symbolic procedure random!-teeny!-prime l; % get one of the first 10 primes at random providing it is % not in the list L or that L says we have tried them all; if l='all or (length l = 10) then nil else begin scalar p; repeat p:=getv(teeny!-primes,remainder(next!-random!-number(),10)) until not member(p,l); return p end; % symbolic procedure primep n; % Test if prime. Only for use on small integers. % n=2 or % (n>2 and not evenp n and primetest(n,3)); % symbolic procedure primetest(n,trial); % if igreaterp(itimes(trial,trial),n) then t % else if iremainder(n,trial)=0 then nil % else primetest(n,iplus(trial,2)); % PSEUDO-PRIMES will be a list of all composite numbers which are % less than 2^24 and where 2926^(n-1) = 3315^(n-1) = 1 mod n. pseudo!-primes:=mkvect 87; begin scalar i,l; i:=0; l:= '(2047 4033 33227 38503 56033 137149 145351 146611 188191 226801 252601 294409 328021 399001 410041 488881 512461 556421 597871 636641 665281 722261 742813 873181 950797 1047619 1084201 1141141 1152271 1193221 1373653 1398101 1461241 1584133 1615681 1627921 1755001 1857241 1909001 2327041 2508013 3057601 3363121 3542533 3581761 3828001 4069297 4209661 4335241 4510507 4588033 4650049 4877641 5049001 5148001 5176153 5444489 5481451 5892511 5968873 6186403 6189121 6733693 6868261 6955541 7398151 7519441 8086231 8134561 8140513 8333333 8725753 8927101 9439201 9494101 10024561 10185841 10267951 10606681 11972017 13390081 14063281 14469841 14676481 14913991 15247621 15829633 16253551); while l do << putv(pseudo!-primes,i,car l); i:=i+1; l:=cdr l >> end; symbolic procedure random!-prime(); begin % I want a random prime that is smaller than largest-small-modulus. % I do this by generating random odd integers in the range lsm/2 to % lsm and filtering them for primality. Prime testing is done using % a Fermat test followed by lookup in an exception table that was % laboriously precomputed. This process should be distinctly faster % than trial-division testing of candidate primes, but the exception % table is tedious to compute, so I limit lsm to 2**24 here. This is % both the value that Cambridge Lisp can support directly, an indication % of how large an exception table I computed using 48 hours of CPU time % and large enough that primes selected this way will hardly ever % be unlucky just through being too small. scalar p,w,oldmod,lsm, lsm2; lsm := largest!-small!-modulus; if lsm > 2**24 then lsm := 2**24; lsm2 := lsm/2; % W will become 1 when P is prime; oldmod := current!-modulus; while not (w=1) do << p := remainder(next!-random!-number(), lsm); if p < lsm2 then p := p + lsm2; if evenp p then p := p + 1; set!-modulus p; w:=modular!-expt(modular!-number 2926,isub1 p); if w=1 and (modular!-expt(modular!-number 3315,isub1 p) neq 1 or pseudo!-prime!-p p) then w:=0>>; set!-modulus oldmod; return p end; symbolic procedure pseudo!-prime!-p n; begin scalar low,mid,high,v; low:=0; high:=87; % Size of vector of pseudo-primes; while not (high=low) do << % Binary search in table; mid:=iquotient(iplus(iadd1 high,low),2); % Mid point of (low,high); v:=getv(pseudo!-primes,mid); if igreaterp(v,n) then high:=isub1 mid else low:=mid >>; return (getv(pseudo!-primes,low)=n) end; % (5) useful routines for vectors; symbolic procedure form!-sum!-and!-product!-mod!-p(avec,fvec,r); % sum over i (avec(i) * fvec(i)); begin scalar s; s:=polyzero; for i:=1:r do s:=plus!-mod!-p(times!-mod!-p(getv(avec,i),getv(fvec,i)), s); return s end; symbolic procedure form!-sum!-and!-product!-mod!-m(avec,fvec,r); % Same as above but AVEC holds alphas mod p and want to work % mod m (m > p) so minor difference to change AVEC to AVEC mod m; begin scalar s; s:=polyzero; for i:=1:r do s:=plus!-mod!-p(times!-mod!-p( !*f2mod !*mod2f getv(avec,i),getv(fvec,i)),s); return s end; symbolic procedure reduce!-vec!-by!-one!-var!-mod!-p(v,pt,n); % substitute for the given variable in all elements creating a % new vector for the result. (all arithmetic is mod p); begin scalar newv; newv:=mkvect n; for i:=1:n do putv(newv,i,evaluate!-mod!-p(getv(v,i),car pt,cdr pt)); return newv end; symbolic procedure make!-bivariate!-vec!-mod!-p(v,imset,var,n); begin scalar newv; newv:=mkvect n; for i:=1:n do putv(newv,i,make!-bivariate!-mod!-p(getv(v,i),imset,var)); return newv end; symbolic procedure times!-vector!-mod!-p(v,n); % product of all the elements in the vector mod p; begin scalar w; w:=1; for i:=1:n do w:=times!-mod!-p(getv(v,i),w); return w end; symbolic procedure make!-vec!-modular!-symmetric(v,n); % fold each elt of V which is current a modular poly in the % range 0->(p-1) onto the symmetric range (-p/2)->(p/2); for i:=1:n do putv(v,i,make!-modular!-symmetric getv(v,i)); % (6) Combinatorial fns used in finding values for the variables; symbolic procedure make!-zerovarset vlist; % vlist is a list of pairs (v . tag) where v is a variable name and % tag is a boolean tag. The procedure splits the list into two % according to the tags: Zerovarset is set to a list of variables % whose tag is false and othervars contains the rest; for each w in vlist do if cdr w then othervars:= car w . othervars else zerovarset:= car w . zerovarset; symbolic procedure make!-zeroset!-list n; % Produces a list of lists each of length n with all combinations of % ones and zeroes; begin scalar w; for k:=0:n do w:=append(w,kcombns(k,n)); return w end; symbolic procedure kcombns(k,m); % produces a list of all combinations of ones and zeroes with k ones % in each; if k=0 or k=m then begin scalar w; if k=m then k:=1; for i:=1:m do w:=k.w; return list w end else if k=1 or k=isub1 m then << if k=isub1 m then k:=0; list!-with!-one!-a(k,1 #- k,m) >> else append( for each x in kcombns(isub1 k,isub1 m) collect (1 . x), for each x in kcombns(k,isub1 m) collect (0 . x) ); symbolic procedure list!-with!-one!-a(a,b,m); % Creates list of all lists with one a and m-1 b's in; begin scalar w,x,r; for i:=1:isub1 m do w:=b . w; r:=list(a . w); for i:=1:isub1 m do << x:=(car w) . x; w:=cdr w; r:=append(x,(a . w)) . r >>; return r end; symbolic procedure make!-next!-zset l; begin scalar k,w; image!-set!-modulus:=iadd1 image!-set!-modulus; set!-modulus image!-set!-modulus; w:=for each ll in cdr l collect for each n in ll collect if n=0 then n else << k:=modular!-number next!-random!-number(); while (zerop k) or (onep k) do k:=modular!-number next!-random!-number(); if k>modulus!/2 then k:=k-current!-modulus; k >>; save!-zset:=nil; return w end; endmodule; module facprim; % Factorize a primitive multivariate polynomial. % Author: P. M. A. Moore, 1979. % Modifications by: Arthur C. Norman. fluid '(!*force!-zero!-set !*overshoot !*overview !*timings !*trfac alphalist alphavec bad!-case base!-time best!-factor!-count best!-known!-factors best!-modulus best!-set!-pointer chosen!-prime current!-factor!-product current!-modulus degree!-bounds deltam f!-numvec factor!-level factor!-trace!-list factored!-lc factorvec facvec fhatvec forbidden!-primes forbidden!-sets full!-gcd hensel!-growth!-size image!-content image!-factors image!-lc image!-mod!-p image!-poly image!-set image!-set!-modulus input!-leading!-coefficient input!-polynomial inverted inverted!-sign irreducible known!-factors kord!* m!-image!-variable modfvec modular!-info multivariate!-factors multivariate!-input!-poly no!-of!-best!-sets no!-of!-primes!-to!-try no!-of!-random!-sets non!-monic null!-space!-basis number!-of!-factors one!-complete!-deg!-analysis!-done othervars poly!-mod!-p polynomial!-to!-factor predictions previous!-degree!-map prime!-base reconstructing!-gcd reduction!-count save!-zset sfp!-count split!-list target!-factor!-count true!-leading!-coeffts usable!-set!-found valid!-image!-sets vars!-to!-kill zero!-set!-tried zerovarset zset); global '(largest!-small!-modulus); %**********************************************************************; % % multivariate polynomial factorization more or less as described % by paul wang in: math. comp. vol.32 no.144 oct 1978 pp. 1215-1231 % 'an improved multivariate polynomial factoring algorithm' % %**********************************************************************; %----------------------------------------------------------------------; % this code works by using a local database of fluid variables % whose meaning is (hopefully) obvious. % they are used as follows: % % global name: set in: comments: % % m!-factored!-leading! create!.images only set if non-numeric % -coefft % m!-factored!-images factorize!.images vector % m!-input!-polynomial factorize!-primitive! % -polynomial % m!-best!-image!-pointer choose!.best!.image % m!-image!-factors choose!.best!.image vector % m!-true!-leading! choose!.best!.image vector % -coeffts % m!-prime choose!.best!.image % irreducible factorize!.images predicate % inverted create!.images predicate % m!-inverted!-sign create!-images +1 or -1 % non!-monic determine!-leading! predicate % -coeffts % (also reconstruct!-over! % -integers) % m!-number!-of!-factors choose!.best!.image % m!-image!-variable square!.free!.factorize % or factorize!-form % m!-image!-sets create!.images vector % this last contains the images of m!-input!-polynomial and the % numbers associated with the factors of lc m!-input!-polynomial (to be % used later) the latter existing only when the lc m!-input!-polynomial % is non-integral. ie.: % m!-image!-sets=< ... , (( d . u ), a, d) , ... > ( a vector) % where: a = an image set (=association list); % d = cont(m!-input!-polynomial image wrt a); % u = prim.part.(same) which is non-trivial square-free % by choice of image set.; % d = vector of numbers associated with factors in lc % m!-input!-polynomial (these depend on a as well); % the number of entries in m!-image!-sets is defined by the fluid % variable, no.of.random.sets; % % % %----------------------------------------------------------------------; %**********************************************************************; % multivariate factorization part 1. entry point for this code: % ** n.b.** the polynomial is assumed to be non-trivial and primitive; symbolic procedure square!.free!.factorize u; % u primitive (multivariate) poly but not yet square free. % result is list of factors consed with their respective multiplicities: % ((f1 . m1),(f2 . m2),...) where mi may = mj when i not = j ; % u is non-trivial - ie. at least linear in some variable; %***** nb. this does not use best square free method *****; begin scalar v,w,x,i,newu,f!.list,sfp!-count; sfp!-count:=0; factor!-trace if not u=polynomial!-to!-factor then << prin2!* "Primitive polynomial to factor: "; printsf u >>; if null m!-image!-variable then errorf list("M-IMAGE-VARIABLE not set: ",u); v:=poly!-gcd(u, derivative!-wrt!-main!-variable(u,m!-image!-variable)); if onep v then << factor!-trace printstr "The polynomial is square-free."; return square!-free!-prim!-factor(u,1) >> else factor!-trace << printstr "We now square-free decompose this to produce a series of "; printstr "(square-free primitive) factors which we treat in turn: "; terpri(); terpri() >>; w:=quotfail(u,v); x:=poly!-gcd(v,w); newu:=quotfail(w,x); if not onep newu then << f!.list:=append(f!.list, square!-free!-prim!-factor(newu,1)) >>; i:=2; % power of next factors; % from now on we can avoid an extra gcd and any diffn; while not domainp v do << v:=quotfail(v,x); w:=quotfail(w,newu); x:=poly!-gcd(v,w); newu:=quotfail(w,x); if not onep newu then << f!.list:=append(f!.list, square!-free!-prim!-factor(newu,i)) >>; i:=iadd1 i >>; if not v=1 then f!.list:=(v . 1) . f!.list; return f!.list end; symbolic procedure square!-free!-prim!-factor(u,i); % factorize the square-free primitive factor u whose multiplicity % in the original poly is i. return the factors consed with this % multiplicity; begin scalar w; sfp!-count:=iadd1 sfp!-count; factor!-trace << if not(u=polynomial!-to!-factor) then << prin2!* "("; prin2!* sfp!-count; prin2!* ") Square-free primitive factor: "; printsf u; prin2!* " with multiplicity "; prin2!* i; terpri!*(nil) >> >>; w:=distribute!.multiplicity(factorize!-primitive!-polynomial u,i); factor!-trace if not u=polynomial!-to!-factor then << prin2!* "Factors of ("; prin2!* sfp!-count; printstr ") are: "; fac!-printfactors(1 . w); terpri(); terpri() >>; return w end; symbolic procedure distribute!.multiplicity(factorlist,n); % factorlist is a simple list of factors of a square free primitive % multivariate poly and n is their multiplicity in a square free % decomposition of another polynomial. result is a list of form: % ((f1 . n),(f2 . n),...) where fi are the factors.; for each w in factorlist collect (w . n); symbolic procedure factorize!-primitive!-polynomial u; % u is primitive square free and at least linear in % m!-image!-variable. m!-image!-variable is the variable preserved in % the univariate images. this function determines a random set of % integers and a prime to create a univariate modular image of u, % factorize it and determine the leading coeffts of the factors in the % full factorization of u. finally the modular image factors are grown % up to the full multivariates ones using the hensel construction; % result is simple list of irreducible factors; if degree!-in!-variable(u,m!-image!-variable) = 1 then list u else if degree!-in!-variable(u,m!-image!-variable) = 2 then factorize!-quadratic u else if fac!-univariatep u then univariate!-factorize u else begin scalar valid!-image!-sets,factored!-lc,image!-factors,prime!-base, one!-complete!-deg!-analysis!-done,zset,zerovarset,othervars, multivariate!-input!-poly,best!-set!-pointer,reduction!-count, true!-leading!-coeffts,number!-of!-factors, inverted!-sign,irreducible,inverted,vars!-to!-kill, forbidden!-sets,zero!-set!-tried,non!-monic, no!-of!-best!-sets,no!-of!-random!-sets,bad!-case, target!-factor!-count,modular!-info,multivariate!-factors, hensel!-growth!-size,alphalist,base!-timer,w!-time, previous!-degree!-map,image!-set!-modulus, best!-known!-factors,reconstructing!-gcd,full!-gcd; base!-timer:=time(); trace!-time display!-time( " Entered multivariate primitive polynomial code after ", base!-timer - base!-time); %note that this code works by using a local database of %fluid variables that are updated by the subroutines directly %called here. this allows for the relativly complicated %interaction between flow of data and control that occurs in %the factorization algorithm. factor!-trace << printstr "From now on we shall refer to this polynomial as U."; printstr "We now create an image of U by picking suitable values "; printstr "for all but one of the variables in U."; prin2!* "The variable preserved in the image is "; prinvar m!-image!-variable; terpri!*(nil) >>; initialize!-fluids u; % set up the fluids to start things off; w!-time:=time(); tryagain: get!-some!-random!-sets(); choose!-the!-best!-set(); trace!-time << display!-time("Modular factoring and best set chosen in ", time()-w!-time); w!-time:=time() >>; if irreducible then return list u else if bad!-case then << if !*overshoot then printc "Bad image sets - loop"; bad!-case:=nil; goto tryagain >>; reconstruct!-image!-factors!-over!-integers(); trace!-time << display!-time("Image factors reconstructed in ",time()-w!-time); w!-time:=time() >>; if irreducible then return list u else if bad!-case then << if !*overshoot then printc "Bad image factors - loop"; bad!-case:=nil; goto tryagain >>; determine!.leading!.coeffts(); trace!-time << display!-time("Leading coefficients distributed in ", time()-w!-time); w!-time:=time() >>; if irreducible then return list u else if bad!-case then << if !*overshoot then printc "Bad split shown by LC distribution"; bad!-case:=nil; goto tryagain >>; if determine!-more!-coeffts()='done then << trace!-time << display!-time("All the coefficients distributed in ", time()-w!-time); w!-time:=time() >>; return check!-inverted multivariate!-factors >>; trace!-time << display!-time("More coefficients distributed in ", time()-w!-time); w!-time:=time() >>; reconstruct!-multivariate!-factors(nil); if bad!-case and not irreducible then << if !*overshoot then printc "Multivariate overshoot - restart"; bad!-case:=nil; goto tryagain >>; trace!-time display!-time("Multivariate factors reconstructed in ", time()-w!-time); if irreducible then return list u; return check!-inverted multivariate!-factors end; symbolic procedure getcof(p, v, n); % Get coeff of v^n in p; % I bet this exists somewhere under a different name.... if domainp p then if n=0 then p else nil else if mvar p = v then if ldeg p=n then lc p else getcof(red p, v, n) else addf(multf((lpow p .* 1) .+ nil, getcof(lc p, v, n)), getcof(red p, v, n)); symbolic procedure factorize!-quadratic u; % U is a primitive square-free quadratic. It factors if and only if % its discriminant is a perfect square; begin scalar a, b, c, discr, f1, f2, x; % I am unreasonably cautious here - i THINK that the image variable % should be the main var here, but in case things have goot themselves % reordered & to make myself bomb proof against future changes I will % not assume same a := getcof(u, m!-image!-variable, 2); b := getcof(u, m!-image!-variable, 1); c := getcof(u, m!-image!-variable, 0); discr := addf(multf(b, b), multf(a, multf(-4, c))); discr := sqrtf2 discr; if discr=-1 then return list u; % Irreducible; x := addf(multf(a, multf(2, !*k2f m!-image!-variable)), b); f1 := addf(x, discr); f2 := addf(x, negf discr); f1 := quotf(f1, cdr contents!-with!-respect!-to(f1, m!-image!-variable)); f2 := quotf(f2, cdr contents!-with!-respect!-to(f2, m!-image!-variable)); return list(f1, f2) end; symbolic procedure sqrtd2 d; % Square root of domain element or -1 if it does not have an exact one; % Possibly needs upgrades to deal with non-integer domains, e.g. in % modular arithmetic just half of all values have square roots (= are % quadratic residues), but finding the roots is (I think) HARD. In % floating point it could be taken that all positive values have square % roots. Anyway somebody can adjust this as necessary and I think that % SQRTF2 will then behave properly... if d=nil then nil else if not fixp d or d<0 then -1 else begin scalar q, r, rold; q := pmam!-sqrt d; % Works even if D is really huge; r := q*q-d; repeat << rold := abs r; q := q - (r+q)/(2*q); % / truncates, so this rounds to nearest r := q*q-d >> until abs r >= rold; if r=0 then return q else return -1 end; symbolic procedure sqrtf2 p; % Return square root of the polynomial P if there is an exact one, % else returns -1 to indicate failure; if domainp p then sqrtd2 p else begin scalar v, d, qlc, q, r, w; if not evenp (d := ldeg p) or (qlc := sqrtf2 lc p) = -1 then return -1; d := d/2; v := mvar p; q := (mksp(v, d) .* qlc) .+ nil; % First approx to sqrt(P) r := multf(2, q); p := red p; % Residue while p neq nil and mvar p = v and ldeg p >= d and (w := quotf(lt p .+ nil, r)) neq nil do << p := addf(p, multf(negf w, addf(multf(2, q), w))); q := addf(q, w) >>; if p=nil then return q else return -1 end; symbolic procedure initialize!-fluids u; % Set up the fluids to be used in factoring primitive poly; begin scalar w,w1,wtime; if !*force!-zero!-set then << no!-of!-random!-sets:=1; no!-of!-best!-sets:=1 >> else << no!-of!-random!-sets:=9; % we generate this many and calculate their factor counts. no!-of!-best!-sets:=5; % we find the modular factors of this many; >>; image!-set!-modulus:=5; vars!-to!-kill:=variables!-to!-kill lc u; multivariate!-input!-poly:=u; no!-of!-primes!-to!-try := 5; target!-factor!-count:=degree!-in!-variable(u,m!-image!-variable); if not domainp lc multivariate!-input!-poly then if domainp (w:= trailing!.coefft(multivariate!-input!-poly, m!-image!-variable)) then << inverted:=t; % note that we are 'inverting' the poly m!-input!-polynomial; w1:=invert!.poly(multivariate!-input!-poly,m!-image!-variable); multivariate!-input!-poly:=cdr w1; inverted!-sign:=car w1; % to ease the lc problem, m!-input!-polynomial <- poly % produced by taking numerator of (m!-input!-polynomial % with 1/m!-image!-variable substituted for % m!-image!-variable); % m!-inverted!-sign is -1 if we have inverted the sign of % the resulting poly to keep it +ve, else +1; factor!-trace << prin2!* "The trailing coefficient of U wrt "; prinvar m!-image!-variable; prin2!* "(="; prin2!* w; printstr ") is purely numeric so we 'invert' U to give: "; prin2!* " U <- "; printsf multivariate!-input!-poly; printstr "This simplifies any problems with the leading "; printstr "coefficient of U." >> >> else << trace!-time printc "Factoring the leading coefficient:"; wtime:=time(); factored!-lc:= factorize!-form!-recursion lc multivariate!-input!-poly; trace!-time display!-time("Leading coefficient factored in ", time()-wtime); % factorize the lc of m!-input!-polynomial completely; factor!-trace << printstr "The leading coefficient of U is non-trivial so we must "; printstr "factor it before we can decide how it is distributed"; printstr "over the leading coefficients of the factors of U."; printstr "So the factors of this leading coefficient are:"; fac!-printfactors factored!-lc >> >>; make!-zerovarset vars!-to!-kill; % Sets ZEROVARSET and OTHERVARS; if null zerovarset then zero!-set!-tried:=t else << zset:=make!-zeroset!-list length zerovarset; save!-zset:=zset >> end; symbolic procedure variables!-to!-kill lc!-u; % picks out all the variables in u except var. also checks to see if % any of these divide lc u: if they do they are dotted with t otherwise % dotted with nil. result is list of these dotted pairs; for each w in cdr kord!* collect if (domainp lc!-u) or didntgo quotf(lc!-u,!*k2f w) then (w . nil) else (w . t); %**********************************************************************; % multivariate factorization part 2. creating image sets and picking % the best one; fluid '(usable!-set!-found); symbolic procedure get!-some!-random!-sets(); % here we create a number of random sets to make the input % poly univariate by killing all but 1 of the variables. at % the same time we pick a random prime to reduce this image % poly mod p; begin scalar image!-set,chosen!-prime,image!-lc,image!-mod!-p,wtime, image!-content,image!-poly,f!-numvec,forbidden!-primes,i,j, usable!-set!-found; valid!-image!-sets:=mkvect no!-of!-random!-sets; i:=0; while i < no!-of!-random!-sets do << wtime:=time(); generate!-an!-image!-set!-with!-prime( if i<idifference(no!-of!-random!-sets,3) then nil else t); trace!-time display!-time(" Image set generated in ",time()-wtime); i:=iadd1 i; putv(valid!-image!-sets,i,list( image!-set,chosen!-prime,image!-lc,image!-mod!-p,image!-content, image!-poly,f!-numvec)); forbidden!-sets:=image!-set . forbidden!-sets; forbidden!-primes:=list chosen!-prime; j:=1; while (j<3) and (i<no!-of!-random!-sets) do << wtime:=time(); image!-mod!-p:=find!-a!-valid!-prime(image!-lc,image!-poly, not numberp image!-content); if not(image!-mod!-p='not!-square!-free) then << trace!-time display!-time(" Prime and image mod p found in ", time()-wtime); i:=iadd1 i; putv(valid!-image!-sets,i,list( image!-set,chosen!-prime,image!-lc,image!-mod!-p, image!-content,image!-poly,f!-numvec)); forbidden!-primes:=chosen!-prime . forbidden!-primes >>; j:=iadd1 j >> >> end; symbolic procedure choose!-the!-best!-set(); % given several random sets we now choose the best by factoring % each image mod its chosen prime and taking one with the % lowest factor count as the best for hensel growth; begin scalar split!-list,poly!-mod!-p,null!-space!-basis, known!-factors,w,n,fnum,remaining!-split!-list,wtime; modular!-info:=mkvect no!-of!-random!-sets; wtime:=time(); for i:=1:no!-of!-random!-sets do << w:=getv(valid!-image!-sets,i); get!-factor!-count!-mod!-p(i,get!-image!-mod!-p w, get!-chosen!-prime w,not numberp get!-image!-content w) >>; split!-list:=sort(split!-list,function lessppair); % this now contains a list of pairs (m . n) where % m is the no: of factors in image no: n. the list % is sorted with best split (smallest m) first; trace!-time display!-time(" Factor counts found in ",time()-wtime); if caar split!-list = 1 then << irreducible:=t; return nil >>; w:=nil; wtime:=time(); for i:=1:no!-of!-best!-sets do << n:=cdar split!-list; get!-factors!-mod!-p(n, get!-chosen!-prime getv(valid!-image!-sets,n)); w:=(car split!-list) . w; split!-list:=cdr split!-list >>; % pick the best few of these and find out their % factors mod p; trace!-time display!-time(" Best factors mod p found in ",time()-wtime); remaining!-split!-list:=split!-list; split!-list:=reversewoc w; % keep only those images that are fully factored mod p; wtime:=time(); check!-degree!-sets(no!-of!-best!-sets,t); % the best image is pointed at by best!-set!-pointer; trace!-time display!-time(" Degree sets analysed in ",time()-wtime); % now if these didn't help try the rest to see % if we can avoid finding new image sets altogether: ; if bad!-case then << bad!-case:=nil; wtime:=time(); while remaining!-split!-list do << n:=cdar remaining!-split!-list; get!-factors!-mod!-p(n, get!-chosen!-prime getv(valid!-image!-sets,n)); w:=(car remaining!-split!-list) . w; remaining!-split!-list:=cdr remaining!-split!-list >>; trace!-time display!-time(" More sets factored mod p in ",time()-wtime); split!-list:=reversewoc w; wtime:=time(); check!-degree!-sets(no!-of!-random!-sets - no!-of!-best!-sets,t); % best!-set!-pointer hopefully points at the best image ; trace!-time display!-time(" More degree sets analysed in ",time()-wtime) >>; one!-complete!-deg!-analysis!-done:=t; factor!-trace << w:=getv(valid!-image!-sets,best!-set!-pointer); prin2!* "The chosen image set is: "; for each x in get!-image!-set w do << prinvar car x; prin2!* "="; prin2!* cdr x; prin2!* "; " >>; terpri!*(nil); prin2!* "and chosen prime is "; printstr get!-chosen!-prime w; printstr "Image polynomial (made primitive) = "; printsf get!-image!-poly w; if not(get!-image!-content w=1) then << prin2!* " with (extracted) content of "; printsf get!-image!-content w >>; prin2!* "The image polynomial mod "; prin2!* get!-chosen!-prime w; printstr ", made monic, is:"; printsf get!-image!-mod!-p w; printstr "and factors of the primitive image mod this prime are:"; for each x in getv(modular!-info,best!-set!-pointer) do printsf x; if (fnum:=get!-f!-numvec w) and not !*overview then << printstr "The numeric images of each (square-free) factor of"; printstr "the leading coefficient of the polynomial are as"; prin2!* "follows (in order):"; prin2!* " "; for i:=1:length cdr factored!-lc do << prin2!* getv(fnum,i); prin2!* "; " >>; terpri!*(nil) >> >> end; %**********************************************************************; % multivariate factorization part 3. reconstruction of the % chosen image over the integers; symbolic procedure reconstruct!-image!-factors!-over!-integers(); % the hensel construction from modular case to univariate % over the integers; begin scalar best!-modulus,best!-factor!-count,input!-polynomial, input!-leading!-coefficient,best!-known!-factors,s,w,i, x!-is!-factor,x!-factor; s:=getv(valid!-image!-sets,best!-set!-pointer); best!-known!-factors:=getv(modular!-info,best!-set!-pointer); best!-modulus:=get!-chosen!-prime s; best!-factor!-count:=length best!-known!-factors; input!-polynomial:=get!-image!-poly s; if ldeg input!-polynomial=1 then if not(x!-is!-factor:=not numberp get!-image!-content s) then errorf list("Trying to factor a linear image poly: ", input!-polynomial) else begin scalar brecip,ww,om,x!-mod!-p; number!-of!-factors:=2; prime!-base:=best!-modulus; x!-factor:=!*k2f m!-image!-variable; putv(valid!-image!-sets,best!-set!-pointer, put!-image!-poly!-and!-content(s,lc get!-image!-content s, multf(x!-factor,get!-image!-poly s))); om:=set!-modulus best!-modulus; brecip:=modular!-reciprocal red (ww:=reduce!-mod!-p input!-polynomial); x!-mod!-p:=!*f2mod x!-factor; alphalist:=list( (x!-mod!-p . brecip), (ww . modular!-minus modular!-times(brecip,lc ww))); do!-quadratic!-growth(list(x!-factor,input!-polynomial), list(x!-mod!-p,ww),best!-modulus); w:=list input!-polynomial; % All factors apart from X-FACTOR; set!-modulus om end else << input!-leading!-coefficient:=lc input!-polynomial; factor!-trace << printstr "Next we use the Hensel Construction to grow these modular"; printstr "factors into factors over the integers." >>; w:=reconstruct!.over!.integers(); if irreducible then return t; if (x!-is!-factor:=not numberp get!-image!-content s) then << number!-of!-factors:=length w + 1; x!-factor:=!*k2f m!-image!-variable; putv(valid!-image!-sets,best!-set!-pointer, put!-image!-poly!-and!-content(s,lc get!-image!-content s, multf(x!-factor,get!-image!-poly s))); fix!-alphas() >> else number!-of!-factors:=length w; if number!-of!-factors=1 then return irreducible:=t >>; if number!-of!-factors>target!-factor!-count then return bad!-case:=list get!-image!-set s; image!-factors:=mkvect number!-of!-factors; i:=1; factor!-trace printstr "The full factors of the image polynomial are:"; for each im!-factor in w do << putv(image!-factors,i,im!-factor); factor!-trace printsf im!-factor; i:=iadd1 i >>; if x!-is!-factor then << putv(image!-factors,i,x!-factor); factor!-trace << printsf x!-factor; printsf get!-image!-content getv(valid!-image!-sets,best!-set!-pointer) >> >> end; symbolic procedure do!-quadratic!-growth(flist,modflist,p); begin scalar fhatvec,alphavec,factorvec,modfvec,facvec, current!-factor!-product,i,deltam,m; fhatvec:=mkvect number!-of!-factors; alphavec:=mkvect number!-of!-factors; factorvec:=mkvect number!-of!-factors; modfvec:=mkvect number!-of!-factors; facvec:=mkvect number!-of!-factors; current!-factor!-product:=1; i:=0; for each ff in flist do << putv(factorvec,i:=iadd1 i,ff); current!-factor!-product:=multf(ff,current!-factor!-product) >>; i:=0; for each modff in modflist do << putv(modfvec,i:=iadd1 i,modff); putv(alphavec,i,cdr get!-alpha modff) >>; deltam:=p; m:=deltam*deltam; while m<largest!-small!-modulus do << quadratic!-step(m,number!-of!-factors); m:=m*deltam >>; hensel!-growth!-size:=deltam; alphalist:=nil; for j:=1:number!-of!-factors do alphalist:=(reduce!-mod!-p getv(factorvec,j) . getv(alphavec,j)) . alphalist end; symbolic procedure fix!-alphas(); % we extracted a factor x (where x is the image variable) % before any alphas were calculated, we now need to put % back this factor and its coresponding alpha which incidently % will change the other alphas; begin scalar om,f1,x!-factor,a,arecip,b; om:=set!-modulus hensel!-growth!-size; f1:=reduce!-mod!-p input!-polynomial; x!-factor:=!*f2mod !*k2f m!-image!-variable; arecip:=modular!-reciprocal (a:=evaluate!-mod!-p(f1,m!-image!-variable,0)); b:=times!-mod!-p(modular!-minus arecip, quotfail!-mod!-p(difference!-mod!-p(f1,a),x!-factor)); alphalist:=(x!-factor . arecip) . (for each aa in alphalist collect ((car aa) . remainder!-mod!-p(times!-mod!-p(b,cdr aa),car aa))); set!-modulus om end; %**********************************************************************; % multivariate factorization part 4. determining the leading % coefficients; symbolic procedure determine!.leading!.coeffts(); % this function determines the leading coeffts to all but a constant % factor which is spread over all of the factors before reconstruction; begin scalar delta,c,s; s:=getv(valid!-image!-sets,best!-set!-pointer); delta:=get!-image!-content s; % cont(the m!-input!-polynomial image); if not domainp lc multivariate!-input!-poly then << true!-leading!-coeffts:= distribute!.lc(number!-of!-factors,image!-factors,s, factored!-lc); if bad!-case then << bad!-case:=list get!-image!-set s; target!-factor!-count:=number!-of!-factors - 1; if target!-factor!-count=1 then irreducible:=t; return bad!-case >>; delta:=car true!-leading!-coeffts; true!-leading!-coeffts:=cdr true!-leading!-coeffts; % if the lc problem exists then use wang's algorithm to % distribute it over the factors. ; if not !*overview then factor!-trace << printstr "We now determine the leading coefficients of the "; printstr "factors of U by using the factors of the leading"; printstr "coefficient of U and their (square-free) images"; printstr "referred to earlier:"; for i:=1:number!-of!-factors do << prinsf getv(image!-factors,i); prin2!* " with l.c.: "; printsf getv(true!-leading!-coeffts,i) >> >>; if not onep delta then factor!-trace << if !*overview then << printstr "In determining the leading coefficients of the factors"; prin2!* "of U, " >>; prin2!* "We have an integer factor, "; prin2!* delta; printstr ", left over that we "; printstr "cannot yet distribute correctly." >> >> else << true!-leading!-coeffts:=mkvect number!-of!-factors; for i:=1:number!-of!-factors do putv(true!-leading!-coeffts,i,lc getv(image!-factors,i)); if not onep delta then factor!-trace << prin2!* "U has a leading coefficient = "; prin2!* delta; printstr " which we cannot "; printstr "yet distribute correctly over the image factors." >> >>; if not onep delta then << for i:=1:number!-of!-factors do << putv(image!-factors,i,multf(delta,getv(image!-factors,i))); putv(true!-leading!-coeffts,i, multf(delta,getv(true!-leading!-coeffts,i))) >>; divide!-all!-alphas delta; c:=expt(delta,isub1 number!-of!-factors); multivariate!-input!-poly:=multf(c,multivariate!-input!-poly); non!-monic:=t; factor!-trace << printstr "(a) We multiply each of the image factors by the "; printstr "absolute value of this constant and multiply"; prin2!* "U by "; if not(number!-of!-factors=2) then << prin2!* delta; prin2!* "**"; prin2!* isub1 number!-of!-factors >> else prin2!* delta; printstr " giving new image factors"; printstr "as follows: "; for i:=1:number!-of!-factors do printsf getv(image!-factors,i) >> >>; % if necessary, fiddle the remaining integer part of the % lc of m!-input!-polynomial; end; %**********************************************************************; % multivariate factorization part 5. reconstruction; symbolic procedure reconstruct!-multivariate!-factors vset!-mod!-p; % Hensel construction for multivariate case % Full univariate split has already been prepared (if factoring); % but we only need the modular factors and the true leading coeffts; (lambda factor!-level; begin scalar s,om,u0,alphavec,wtime,predictions, best!-factors!-mod!-p,fhatvec,w1,fvec!-mod!-p,d,degree!-bounds, lc!-vec; alphavec:=mkvect number!-of!-factors; best!-factors!-mod!-p:=mkvect number!-of!-factors; lc!-vec := mkvect number!-of!-factors; % This will preserve the LCs of the factors while we are working % mod p since they may contain numbers that are bigger than the % modulus.; if not( (d:=max!-degree(multivariate!-input!-poly,0)) < prime!-base) then fvec!-mod!-p:=choose!-larger!-prime d; om:=set!-modulus hensel!-growth!-size; if null fvec!-mod!-p then << fvec!-mod!-p:=mkvect number!-of!-factors; for i:=1:number!-of!-factors do putv(fvec!-mod!-p,i,reduce!-mod!-p getv(image!-factors,i)) >>; for i:=1:number!-of!-factors do << putv(alphavec,i,cdr get!-alpha getv(fvec!-mod!-p,i)); putv(best!-factors!-mod!-p,i, reduce!-mod!-p getv(best!-known!-factors,i)); putv(lc!-vec,i,lc getv(best!-known!-factors,i)) >>; % Set up the Alphas, input factors mod p and remember to save % the LCs for use after finding the multivariate factors mod p; if not reconstructing!-gcd then << s:=getv(valid!-image!-sets,best!-set!-pointer); vset!-mod!-p:=for each v in get!-image!-set s collect (car v . modular!-number cdr v) >>; % princ "kord* =";% print kord!*; % princ "order of variable substitution=";% print vset!-mod!-p; u0:=reduce!-mod!-p multivariate!-input!-poly; set!-degree!-bounds vset!-mod!-p; wtime:=time(); factor!-trace << printstr "We use the Hensel Construction to grow univariate modular"; printstr "factors into multivariate modular factors, which will in"; printstr "turn be used in the later Hensel construction. The"; printstr "starting modular factors are:"; printvec(" f(",number!-of!-factors,")=",best!-factors!-mod!-p); prin2!* "The modulus is "; printstr current!-modulus >>; find!-multivariate!-factors!-mod!-p(u0, best!-factors!-mod!-p, vset!-mod!-p); if bad!-case then << trace!-time << display!-time(" Multivariate modular factors failed in ", time()-wtime); wtime:=time() >>; target!-factor!-count:=number!-of!-factors - 1; if target!-factor!-count=1 then irreducible:=t; set!-modulus om; return bad!-case >>; trace!-time << display!-time(" Multivariate modular factors found in ", time()-wtime); wtime:=time() >>; fhatvec:=make!-multivariate!-hatvec!-mod!-p(best!-factors!-mod!-p, number!-of!-factors); for i:=1:number!-of!-factors do putv(fvec!-mod!-p,i,getv(best!-factors!-mod!-p,i)); make!-vec!-modular!-symmetric(best!-factors!-mod!-p, number!-of!-factors); for i:=1:number!-of!-factors do << % w1:=getv(coefft!-vectors,i); % putv(best!-known!-factors,i, % merge!-terms(getv(best!-factors!-mod!-p,i),w1)); putv(best!-known!-factors,i, force!-lc(getv(best!-factors!-mod!-p,i),getv(lc!-vec,i))); % Now we put back the LCs before growing the multivariate % factors to be correct over the integers giving the final % result; >>; wtime:=time(); w1:=hensel!-mod!-p( multivariate!-input!-poly, fvec!-mod!-p, best!-known!-factors, get!.coefft!.bound(multivariate!-input!-poly, total!-degree!-in!-powers(multivariate!-input!-poly,nil)), vset!-mod!-p, hensel!-growth!-size); if car w1='overshot then << trace!-time << display!-time(" Full factors failed in ",time()-wtime); wtime:=time() >>; target!-factor!-count:=number!-of!-factors - 1; if target!-factor!-count=1 then irreducible:=t; set!-modulus om; return bad!-case:=t >>; if not(car w1='ok) then errorf w1; trace!-time << display!-time(" Full factors found in ",time()-wtime); wtime:=time() >>; if reconstructing!-gcd then << full!-gcd:=if non!-monic then car primitive!.parts( list getv(cdr w1,1),m!-image!-variable,nil) else getv(cdr w1,1); set!-modulus om; return full!-gcd >>; for i:=1:getv(cdr w1,0) do multivariate!-factors:=getv(cdr w1,i) . multivariate!-factors; if non!-monic then multivariate!-factors:= primitive!.parts(multivariate!-factors,m!-image!-variable,nil); factor!-trace << printstr "The full multivariate factors are:"; for each x in multivariate!-factors do printsf x >>; set!-modulus om; end) (factor!-level*100); symbolic procedure check!-inverted multi!-faclist; begin scalar inv!.sign,l; if inverted then << inv!.sign:=1; multi!-faclist:= for each x in multi!-faclist collect << l:=invert!.poly(x,m!-image!-variable); inv!.sign:=(car l) * inv!.sign; cdr l >>; if not(inv!.sign=inverted!-sign) then errorf list("INVERSION HAS LOST A SIGN",inv!.sign) >>; return multivariate!-factors:=multi!-faclist end; endmodule; module interfac; % Authors: A. C. Norman and P. M. A. Moore, 1981. % Modifications by: Anthony C. Hearn. fluid '(m!-image!-variable poly!-vector polyzero unknowns!-list varlist); %**********************************************************************; % % Routines that are specific to REDUCE. % These are either routines that are not needed in the HASH system % (which is the other algebra system that this factorizer % can be plugged into) or routines that are specifically % redefined in the HASH system. ; %---------------------------------------------------------------------; % The following would normally live in section: ALPHAS %---------------------------------------------------------------------; symbolic procedure assoc!-alpha(poly,alist); assoc(poly,alist); %---------------------------------------------------------------------; % The following would normally live in section: COEFFTS %---------------------------------------------------------------------; symbolic procedure termvector2sf v; begin scalar r,w; for i:=car getv(v,0) step -1 until 1 do << w:=getv(v,i); % degree . coefft; r:=if car w=0 then cdr w else (mksp(m!-image!-variable,car w) .* cdr w) .+ r >>; return r end; symbolic procedure force!-lc(a,n); % force polynomial a to have leading coefficient as specified; (lpow a .* n) .+ red a; symbolic procedure merge!-terms(u,v); merge!-terms1(1,u,v,car getv(v,0)); symbolic procedure merge!-terms1(i,u,v,n); if i#>n then u else begin scalar a,b; a:=getv(v,i); if domainp u or not(mvar u=m!-image!-variable) then if not(car a=0) then errorf list("MERGING COEFFTS FAILED",u,a) else if cdr a then return cdr a else return u; b:=lt u; if tdeg b=car a then return (if cdr a then tpow b .* cdr a else b) .+ merge!-terms1(i #+ 1,red u,v,n) else if tdeg b #> car a then return b .+ merge!-terms1(i,red u,v,n) else errorf list("MERGING COEFFTS FAILED ",u,a) end; symbolic procedure list!-terms!-in!-factor u; % ...; if domainp u then list (0 . nil) else (ldeg u . nil) . list!-terms!-in!-factor red u; symbolic procedure try!-other!-coeffts(r,unknowns!-list,uv); begin scalar ldeg!-r,lc!-r,w; while not domainp r and (r:=red r) and not(w='complete) do << if not depends!-on!-var(r,m!-image!-variable) then << ldeg!-r:=0; lc!-r:=r >> else << ldeg!-r:=ldeg r; lc!-r:=lc r >>; w:=solve!-next!-coefft(ldeg!-r,lc!-r,unknowns!-list,uv) >> end; %---------------------------------------------------------------------; % The following would normally live in section: FACMISC %---------------------------------------------------------------------; symbolic procedure derivative!-wrt!-main!-variable(p,var); % partial derivative of the polynomial p with respect to % its main variable, var; if domainp p or (mvar p neq var) then nil else begin scalar degree; degree:=ldeg p; if degree=1 then return lc p; %degree one term is special; return (mksp(mvar p,degree-1) .* multf(degree,lc p)) .+ derivative!-wrt!-main!-variable(red p,var) end; symbolic procedure fac!-univariatep u; % tests to see if u is univariate; domainp u or not multivariatep(u,mvar u); symbolic procedure variables!.in!.form(a,sofar); if domainp a then sofar else << if not memq(mvar a,sofar) then sofar:=mvar a . sofar; variables!.in!.form(red a, variables!.in!.form(lc a,sofar)) >>; symbolic procedure degree!-in!-variable(p,v); % returns the degree of the polynomial p in the % variable v; if domainp p then 0 else if lc p=0 then errorf "Polynomial with a zero coefficient found" else if v=mvar p then ldeg p else max(degree!-in!-variable(lc p,v), degree!-in!-variable(red p,v)); symbolic procedure get!-height poly; % find height (max coefft) of given poly; if null poly then 0 else if numberp poly then abs poly else max(get!-height lc poly,get!-height red poly); symbolic procedure poly!-minusp a; if a=nil then nil else if domainp a then minusp a else poly!-minusp lc a; symbolic procedure poly!-abs a; if poly!-minusp a then negf a else a; symbolic procedure fac!-printfactors l; % procedure to print the result of factorize!-form; % ie. l is of the form: (c . f) % where c is the numeric content (may be 1) % and f is of the form: ( (f1 . e1) (f2 . e2) ... (fn . en) ) % where the fi's are s.f.s and ei's are numbers; << terpri(); if not (car l = 1) then printsf car l; for each item in cdr l do printsf !*p2f mksp(prepf car item,cdr item) >>; %---------------------------------------------------------------------; % The following would normally live in section: FACPRIM %---------------------------------------------------------------------; symbolic procedure invert!.poly(u,var); % u is a non-trivial primitive square free multivariate polynomial. % assuming var is the top-level variable in u, this effectively % reverses the position of the coeffts: ie % a(n)*var**n + a(n-1)*var**(n-1) + ... + a(0) % becomes: % a(0)*var**n + a(1)*var**(n-1) + ... + a(n) . ; begin scalar w,invert!-sign; w:=invert!.poly1(red u,ldeg u,lc u,var); if poly!-minusp lc w then << w:=negf w; invert!-sign:=-1 >> else invert!-sign:=1; return invert!-sign . w end; symbolic procedure invert!.poly1(u,d,v,var); % d is the degree of the poly we wish to invert. % assume d > ldeg u always, and that v is never nil; if (domainp u) or not (mvar u=var) then (var to d) .* u .+ v else invert!.poly1(red u,d,(var to (d-ldeg u)) .* (lc u) .+ v,var); symbolic procedure trailing!.coefft(u,var); % u is multivariate poly with var as the top-level variable. we find % the trailing coefft - ie the constant wrt var in u; if domainp u then u else if mvar u=var then trailing!.coefft(red u,var) else u; %---------------------------------------------------------------------; % The following would normally live in section: IMAGESET %---------------------------------------------------------------------; symbolic procedure make!-image!-lc!-list(u,imset); reversewoc make!-image!-lc!-list1(u,imset, for each x in imset collect car x); symbolic procedure make!-image!-lc!-list1(u,imset,varlist); % If IMSET=((x1 . a1, x2 . a2, ... , xn . an)) (ordered) where xj is % the variable and aj its value, then this fn creates n images of U wrt % sets S(i) where S(i)= ((x1 . a1), ... , (xi . ai)). The result is an % ordered list of pairs: (u(i) . X(i+1)) where u(i)= U wrt S(i) and % X(i) = (xi, ... , xn) and X(n+1) = NIL. VARLIST = X(1). % (Note. the variables tagged to u(i) should be all those % appearing in u(i) unless it is degenerate). The returned list is % ordered with u(1) first and ending with the number u(n); if null imset then nil else if domainp u then list(!*d2n u . cdr varlist) else if mvar u=caar imset then begin scalar w; w:=horner!-rule!-for!-one!-var( u,caar imset,cdar imset,polyzero,ldeg u) . cdr varlist; return if polyzerop car w then list (0 . cdr w) else (w . make!-image!-lc!-list1(car w,cdr imset,cdr varlist)) end else make!-image!-lc!-list1(u,cdr imset,cdr varlist); symbolic procedure horner!-rule!-for!-one!-var(u,x,val,c,degg); if domainp u or not(mvar u=x) then if zerop val then u else addf(u,multf(c,!*num2f(val**degg))) else begin scalar newdeg; newdeg:=ldeg u; return horner!-rule!-for!-one!-var(red u,x,val, if zerop val then lc u else addf(lc u, multf(c,!*num2f(val**(idifference(degg,newdeg))))), newdeg) end; symbolic procedure make!-image(u,imset); % finds image of u wrt image set, imset, (=association list); if domainp u then u else if mvar u=m!-image!-variable then adjoin!-term(lpow u,!*num2f evaluate!-in!-order(lc u,imset), make!-image(red u,imset)) else !*num2f evaluate!-in!-order(u,imset); symbolic procedure evaluate!-in!-order(u,imset); % makes an image of u wrt imageset, imset, using horner's rule. result % should be purely numeric; if domainp u then !*d2n u else if mvar u=caar imset then horner!-rule(evaluate!-in!-order(lc u,cdr imset), ldeg u,red u,imset) else evaluate!-in!-order(u,cdr imset); symbolic procedure horner!-rule(c,degg,a,vset); % c is running total and a is what is left; if domainp a then if zerop cdar vset then !*d2n a else (!*d2n a)+c*((cdar vset)**degg) else if not(mvar a=caar vset) then if zerop cdar vset then evaluate!-in!-order(a,cdr vset) else evaluate!-in!-order(a,cdr vset)+c*((cdar vset)**degg) else begin scalar newdeg; newdeg:=ldeg a; return horner!-rule(if zerop cdar vset then evaluate!-in!-order(lc a,cdr vset) else evaluate!-in!-order(lc a,cdr vset) +c*((cdar vset)**(idifference(degg,newdeg))),newdeg,red a,vset) end; %---------------------------------------------------------------------; % The following would normally live in section: MHENSFNS %---------------------------------------------------------------------; symbolic procedure max!-degree(u,n); % finds maximum degree of any single variable in U (n is max so far); if domainp u then n else if igreaterp(n,ldeg u) then max!-degree(red u,max!-degree(lc u,n)) else max!-degree(red u,max!-degree(lc u,ldeg u)); symbolic procedure diff!-over!-k!-mod!-p(u,k,v); % derivative of u wrt v divided by k (=number); if domainp u then nil else if mvar u = v then if ldeg u = 1 then quotient!-mod!-p(lc u,modular!-number k) else adjoin!-term(mksp(v,isub1 ldeg u), quotient!-mod!-p( times!-mod!-p(modular!-number ldeg u,lc u), modular!-number k), diff!-over!-k!-mod!-p(red u,k,v)) else adjoin!-term(lpow u, diff!-over!-k!-mod!-p(lc u,k,v), diff!-over!-k!-mod!-p(red u,k,v)); symbolic procedure diff!-k!-times!-mod!-p(u,k,v); % differentiates u k times wrt v and divides by (k!) ie. for each term % a*v**n we get [n k]*a*v**(n-k) if n>=k and nil if n<k where % [n k] is the binomial coefficient; if domainp u then nil else if mvar u = v then if ldeg u < k then nil else if ldeg u = k then lc u else adjoin!-term(mksp(v,ldeg u - k), times!-mod!-p(binomial!-coefft!-mod!-p(ldeg u,k),lc u), diff!-k!-times!-mod!-p(red u,k,v)) else adjoin!-term(lpow u, diff!-k!-times!-mod!-p(lc u,k,v), diff!-k!-times!-mod!-p(red u,k,v)); symbolic procedure spreadvar(u,v,slist); % find all the powers of V in U and merge their degrees into SLIST. % We ignore the constant term wrt V; if domainp u then slist else << if mvar u=v and not member(ldeg u,slist) then slist:=ldeg u . slist; spreadvar(red u,v,spreadvar(lc u,v,slist)) >>; %---------------------------------------------------------------------; % The following would normally live in section: UNIHENS %---------------------------------------------------------------------; symbolic procedure root!-squares(u,sofar); if null u then pmam!-sqrt sofar else if domainp u then pmam!-sqrt(sofar+(u*u)) else root!-squares(red u,sofar+(lc u * lc u)); %---------------------------------------------------------------------; % The following would normally live in section: VECPOLY %---------------------------------------------------------------------; symbolic procedure poly!-to!-vector p; % spread the given univariate polynomial out into POLY-VECTOR; if isdomain p then putv(poly!-vector,0,!*d2n p) else << putv(poly!-vector,ldeg p,lc p); poly!-to!-vector red p >>; symbolic procedure vector!-to!-poly(p,d,v); % Convert the vector P into a polynomial of degree D in variable V; begin scalar r; if d#<0 then return nil; r:=!*n2f getv(p,0); for i:=1:d do if getv(p,i) neq 0 then r:=((v to i) .* getv(p,i)) .+ r; return r end; endmodule; module linmodp; % Authors: A. C. Norman and P. M. A. Moore, 1979; fluid '(current!-modulus prime!-base); %**********************************************************************; % % This section solves linear equations mod p; symbolic procedure lu!-factorize!-mod!-p(a,n); % A is a matrix of size N*N. Overwrite it with its LU factorization; begin scalar w; for i:=1:n do begin scalar ii,pivot; ii:=i; while n>=ii and ((pivot:=getm2(a,ii,i))=0 or iremainder(pivot,prime!-base)=0) do ii := ii+1; if ii>n then return 'singular; if not ii=i then begin scalar temp; temp:=getv(a,i); putv(a,i,getv(a,ii)); putv(a,ii,temp) end; putm2(a,i,0,ii); % Remember pivoting information; pivot:=modular!-reciprocal pivot; putm2(a,i,i,pivot); for j:=i+1:n do putm2(a,i,j,modular!-times(pivot,getm2(a,i,j))); for ii:=i+1:n do begin scalar multiple; multiple:=getm2(a,ii,i); for j:=i+1:n do putm2(a,ii,j,modular!-difference(getm2(a,ii,j), modular!-times(multiple,getm2(a,i,j)))) end end; return w end; symbolic procedure back!-substitute(a,v,n); % A is an N*N matrix as produced by LU-FACTORIZE-MOD-P, and V is % a vector of length N. Overwrite V with solution to linear equations; begin for i:=1:n do begin scalar ii; ii:=getm2(a,i,0); % Pivot control; if ii neq i then begin scalar temp; temp:=getv(v,i); putv(v,i,getv(v,ii)); putv(v,ii,temp) end end; for i:=1:n do begin putv(v,i,times!-mod!-p(!*n2f getm2(a,i,i),getv(v,i))); for ii:=i+1:n do putv(v,ii,difference!-mod!-p(getv(v,ii), times!-mod!-p(getv(v,i),!*n2f getm2(a,ii,i)))) end; % Now do the actual back substitution; for i:=n-1 step -1 until 1 do for j:=i+1:n do putv(v,i,difference!-mod!-p(getv(v,i), times!-mod!-p(!*n2f getm2(a,i,j),getv(v,j)))); return v end; endmodule; module mhensfns; % Authors: A. C. Norman and P. M. A. Moore, 1979; fluid '(!*trfac alphalist current!-modulus degree!-bounds delfvec factor!-level factor!-trace!-list forbidden!-primes hensel!-growth!-size image!-factors max!-unknowns multivariate!-input!-poly non!-monic number!-of!-factors number!-of!-unknowns polyzero prime!-base pt); %**********************************************************************; % This section contains some of the functions used in % the multivariate hensel growth. (ie they are called from % section MULTIHEN or function RECONSTRUCT-MULTIVARIATE-FACTORS). ; symbolic procedure set!-degree!-bounds v; degree!-bounds:=for each var in v collect (car var . degree!-in!-variable(multivariate!-input!-poly,car var)); symbolic procedure get!-degree!-bound v; begin scalar w; w:=atsoc(v,degree!-bounds); if null w then errorf(list("Degree bound not found for ", v," in ",degree!-bounds)); return cdr w end; symbolic procedure choose!-larger!-prime n; % our prime base in the multivariate hensel must be greater than n so % this sets a new prime to be that (previous one was found to be no % good). We also set up various fluids e.g. the Alphas; % the primes we can choose are < 2**24 so if n is bigger % we collapse; if n > 2**24-1 then errorf list("CANNOT CHOOSE PRIME > GIVEN NUMBER:",n) else begin scalar p,flist!-mod!-p,k,fvec!-mod!-p,forbidden!-primes; trynewprime: if p then forbidden!-primes:=p . forbidden!-primes; p:=random!-prime(); % this chooses a word-size prime (currently 24 bits); set!-modulus p; if not(p>n) or member(p,forbidden!-primes) or polyzerop reduce!-mod!-p lc multivariate!-input!-poly then goto trynewprime; for i:=1:number!-of!-factors do flist!-mod!-p:=(reduce!-mod!-p getv(image!-factors,i) . flist!-mod!-p); alphalist:=alphas(number!-of!-factors,flist!-mod!-p,1); if alphalist='factors! not! coprime then goto trynewprime; hensel!-growth!-size:=p; prime!-base:=p; factor!-trace << prin2!* "New prime chosen: "; printstr hensel!-growth!-size >>; k:=number!-of!-factors; fvec!-mod!-p:=mkvect k; for each w in flist!-mod!-p do << putv(fvec!-mod!-p,k,w); k:=isub1 k >>; return fvec!-mod!-p end; symbolic procedure binomial!-coefft!-mod!-p(n,r); if n<r then nil else if n=r then 1 else if r=1 then !*num2f modular!-number n else begin scalar n!-c!-r,b,j; n!-c!-r:=1; b:=min(r,n-r); n:=modular!-number n; r:=modular!-number r; for i:=1:b do << j:=modular!-number i; n!-c!-r:=modular!-quotient( modular!-times(n!-c!-r, modular!-difference(n,modular!-difference(j,1))), j) >>; return !*num2f n!-c!-r end; symbolic procedure make!-multivariate!-hatvec!-mod!-p(bvec,n); % makes a vector whose ith elt is product over j [ BVEC(j) ] / BVEC(i); % NB. we must NOT actually do the division here as we are likely % to be working mod p**n (some n > 1) and the division can involve % a division by p.; begin scalar bhatvec,r; bhatvec:=mkvect n; for i:=1:n do << r:=1; for j:=1:n do if not(j=i) then r:=times!-mod!-p(r,getv(bvec,j)); putv(bhatvec,i,r) >>; return bhatvec end; symbolic procedure max!-degree!-in!-var(fvec,v); begin scalar r,d; r:=0; for i:=1:number!-of!-factors do if r<(d:=degree!-in!-variable(getv(fvec,i),v)) then r:=d; return r end; symbolic procedure make!-growth!-factor pt; % pt is of form (v . n) where v is a variable. we make the s.f. v-n; if cdr pt=0 then !*f2mod !*k2f car pt else plus!-mod!-p(!*f2mod !*k2f car pt,modular!-minus cdr pt); symbolic procedure terms!-done!-mod!-p(fvec,delfvec,delfactor); % calculate the terms introduced by the corrections in DELFVEC; begin scalar flist,delflist; for i:=1:number!-of!-factors do << flist:=getv(fvec,i) . flist; delflist:=getv(delfvec,i) . delflist >>; return terms!-done1!-mod!-p(number!-of!-factors,flist,delflist, number!-of!-factors,delfactor) end; symbolic procedure terms!-done1!-mod!-p(n,flist,delflist,r,m); if n=1 then (car flist) . (car delflist) else begin scalar k,i,f1,f2,delf1,delf2; k:=n/2; i:=1; for each f in flist do << if i>k then f2:=(f . f2) else f1:=(f . f1); i:=i+1 >>; i:=1; for each delf in delflist do << if i>k then delf2:=(delf . delf2) else delf1:=(delf . delf1); i:=i+1 >>; f1:=terms!-done1!-mod!-p(k,f1,delf1,r,m); delf1:=cdr f1; f1:=car f1; f2:=terms!-done1!-mod!-p(n-k,f2,delf2,r,m); delf2:=cdr f2; f2:=car f2; delf1:= plus!-mod!-p(plus!-mod!-p( times!-mod!-p(f1,delf2), times!-mod!-p(f2,delf1)), times!-mod!-p(times!-mod!-p(delf1,m),delf2)); if n=r then return delf1; return (times!-mod!-p(f1,f2) . delf1) end; symbolic procedure primitive!.parts(flist,var,univariate!-inputs); % finds the prim.part of each factor in flist wrt variable var; % Note that FLIST may contain univariate or multivariate S.F.s % (according to UNIVARIATE!-INPUTS) - in the former case we correct the % ALPHALIST if necessary; begin scalar c,primf; if null var then errorf "Must take primitive parts wrt some non-null variable"; if non!-monic then factor!-trace << printstr "Because we multiplied the original primitive"; printstr "polynomial by a multiple of its leading coefficient"; printstr "(see (a) above), the factors we have now are not"; printstr "necessarily primitive. However the required factors"; printstr "are merely their primitive parts." >>; return for each fw in flist collect << if not depends!-on!-var(fw,var) then errorf list("WRONG VARIABLE",var,fw); c:=comfac fw; if car c then errorf(list( "FACTOR DIVISIBLE BY MAIN VARIABLE:",fw,car c)); primf:=quotfail(fw,cdr c); if not(cdr c=1) and univariate!-inputs then multiply!-alphas(cdr c,fw,primf); primf >> end; symbolic procedure make!-predicted!-forms(pfs,v); % PFS is a vector of S.F.s which represents the sparsity of % the associated polynomials wrt V. Here PFS is adjusted to a % suitable form for handling this sparsity. ie. we record the % degrees of V in a vector for each poly in PFS. Each % monomial (in V) represents an unknown (its coefft) in the predicted % form of the associated poly. We count the maximum no of unknowns for % each poly and return the maximum of these; begin scalar l,n,pvec,j,w; max!-unknowns:=0; for i:=1:number!-of!-factors do << w:=getv(pfs,i); % get the ith poly; l:=sort(spreadvar(w,v,nil),function lessp); % Pick out the monomials in V from this poly and order % them in increasing degree; n:=iadd1 length l; % no of unknowns in predicted poly - we add % one for the constant term; number!-of!-unknowns:=(n . i) . number!-of!-unknowns; if max!-unknowns<n then max!-unknowns:=n; pvec:=mkvect isub1 n; % get space for the info on this poly; j:=0; putv(pvec,j,isub1 n); % put in the length of this vector which will vary % from poly to poly; for each m in l do putv(pvec,j:=iadd1 j,m); % put in the monomial info; putv(pfs,i,pvec); % overwrite the S.F. in PFS with the more compact vector; >>; number!-of!-unknowns:=sort(number!-of!-unknowns,function lesspcar); return max!-unknowns end; symbolic procedure make!-correction!-vectors(bfs,n); % set up space for the vector of vectors to hold the correction % terms as we generate them by the function SOLVE-FOR-CORRECTIONS. % Also put in the starting values; begin scalar cvs,cv; cvs:=mkvect number!-of!-factors; for i:=1:number!-of!-factors do << cv:=mkvect n; % each CV will hold the corrections for the ith factor; % the no of corrections we put in here depends on the % maximum no of unknowns we have in the predicted % forms, giving a set of soluble linear systems (hopefully); putv(cv,1,getv(bfs,i)); % put in the first 'corrections'; putv(cvs,i,cv) >>; return cvs end; symbolic procedure construct!-soln!-matrices(pfs,val); % Here we construct the matrices - one for each linear system % we will have to solve to see if our predicted forms of the % answer are correct. Each matrix is a vector of row-vectors % - the ijth elt is in jth slot of ith row-vector (ie zero slots % are not used here); begin scalar soln!-matrix,resvec,n,pv; resvec:=mkvect number!-of!-factors; for i:=1:number!-of!-factors do << pv:=getv(pfs,i); soln!-matrix:=mkvect(n:=iadd1 getv(pv,0)); construct!-ith!-matrix(soln!-matrix,pv,n,val); putv(resvec,i,soln!-matrix) >>; return resvec end; symbolic procedure construct!-ith!-matrix(sm,pv,n,val); begin scalar mv; mv:=mkvect n; % this will be the first row; putv(mv,1,1); % the first column represents the constant term; for j:=2:n do putv(mv,j,modular!-expt(val,getv(pv,isub1 j))); % first row is straight substitution; putv(sm,1,mv); % now for the rest of the rows: ; for j:=2:n do << mv:=mkvect n; putv(mv,1,0); construct!-matrix!-row(mv,isub1 j,pv,n,val); putv(sm,j,mv) >> end; symbolic procedure construct!-matrix!-row(mrow,j,pv,n,val); begin scalar d; for k:=2:n do << d:=getv(pv,isub1 k); % degree representing the monomial; if d<j then putv(mrow,k,0) else << d:=modular!-times(!*d2n binomial!-coefft!-mod!-p(d,j), modular!-expt(val,idifference(d,j))); % differentiate and substitute all at once; putv(mrow,k,d) >> >> end; symbolic procedure print!-linear!-systems(soln!-m,correction!-v, predicted!-f,v); << for i:=1:number!-of!-factors do print!-linear!-system(i,soln!-m,correction!-v,predicted!-f,v); terpri!*(nil) >>; symbolic procedure print!-linear!-system(i,soln!-m,correction!-v, predicted!-f,v); begin scalar pv,sm,cv,mr,n,tt; terpri!*(t); prin2!* " i = "; printstr i; terpri!*(nil); sm:=getv(soln!-m,i); cv:=getv(correction!-v,i); pv:=getv(predicted!-f,i); n:=iadd1 getv(pv,0); for j:=1:n do << % for each row in matrix ... ; prin2!* "( "; tt:=2; mr:=getv(sm,j); % matrix row; for k:=1:n do << % for each elt in row ... ; prin2!* getv(mr,k); ttab!* (tt:=tt+10) >>; prin2!* ") ( ["; if j=1 then prin2!* 1 else prinsf adjoin!-term(mksp(v,getv(pv,isub1 j)),1,polyzero); prin2!* "]"; ttab!* (tt:=tt+10); prin2!* " )"; if j=(n/2) then prin2!* " = ( " else prin2!* " ( "; prinsf getv(cv,j); ttab!* (tt:=tt+30); printstr ")"; if not(j=n) then << tt:=2; prin2!* "("; ttab!* (tt:=tt+n*10); prin2!* ") ("; ttab!* (tt:=tt+10); prin2!* " ) ("; ttab!* (tt:=tt+30); printstr ")" >> >>; terpri!*(t) end; symbolic procedure try!-prediction(sm,cv,pv,n,i,poly,v,ff,ffhat); begin scalar w,ffi,fhati; sm:=getv(sm,i); cv:=getv(cv,i); pv:=getv(pv,i); if not(n=iadd1 getv(pv,0)) then errorf list("Predicted unknowns gone wrong? ",n,iadd1 getv(pv,0)); if null getm2(sm,1,0) then << w:=lu!-factorize!-mod!-p(sm,n); if w='singular then << factor!-trace << prin2!* "Prediction for "; prin2!* if null ff then 'f else 'a; prin2!* "("; prin2!* i; printstr ") failed due to singular matrix." >>; return (w . i) >> >>; back!-substitute(sm,cv,n); w:= if null ff then try!-factor(poly,cv,pv,n,v) else << ffi := getv(ff,i); fhati := getv(ffhat,i); % The unfolding here is to get round % a bug in the PSL compiler 12/9/82. It % will be tidied back up as soon as % possible; try!-alpha(poly,cv,pv,n,v,ffi,fhati) >>; if w='bad!-prediction then << factor!-trace << prin2!* "Prediction for "; prin2!* if null ff then 'f else 'a; prin2!* "("; prin2!* i; printstr ") was an inadequate guess." >>; return (w . i) >>; factor!-trace << prin2!* "Prediction for "; prin2!* if null ff then 'f else 'a; prin2!* "("; prin2!* i; prin2!* ") worked: "; printsf car w >>; return (i . w) end; symbolic procedure try!-factor(poly,testv,predictedf,n,v); begin scalar r,w; r:=getv(testv,1); for j:=2:n do << w:=!*f2mod adjoin!-term(mksp(v,getv(predictedf,isub1 j)),1, polyzero); r:=plus!-mod!-p(r,times!-mod!-p(w,getv(testv,j))) >>; w:=quotient!-mod!-p(poly,r); if didntgo w or not polyzerop difference!-mod!-p(poly,times!-mod!-p(w,r)) then return 'bad!-prediction else return list(r,w) end; symbolic procedure try!-alpha(poly,testv,predictedf,n,v,fi,fhati); begin scalar r,w,wr; r:=getv(testv,1); for j:=2:n do << w:=!*f2mod adjoin!-term(mksp(v,getv(predictedf,isub1 j)),1, polyzero); r:=plus!-mod!-p(r,times!-mod!-p(w,getv(testv,j))) >>; if polyzerop (wr:=difference!-mod!-p(poly,times!-mod!-p(r,fhati))) then return list (r,wr); w:=quotient!-mod!-p(wr,fi); if didntgo w or not polyzerop difference!-mod!-p(wr,times!-mod!-p(w,fi)) then return 'bad!-prediction else return list(r,wr) end; endmodule; module modpoly; % Authors: A. C. Norman and P. M. A. Moore, 1979; fluid '(current!-modulus exact!-quotient!-flag m!-image!-variable modulus!/2 reduction!-count); %**********************************************************************; % routines for performing arithmetic on multivariate % polynomials with coefficients that are modular % numbers as defined by modular!-plus etc; % note that the datastructure used is the same as that used in % REDUCE except that it is assumed that domain elements are atomic; symbolic procedure plus!-mod!-p(a,b); % form the sum of the two polynomials a and b % working over the ground domain defined by the routines % modular!-plus, modular!-times etc. the inputs to this % routine are assumed to have coefficients already % in the required domain; if null a then b else if null b then a else if isdomain a then if isdomain b then !*num2f modular!-plus(a,b) else (lt b) .+ plus!-mod!-p(a,red b) else if isdomain b then (lt a) .+ plus!-mod!-p(red a,b) else if lpow a = lpow b then adjoin!-term(lpow a, plus!-mod!-p(lc a,lc b),plus!-mod!-p(red a,red b)) else if comes!-before(lpow a,lpow b) then (lt a) .+ plus!-mod!-p(red a,b) else (lt b) .+ plus!-mod!-p(a,red b); symbolic procedure times!-mod!-p(a,b); if (null a) or (null b) then nil else if isdomain a then multiply!-by!-constant!-mod!-p(b,a) else if isdomain b then multiply!-by!-constant!-mod!-p(a,b) else if mvar a=mvar b then plus!-mod!-p( plus!-mod!-p(times!-term!-mod!-p(lt a,b), times!-term!-mod!-p(lt b,red a)), times!-mod!-p(red a,red b)) else if ordop(mvar a,mvar b) then adjoin!-term(lpow a,times!-mod!-p(lc a,b),times!-mod!-p(red a,b)) else adjoin!-term(lpow b, times!-mod!-p(a,lc b),times!-mod!-p(a,red b)); symbolic procedure times!-term!-mod!-p(term,b); %multiply the given polynomial by the given term; if null b then nil else if isdomain b then adjoin!-term(tpow term, multiply!-by!-constant!-mod!-p(tc term,b),nil) else if tvar term=mvar b then adjoin!-term(mksp(tvar term,iplus(tdeg term,ldeg b)), times!-mod!-p(tc term,lc b), times!-term!-mod!-p(term,red b)) else if ordop(tvar term,mvar b) then adjoin!-term(tpow term,times!-mod!-p(tc term,b),nil) else adjoin!-term(lpow b, times!-term!-mod!-p(term,lc b), times!-term!-mod!-p(term,red b)); symbolic procedure difference!-mod!-p(a,b); plus!-mod!-p(a,minus!-mod!-p b); symbolic procedure minus!-mod!-p a; if null a then nil else if isdomain a then modular!-minus a else (lpow a .* minus!-mod!-p lc a) .+ minus!-mod!-p red a; symbolic procedure reduce!-mod!-p a; %converts a multivariate poly from normal into modular polynomial; if null a then nil else if isdomain a then !*num2f modular!-number a else adjoin!-term(lpow a,reduce!-mod!-p lc a,reduce!-mod!-p red a); symbolic procedure monic!-mod!-p a; % This procedure can only cope with polys that have a numeric % leading coeff; if a=nil then nil else if isdomain a then 1 else if lc a = 1 then a else if not domainp lc a then errorf "LC NOT NUMERIC IN MONIC-MOD-P" else multiply!-by!-constant!-mod!-p(a, modular!-reciprocal lc a); symbolic procedure quotfail!-mod!-p(a,b); % Form quotient A/B, but complain if the division is % not exact; begin scalar c; exact!-quotient!-flag:=t; c:=quotient!-mod!-p(a,b); if exact!-quotient!-flag then return c else errorf "QUOTIENT NOT EXACT (MOD P)" end; symbolic procedure quotient!-mod!-p(a,b); % truncated quotient of a by b; if null b then errorf "B=0 IN QUOTIENT-MOD-P" else if isdomain b then multiply!-by!-constant!-mod!-p(a, modular!-reciprocal b) else if a=nil then nil else if isdomain a then exact!-quotient!-flag:=nil else if mvar a=mvar b then xquotient!-mod!-p(a,b,mvar b) else if ordop(mvar a,mvar b) then adjoin!-term(lpow a, quotient!-mod!-p(lc a,b), quotient!-mod!-p(red a,b)) else exact!-quotient!-flag:=nil; symbolic procedure xquotient!-mod!-p(a,b,v); % truncated quotient a/b given that b is nontrivial; if a=nil then nil else if (isdomain a) or (not mvar a=v) or ilessp(ldeg a,ldeg b) then exact!-quotient!-flag:=nil else if ldeg a = ldeg b then begin scalar w; w:=quotient!-mod!-p(lc a,lc b); if difference!-mod!-p(a,times!-mod!-p(w,b)) then exact!-quotient!-flag:=nil; return w end else begin scalar term; term:=mksp(mvar a,idifference(ldeg a,ldeg b)) .* quotient!-mod!-p(lc a,lc b); %that is the leading term of the quotient. now subtract %term*b from a; a:=plus!-mod!-p(red a, times!-term!-mod!-p(negate!-term term,red b)); % or a:=a-b*term given leading terms must cancel; return term .+ xquotient!-mod!-p(a,b,v) end; symbolic procedure negate!-term term; % negate a term; tpow term .* minus!-mod!-p tc term; symbolic procedure remainder!-mod!-p(a,b); % remainder when a is divided by b; if null b then errorf "B=0 IN REMAINDER-MOD-P" else if isdomain b then nil else if isdomain a then a else xremainder!-mod!-p(a,b,mvar b); symbolic procedure xremainder!-mod!-p(a,b,v); % remainder when the modular polynomial a is % divided by b, given that b is non degenerate; if (isdomain a) or (not mvar a=v) or ilessp(ldeg a,ldeg b) then a else begin scalar q,w; q:=quotient!-mod!-p(minus!-mod!-p lc a,lc b); % compute -lc of quotient; w:=idifference(ldeg a,ldeg b); %ldeg of quotient; if w=0 then a:=plus!-mod!-p(red a, multiply!-by!-constant!-mod!-p(red b,q)) else a:=plus!-mod!-p(red a,times!-term!-mod!-p( mksp(mvar b,w) .* q,red b)); % the above lines of code use red a and red b because % by construction the leading terms of the required % answers will cancel out; return xremainder!-mod!-p(a,b,v) end; symbolic procedure multiply!-by!-constant!-mod!-p(a,n); % multiply the polynomial a by the constant n; if null a then nil else if n=1 then a else if isdomain a then !*num2f modular!-times(a,n) else adjoin!-term(lpow a,multiply!-by!-constant!-mod!-p(lc a,n), multiply!-by!-constant!-mod!-p(red a,n)); symbolic procedure gcd!-mod!-p(a,b); % return the monic gcd of the two modular univariate % polynomials a and b. Set REDUCTION-COUNT to the number % of steps taken in the process; << reduction!-count := 0; if null a then monic!-mod!-p b else if null b then monic!-mod!-p a else if isdomain a then 1 else if isdomain b then 1 else if igreaterp(ldeg a,ldeg b) then ordered!-gcd!-mod!-p(a,b) else ordered!-gcd!-mod!-p(b,a) >>; symbolic procedure ordered!-gcd!-mod!-p(a,b); % as above, but deg a > deg b; begin scalar steps; steps := 0; top: a := reduce!-degree!-mod!-p(a,b); if null a then return monic!-mod!-p b; steps := steps + 1; if domainp a then << reduction!-count := reduction!-count+steps; return 1 >> else if ldeg a<ldeg b then begin scalar w; reduction!-count := reduction!-count + steps; steps := 0; w := a; a := b; b := w end; go to top end; symbolic procedure reduce!-degree!-mod!-p(a,b); % Compute A-Q*B where Q is a single term chosen so that the result % has lower degree than A did; begin scalar q,w; q:=modular!-quotient(modular!-minus lc a,lc b); % compute -lc of quotient; w:=idifference(ldeg a,ldeg b); %ldeg of quotient; % the next lines of code use red a and red b because % by construction the leading terms of the required % answers will cancel out; if w=0 then return plus!-mod!-p(red a, multiply!-by!-constant!-mod!-p(red b,q)) else return plus!-mod!-p(red a,times!-term!-mod!-p( mksp(mvar b,w) .* q,red b)) end; symbolic procedure derivative!-mod!-p a; % derivative of a wrt its main variable; if isdomain a then nil else if ldeg a=1 then lc a else derivative!-mod!-p!-1(a,mvar a); symbolic procedure derivative!-mod!-p!-1(a,v); if isdomain a then nil else if not mvar a=v then nil else if ldeg a=1 then lc a else adjoin!-term(mksp(v,isub1 ldeg a), multiply!-by!-constant!-mod!-p(lc a, modular!-number ldeg a), derivative!-mod!-p!-1(red a,v)); symbolic procedure square!-free!-mod!-p a; % predicate that tests if a is square-free as a modular % univariate polynomial; if isdomain a then t else isdomain gcd!-mod!-p(a,derivative!-mod!-p a); symbolic procedure evaluate!-mod!-p(a,v,n); % evaluate polynomial A at the point V=N; if isdomain a then a else if n=0 then evaluate!-mod!-p(a,v,nil) else if v=nil then errorf "Variable=NIL in EVALUATE-MOD-P" else if mvar a=v then horner!-rule!-mod!-p(lc a,ldeg a,red a,n,v) else adjoin!-term(lpow a, evaluate!-mod!-p(lc a,v,n), evaluate!-mod!-p(red a,v,n)); symbolic procedure horner!-rule!-mod!-p(v,degg,a,n,var); % v is the running total, and it must be multiplied by % n**deg and added to the value of a at n; if isdomain a or not mvar a=var then if null n or zerop n then a else <<v:=times!-mod!-p(v,expt!-mod!-p(n,degg)); plus!-mod!-p(a,v)>> else begin scalar newdeg; newdeg:=ldeg a; return horner!-rule!-mod!-p(if null n or zerop n then lc a else plus!-mod!-p(lc a, times!-mod!-p(v,expt!-mod!-p(n,idifference(degg,newdeg)))), newdeg,red a,n,var) end; symbolic procedure expt!-mod!-p(a,n); % a**n; if n=0 then 1 else if n=1 then a else begin scalar w,x; w:=divide(n,2); x:=expt!-mod!-p(a,car w); x:=times!-mod!-p(x,x); if not (cdr w = 0) then x:=times!-mod!-p(x,a); return x end; symbolic procedure make!-bivariate!-mod!-p(u,imset,v); % Substitute into U for all variables in IMSET which should result in % a bivariate poly. One variable is M-IMAGE-VARIABLE and V is the other % U is modular multivariate with these two variables at top 2 levels % - V at 2nd level; if domainp u then u else if mvar u = m!-image!-variable then adjoin!-term(lpow u,make!-univariate!-mod!-p(lc u,imset,v), make!-bivariate!-mod!-p(red u,imset,v)) else make!-univariate!-mod!-p(u,imset,v); symbolic procedure make!-univariate!-mod!-p(u,imset,v); % Substitute into U for all variables in IMSET giving a univariate % poly in V. U is modular multivariate with V at top level; if domainp u then u else if mvar u = v then adjoin!-term(lpow u,!*num2f evaluate!-in!-order!-mod!-p(lc u,imset), make!-univariate!-mod!-p(red u,imset,v)) else !*num2f evaluate!-in!-order!-mod!-p(u,imset); symbolic procedure evaluate!-in!-order!-mod!-p(u,imset); % makes an image of u wrt imageset, imset, using horner's rule. result % should be purely numeric (and modular); if domainp u then !*d2n u else if mvar u=caar imset then horner!-rule!-in!-order!-mod!-p( evaluate!-in!-order!-mod!-p(lc u,cdr imset),ldeg u,red u,imset) else evaluate!-in!-order!-mod!-p(u,cdr imset); symbolic procedure horner!-rule!-in!-order!-mod!-p(c,degg,a,vset); % c is running total and a is what is left; if domainp a then modular!-plus(!*d2n a, modular!-times(c,modular!-expt(cdar vset,degg))) else if not(mvar a=caar vset) then modular!-plus( evaluate!-in!-order!-mod!-p(a,cdr vset), modular!-times(c,modular!-expt(cdar vset,degg))) else begin scalar newdeg; newdeg:=ldeg a; return horner!-rule!-in!-order!-mod!-p( modular!-plus( evaluate!-in!-order!-mod!-p(lc a,cdr vset), modular!-times(c, modular!-expt(cdar vset,(idifference(degg,newdeg))))), newdeg,red a,vset) end; symbolic procedure make!-modular!-symmetric a; % input is a multivariate MODULAR poly A with nos in the range 0->(p-1). % This folds it onto the symmetric range (-p/2)->(p/2); if null a then nil else if domainp a then if a>modulus!/2 then !*num2f(a - current!-modulus) else a else adjoin!-term(lpow a,make!-modular!-symmetric lc a, make!-modular!-symmetric red a); endmodule; module multihen; % Authors: A. C. Norman and P. M. A. Moore, 1979. fluid '(!*overshoot !*trfac alphavec bad!-case factor!-level factor!-trace!-list fhatvec hensel!-growth!-size max!-unknowns number!-of!-factors number!-of!-unknowns predictions residue); %**********************************************************************; % hensel construction for the multivariate case % (this version is highly recursive); symbolic procedure find!-multivariate!-factors!-mod!-p(poly, best!-factors,variable!-set); % All arithmetic is done mod p, best-factors is overwritten; if null variable!-set then best!-factors else (lambda factor!-level; begin scalar growth!-factor,b0s,res,correction!-factor,v, bhat0s,w,degbd,first!-time,redpoly, predicted!-forms,number!-of!-unknowns,solve!-count, correction!-vectors,soln!-matrices,max!-unknowns, unknowns!-count!-list,test!-prediction,poly!-remaining, prediction!-results,one!-prediction!-failed; v:=car variable!-set; degbd:=get!-degree!-bound car v; first!-time:=t; growth!-factor:=make!-growth!-factor v; poly!-remaining:=poly; prediction!-results:=mkvect number!-of!-factors; find!-msg1(best!-factors,growth!-factor,poly); b0s:=reduce!-vec!-by!-one!-var!-mod!-p(best!-factors, v,number!-of!-factors); % The above made a copy of the vector; for i:=1:number!-of!-factors do putv(best!-factors,i, difference!-mod!-p(getv(best!-factors,i),getv(b0s,i))); redpoly:=evaluate!-mod!-p(poly,car v,cdr v); find!-msg2(v,variable!-set); find!-multivariate!-factors!-mod!-p(redpoly,b0s,cdr variable!-set); % answers in b0s; if bad!-case then return; for i:=1:number!-of!-factors do putv(best!-factors,i, plus!-mod!-p(getv(b0s,i),getv(best!-factors,i))); find!-msg3(best!-factors,v); res:=diff!-over!-k!-mod!-p( difference!-mod!-p(poly, times!-vector!-mod!-p(best!-factors,number!-of!-factors)), 1,car v); % RES is the residue and must eventually be reduced to zero; factor!-trace << printsf res; terpri!*(nil) >>; if not polyzerop res and cdr variable!-set and not zerop cdr v then << predicted!-forms:=make!-bivariate!-vec!-mod!-p(best!-factors, cdr variable!-set,car v,number!-of!-factors); find!-multivariate!-factors!-mod!-p( make!-bivariate!-mod!-p(poly,cdr variable!-set,car v), predicted!-forms,list v); % Answers in PREDICTED!-FORMS. find!-msg4(predicted!-forms,v); make!-predicted!-forms(predicted!-forms,car v); % Sets max!-unknowns and number!-of!-unknowns. find!-msg5(); unknowns!-count!-list:=number!-of!-unknowns; while unknowns!-count!-list and (car (w:=car unknowns!-count!-list))=1 do begin scalar i,r; unknowns!-count!-list:=cdr unknowns!-count!-list; i:=cdr w; w:=quotient!-mod!-p(poly!-remaining,r:=getv(best!-factors,i)); if didntgo w or not polyzerop difference!-mod!-p(poly!-remaining, times!-mod!-p(w,r)) then if one!-prediction!-failed then << factor!-trace printstr "Predictions are no good"; max!-unknowns:=nil >> else << factor!-trace << prin2!* "Guess for f("; prin2!* i; printstr ") was bad." >>; one!-prediction!-failed:=i >> else << putv(prediction!-results,i,r); factor!-trace << prin2!* "Prediction for f("; prin2!* i; prin2!* ") worked: "; printsf r >>; poly!-remaining:=w >> end; w:=length unknowns!-count!-list; if w=1 and not one!-prediction!-failed then << putv(best!-factors,cdar unknowns!-count!-list,poly!-remaining); go to exit >> else if w=0 and one!-prediction!-failed then << putv(best!-factors,one!-prediction!-failed,poly!-remaining); go to exit >>; solve!-count:=1; if max!-unknowns then correction!-vectors:= make!-correction!-vectors(best!-factors,max!-unknowns) >>; bhat0s:=make!-multivariate!-hatvec!-mod!-p(b0s,number!-of!-factors); correction!-factor:=growth!-factor; % next power of growth-factor we are % adding to the factors; % Now branch to another function to make this one not so huge. return find!-multi1(list(res, test!-prediction, growth!-factor, first!-time, bhat0s, b0s, variable!-set, solve!-count, correction!-vectors, unknowns!-count!-list, correction!-factor, best!-factors, v, degbd, soln!-matrices, predicted!-forms, poly!-remaining, prediction!-results, one!-prediction!-failed)); exit: find!-exit(best!-factors,first!-time); end) (factor!-level+1); symbolic procedure find!-multi1(u); begin scalar res,test!-prediction,growth!-factor,first!-time,bhat0s, b0s,variable!-set,solve!-count,correction!-vectors, unknowns!-count!-list,correction!-factor,best!-factors,v, degbd,soln!-matrices,predicted!-forms,poly!-remaining, prediction!-results,one!-prediction!-failed, b1,bool,d,k,kk,substres,w; res := car u; u := cdr u; test!-prediction := car u; u := cdr u; growth!-factor := car u; u := cdr u; first!-time := car u; u := cdr u; bhat0s := car u; u := cdr u; b0s := car u; u := cdr u; variable!-set := car u; u := cdr u; solve!-count := car u; u := cdr u; correction!-vectors := car u; u := cdr u; unknowns!-count!-list := car u; u := cdr u; correction!-factor := car u; u := cdr u; best!-factors := car u; u := cdr u; v := car u; u := cdr u; degbd := car u; u := cdr u; soln!-matrices := car u; u := cdr u; predicted!-forms := car u; u := cdr u; poly!-remaining := car u; u := cdr u; prediction!-results := car u; u := cdr u; one!-prediction!-failed := car u; b1:=mkvect number!-of!-factors; k:=1; kk:=0; temploop: bool := nil; while not bool and not polyzerop res and (null max!-unknowns or null test!-prediction) do if k>degbd then << factor!-trace << prin2!* "We have overshot the degree bound for "; printvar car v >>; if !*overshoot then printc "Multivariate degree bound overshoot -> restart"; bad!-case:= bool := t >> else if polyzerop(substres:=evaluate!-mod!-p(res,car v,cdr v)) then << k:=iadd1 k; res:=diff!-over!-k!-mod!-p(res,k,car v); correction!-factor:= times!-mod!-p(correction!-factor,growth!-factor) >> else begin find!-msg6(growth!-factor,first!-time,k,kk,substres); kk := kk#+1; if first!-time then first!-time := nil; solve!-for!-corrections(substres,bhat0s,b0s,b1, cdr variable!-set); % Answers left in B1; if bad!-case then return (bool := t); if max!-unknowns then << solve!-count:=iadd1 solve!-count; for i:=1:number!-of!-factors do putv(getv(correction!-vectors,i),solve!-count,getv(b1,i)); if solve!-count=caar unknowns!-count!-list then test!-prediction:=t >>; factor!-trace << printstr " Giving:"; printvec(" f(",number!-of!-factors,",1) = ",b1) >>; d:=times!-mod!-p(correction!-factor, terms!-done!-mod!-p(best!-factors,b1,correction!-factor)); if degree!-in!-variable(d,car v)>degbd then << factor!-trace << prin2!* "We have overshot the degree bound for "; printvar car v >>; if !*overshoot then printc "Multivariate degree bound overshoot -> restart"; bad!-case:=t; return (bool := t)>>; d:=diff!-k!-times!-mod!-p(d,k,car v); for i:=1:number!-of!-factors do putv(best!-factors,i, plus!-mod!-p(getv(best!-factors,i), times!-mod!-p(getv(b1,i),correction!-factor))); k:=iadd1 k; res:=diff!-over!-k!-mod!-p(difference!-mod!-p(res,d),k,car v); factor!-trace << printstr " New factors are now:"; printvec(" f(",number!-of!-factors,") = ",best!-factors); prin2!* " and residue = "; printsf res; printstr "-------------" >>; correction!-factor:= times!-mod!-p(correction!-factor,growth!-factor) end; if not polyzerop res and not bad!-case then << soln!-matrices:=construct!-soln!-matrices(predicted!-forms,cdr v); factor!-trace << printstr "We use the results from the Hensel growth to"; printstr "produce a set of linear equations to solve"; printstr "for coefficients in the relevent factors:" >>; bool := nil; while not bool and unknowns!-count!-list and (car (w:=car unknowns!-count!-list))=solve!-count do << unknowns!-count!-list:=cdr unknowns!-count!-list; factor!-trace print!-linear!-system(cdr w,soln!-matrices, correction!-vectors,predicted!-forms,car v); w:=try!-prediction(soln!-matrices,correction!-vectors, predicted!-forms,car w,cdr w,poly!-remaining,car v, nil,nil); if car w='singular or car w='bad!-prediction then if one!-prediction!-failed then << factor!-trace printstr "Predictions were no help."; max!-unknowns:=nil; bool := t>> else one!-prediction!-failed:=cdr w else << putv(prediction!-results,car w,cadr w); poly!-remaining:=caddr w >> >>; if null max!-unknowns then goto temploop; w:=length unknowns!-count!-list; if w>1 or (w=1 and one!-prediction!-failed) then << test!-prediction:=nil; goto temploop >>; if w=1 or one!-prediction!-failed then << w:=if one!-prediction!-failed then one!-prediction!-failed else cdar unknowns!-count!-list; putv(prediction!-results,w,poly!-remaining) >>; for i:=1:number!-of!-factors do putv(best!-factors,i,getv(prediction!-results,i)); if not one!-prediction!-failed then predictions:= (car v . list(soln!-matrices,predicted!-forms,max!-unknowns, number!-of!-unknowns)) . predictions >>; find!-exit(best!-factors,first!-time); end; symbolic procedure find!-msg1(best!-factors,growth!-factor,poly); factor!-trace << printstr "Want f(i) s.t."; prin2!* " product over i [ f(i) ] = "; prinsf poly; prin2!* " mod "; printstr hensel!-growth!-size; terpri!*(nil); printstr "We know f(i) as follows:"; printvec(" f(",number!-of!-factors,") = ",best!-factors); prin2!* " and we shall put in powers of "; prinsf growth!-factor; printstr " to find them fully." >>; symbolic procedure find!-msg2(v,variable!-set); factor!-trace << prin2!* "First solve the problem in one less variable by putting "; prinvar car v; prin2!* "="; printstr cdr v; if cdr variable!-set then << prin2!* "and growing wrt "; printvar caadr variable!-set >>; terpri!*(nil) >>; symbolic procedure find!-msg3(best!-factors,v); factor!-trace << prin2!* "After putting back any knowledge of "; prinvar car v; printstr ", we have the"; printstr "factors so far as:"; printvec(" f(",number!-of!-factors,") = ",best!-factors); printstr "Subtracting the product of these from the polynomial"; prin2!* "and differentiating wrt "; prinvar car v; printstr " gives a residue:" >>; symbolic procedure find!-msg4(predicted!-forms,v); factor!-trace << printstr "To help reduce the number of Hensel steps we try"; prin2!* "predicting how many terms each factor will have wrt "; prinvar car v; printstr "."; printstr "Predictions are based on the bivariate factors :"; printvec(" f(",number!-of!-factors,") = ",predicted!-forms) >>; symbolic procedure find!-msg5; factor!-trace << terpri!*(nil); printstr "We predict :"; for each w in number!-of!-unknowns do << prin2!* car w; prin2!* " terms in f("; prin2!* cdr w; printstr '!) >>; if (caar number!-of!-unknowns)=1 then << prin2!* "Since we predict only one term for f("; prin2!* cdar number!-of!-unknowns; printstr "), we can try"; printstr "dividing it out now:" >> else << prin2!* "So we shall do at least "; prin2!* isub1 caar number!-of!-unknowns; prin2!* " Hensel step"; if (caar number!-of!-unknowns)=2 then printstr "." else printstr "s." >>; terpri!*(nil) >>; symbolic procedure find!-msg6(growth!-factor,first!-time,k,kk,substres); factor!-trace << prin2!* "Hensel Step "; printstr (kk:=kk #+ 1); prin2!* "-------------"; if kk>10 then printstr "-" else terpri!*(t); prin2!* "Next corrections are for ("; prinsf growth!-factor; if not (k=1) then << prin2!* ") ** "; prin2!* k >> else prin2!* '!); printstr ". To find these we solve:"; prin2!* " sum over i [ f(i,1)*fhat(i,0) ] = "; prinsf substres; prin2!* " mod "; prin2!* hensel!-growth!-size; printstr " for f(i,1), "; if first!-time then << prin2!* " where fhat(i,0) = product over j [ f(j,0) ]"; prin2!* " / f(i,0) mod "; printstr hensel!-growth!-size >>; terpri!*(nil) >>; symbolic procedure find!-exit(best!-factors,first!-time); factor!-trace << if not bad!-case then if first!-time then printstr "Therefore these factors are already correct." else << printstr "Correct factors are:"; printvec(" f(",number!-of!-factors,") = ",best!-factors) >>; terpri!*(nil); printstr "******************************************************"; terpri!*(nil) >>; symbolic procedure solve!-for!-corrections(c,fhatvec,fvec,resvec,vset); % ....; if null vset then for i:=1:number!-of!-factors do putv(resvec,i, remainder!-mod!-p( times!-mod!-p(c,getv(alphavec,i)), getv(fvec,i))) else (lambda factor!-level; begin scalar residue,growth!-factor,f0s,fhat0s,v, correction!-factor,degbd,first!-time,redc, predicted!-forms,max!-unknowns,solve!-count,number!-of!-unknowns, correction!-vectors,soln!-matrices,w,previous!-prediction!-holds, unknowns!-count!-list,test!-prediction,poly!-remaining, prediction!-results,one!-prediction!-failed; v:=car vset; degbd:=get!-degree!-bound car v; first!-time:=t; growth!-factor:=make!-growth!-factor v; poly!-remaining:=c; prediction!-results:=mkvect number!-of!-factors; redc:=evaluate!-mod!-p(c,car v,cdr v); solve!-msg1(c,fvec,v); solve!-for!-corrections(redc, fhat0s:=reduce!-vec!-by!-one!-var!-mod!-p( fhatvec,v,number!-of!-factors), f0s:=reduce!-vec!-by!-one!-var!-mod!-p( fvec,v,number!-of!-factors), resvec, cdr vset); % Results left in RESVEC; if bad!-case then return; solve!-msg2(resvec,v); residue:=diff!-over!-k!-mod!-p(difference!-mod!-p(c, form!-sum!-and!-product!-mod!-p(resvec,fhatvec, number!-of!-factors)),1,car v); factor!-trace << printsf residue; prin2!* " Now we shall put in the powers of "; prinsf growth!-factor; printstr " to find the a's fully." >>; if not polyzerop residue and not zerop cdr v then << w:=atsoc(car v,predictions); if w then << previous!-prediction!-holds:=t; factor!-trace << printstr "We shall use the previous prediction for the form of"; prin2!* "polynomials wrt "; printvar car v >>; w:=cdr w; soln!-matrices:=car w; predicted!-forms:=cadr w; max!-unknowns:=caddr w; number!-of!-unknowns:=cadr cddr w >> else << factor!-trace << printstr "We shall use a new prediction for the form of polynomials "; prin2!* "wrt "; printvar car v >>; predicted!-forms:=mkvect number!-of!-factors; for i:=1:number!-of!-factors do putv(predicted!-forms,i,getv(fvec,i)); % make a copy of the factors in a vector that we shall % overwrite; make!-predicted!-forms(predicted!-forms,car v); % sets max!-unknowns and number!-of!-unknowns; >>; solve!-msg3(); unknowns!-count!-list:=number!-of!-unknowns; while unknowns!-count!-list and (car (w:=car unknowns!-count!-list))=1 do begin scalar i,r,wr,fi; unknowns!-count!-list:=cdr unknowns!-count!-list; i:=cdr w; w:=quotient!-mod!-p( wr:=difference!-mod!-p(poly!-remaining, times!-mod!-p(r:=getv(resvec,i),getv(fhatvec,i))), fi:=getv(fvec,i)); if didntgo w or not polyzerop difference!-mod!-p(wr,times!-mod!-p(w,fi)) then if one!-prediction!-failed then << factor!-trace printstr "Predictions are no good."; max!-unknowns:=nil >> else << factor!-trace << prin2!* "Guess for a("; prin2!* i; printstr ") was bad." >>; one!-prediction!-failed:=i >> else << putv(prediction!-results,i,r); factor!-trace << prin2!* "Prediction for a("; prin2!* i; prin2!* ") worked: "; printsf r >>; poly!-remaining:=wr >> end; w:=length unknowns!-count!-list; if w=1 and not one!-prediction!-failed then << putv(resvec,cdar unknowns!-count!-list, quotfail!-mod!-p(poly!-remaining,getv(fhatvec, cdar unknowns!-count!-list))); go to exit >> else if w=0 and one!-prediction!-failed then << putv(resvec,one!-prediction!-failed, quotfail!-mod!-p(poly!-remaining,getv(fhatvec, one!-prediction!-failed))); go to exit >>; solve!-count:=1; if max!-unknowns then correction!-vectors:= make!-correction!-vectors(resvec,max!-unknowns) >>; correction!-factor:=growth!-factor; if not polyzerop residue then first!-time:=nil; % Now branch to another function to make this one not so huge. return solve!-for1(list(test!-prediction, growth!-factor, first!-time, fhat0s, f0s, vset, solve!-count, correction!-vectors, unknowns!-count!-list, resvec, correction!-factor, v, degbd, soln!-matrices, predicted!-forms, poly!-remaining, fvec, prediction!-results, previous!-prediction!-holds, one!-prediction!-failed)); exit: solve!-exit(bad!-case,first!-time,resvec); end) (factor!-level+1); symbolic procedure solve!-for1 u; begin scalar test!-prediction,growth!-factor,first!-time,fhat0s,f0s, vset,solve!-count,correction!-vectors,unknowns!-count!-list, resvec,correction!-factor,v,degbd,soln!-matrices, predicted!-forms,poly!-remaining,fvec,prediction!-results, previous!-prediction!-holds,one!-prediction!-failed, bool,d,f1,k,kk,substres,w; test!-prediction := car u; u := cdr u; growth!-factor := car u; u := cdr u; first!-time := car u; u := cdr u; fhat0s := car u; u := cdr u; f0s := car u; u := cdr u; vset := car u; u := cdr u; solve!-count := car u; u := cdr u; correction!-vectors := car u; u := cdr u; unknowns!-count!-list := car u; u := cdr u; resvec := car u; u := cdr u; correction!-factor := car u; u := cdr u; v := car u; u := cdr u; degbd := car u; u := cdr u; soln!-matrices := car u; u := cdr u; predicted!-forms := car u; u := cdr u; poly!-remaining := car u; u := cdr u; fvec := car u; u := cdr u; prediction!-results := car u; u := cdr u; previous!-prediction!-holds := car u; u := cdr u; one!-prediction!-failed := car u; f1:=mkvect number!-of!-factors; k:=1; kk:=0; temploop: bool := nil; while not bool and not polyzerop residue and (null max!-unknowns or null test!-prediction) do if k>degbd then << factor!-trace << prin2!* "We have overshot the degree bound for "; printvar car v >>; if !*overshoot then printc "Multivariate degree bound overshoot -> restart"; bad!-case:= bool := t >> else if polyzerop(substres:=evaluate!-mod!-p(residue,car v,cdr v)) then << k:=iadd1 k; residue:=diff!-over!-k!-mod!-p(residue,k,car v); correction!-factor:= times!-mod!-p(correction!-factor,growth!-factor) >> else begin solve!-msg4(growth!-factor,k,kk,substres); solve!-for!-corrections(substres,fhat0s,f0s,f1,cdr vset); % answers in f1; if bad!-case then return (bool := t); if max!-unknowns then << solve!-count:=iadd1 solve!-count; for i:=1:number!-of!-factors do putv(getv(correction!-vectors,i),solve!-count,getv(f1,i)); if solve!-count=caar unknowns!-count!-list then test!-prediction:=t >>; for i:=1:number!-of!-factors do putv(resvec,i,plus!-mod!-p(getv(resvec,i),times!-mod!-p( getv(f1,i),correction!-factor))); factor!-trace << printstr " Giving:"; printvec(" a(",number!-of!-factors,",1) = ",f1); printstr " New a's are now:"; printvec(" a(",number!-of!-factors,") = ",resvec) >>; d:=times!-mod!-p(correction!-factor, form!-sum!-and!-product!-mod!-p(f1,fhatvec, number!-of!-factors)); if degree!-in!-variable(d,car v)>degbd then << factor!-trace << prin2!* "We have overshot the degree bound for "; printvar car v >>; if !*overshoot then printc "Multivariate degree bound overshoot -> restart"; bad!-case:=t; return (bool := t)>>; d:=diff!-k!-times!-mod!-p(d,k,car v); k:=iadd1 k; residue:=diff!-over!-k!-mod!-p( difference!-mod!-p(residue,d),k,car v); factor!-trace << prin2!* " and residue = "; printsf residue; printstr "-------------" >>; correction!-factor:= times!-mod!-p(correction!-factor,growth!-factor) end; if not polyzerop residue and not bad!-case then << if null soln!-matrices then soln!-matrices:= construct!-soln!-matrices(predicted!-forms,cdr v); factor!-trace << printstr "The Hensel growth so far allows us to test some of"; printstr "our predictions:" >>; bool := nil; while not bool and unknowns!-count!-list and (car (w:=car unknowns!-count!-list))=solve!-count do << unknowns!-count!-list:=cdr unknowns!-count!-list; factor!-trace print!-linear!-system(cdr w,soln!-matrices, correction!-vectors,predicted!-forms,car v); w:=try!-prediction(soln!-matrices,correction!-vectors, predicted!-forms,car w,cdr w,poly!-remaining,car v,fvec, fhatvec); if car w='singular or car w='bad!-prediction then if one!-prediction!-failed then << factor!-trace printstr "Predictions were no help."; max!-unknowns:=nil; bool := t>> else << if previous!-prediction!-holds then << predictions:=delasc(car v,predictions); previous!-prediction!-holds:=nil >>; one!-prediction!-failed:=cdr w >> else << putv(prediction!-results,car w,cadr w); poly!-remaining:=caddr w >> >>; if null max!-unknowns then << if previous!-prediction!-holds then predictions:=delasc(car v,predictions); goto temploop >>; w:=length unknowns!-count!-list; if w>1 or (w=1 and one!-prediction!-failed) then << test!-prediction:=nil; goto temploop >>; if w=1 or one!-prediction!-failed then << w:=if one!-prediction!-failed then one!-prediction!-failed else cdar unknowns!-count!-list; putv(prediction!-results,w,quotfail!-mod!-p( poly!-remaining,getv(fhatvec,w))) >>; for i:=1:number!-of!-factors do putv(resvec,i,getv(prediction!-results,i)); if not previous!-prediction!-holds and not one!-prediction!-failed then predictions:= (car v . list(soln!-matrices,predicted!-forms,max!-unknowns, number!-of!-unknowns)) . predictions >>; solve!-exit(bad!-case,first!-time,resvec) end; symbolic procedure solve!-msg1(c,fvec,v); factor!-trace << printstr "Want a(i) s.t."; prin2!* "(*) sum over i [ a(i)*fhat(i) ] = "; prinsf c; prin2!* " mod "; printstr hensel!-growth!-size; prin2!* " where fhat(i) = product over j [ f(j) ]"; prin2!* " / f(i) mod "; printstr hensel!-growth!-size; printstr " and"; printvec(" f(",number!-of!-factors,") = ",fvec); terpri!*(nil); prin2!* "First solve the problem in one less variable by putting "; prinvar car v; prin2!* '!=; printstr cdr v; terpri!*(nil) >>; symbolic procedure solve!-msg2(resvec,v); factor!-trace << printstr "Giving:"; printvec(" a(",number!-of!-factors,",0) = ",resvec); printstr "Subtracting the contributions these give in (*) from"; prin2!* "the R.H.S. of (*) "; prin2!* "and differentiating wrt "; prinvar car v; printstr " gives a residue:" >>; symbolic procedure solve!-msg3; factor!-trace << terpri!*(nil); printstr "We predict :"; for each w in number!-of!-unknowns do << prin2!* car w; prin2!* " terms in a("; prin2!* cdr w; printstr '!) >>; if (caar number!-of!-unknowns)=1 then << prin2!* "Since we predict only one term for a("; prin2!* cdar number!-of!-unknowns; printstr "), we can test it right away:" >> else << prin2!* "So we shall do at least "; prin2!* isub1 caar number!-of!-unknowns; prin2!* " Hensel step"; if (caar number!-of!-unknowns)=2 then printstr "." else printstr "s." >>; terpri!*(nil) >>; symbolic procedure solve!-msg4(growth!-factor,k,kk,substres); factor!-trace << prin2!* "Hensel Step "; printstr (kk:=kk #+ 1); prin2!* "-------------"; if kk>10 then printstr "-" else terpri!*(t); prin2!* "Next corrections are for ("; prinsf growth!-factor; if not (k=1) then << prin2!* ") ** "; prin2!* k >> else prin2!* '!); printstr ". To find these we solve:"; prin2!* " sum over i [ a(i,1)*fhat(i,0) ] = "; prinsf substres; prin2!* " mod "; prin2!* hensel!-growth!-size; printstr " for a(i,1). "; terpri!*(nil) >>; symbolic procedure solve!-exit(bad!-case,first!-time,resvec); factor!-trace << if not bad!-case then if first!-time then printstr "But these a's are already correct." else << printstr "Correct a's are:"; printvec(" a(",number!-of!-factors,") = ",resvec) >>; terpri!*(nil); printstr "**************************************************"; terpri!*(nil) >>; endmodule; module unihens; % Univariate case of Hensel code with quadratic growth. % Author: P. M. A. Moore, 1979. fluid '(!*linear !*overshoot !*overview !*trfac alphalist alphavec coefftbd current!-factor!-product current!-modulus delfvec deltam factor!-level factor!-trace!-list factors!-done factorvec facvec fhatvec hensel!-growth!-size hensel!-poly irreducible m!-image!-variable modfvec multivariate!-input!-poly non!-monic number!-of!-factors polyzero prime!-base reconstructing!-gcd); global '(largest!-small!-modulus); symbolic procedure uhensel!.extend(poly,best!-flist,lclist,p); % Extend poly=product(factors in best!-flist) mod p even if poly is % non-monic. Return a list (ok. list of factors) if factors can be % extended to be correct over the integers, otherwise return a list % (failed <reason> <reason>). begin scalar w,k,old!-modulus,alphavec,modular!-flist,factorvec, modfvec,coefftbd,fcount,fhatvec,deltam,mod!-symm!-flist, current!-factor!-product,facvec,factors!-done,hensel!-poly; prime!-base:=p; old!-modulus:=set!-modulus p; % timer:=readtime(); number!-of!-factors:=length best!-flist; w:=expt(lc poly,number!-of!-factors -1); if lc poly < 0 then errorf list("LC SHOULD NOT BE -VE",poly); coefftbd:=max(110,p+1,lc poly*get!-coefft!-bound(poly,ldeg poly)); poly:=multf(poly,w); modular!-flist:=for each ff in best!-flist collect reduce!-mod!-p ff; % Modular factors have been multiplied by a constant to % fix the l.c.'s, so they may be out of range - this % fixes that. if not(w=1) then factor!-trace << prin2!* "Altered univariate polynomial: "; printsf poly >>; % Make sure the leading coefft will not cause trouble % in the hensel construction. mod!-symm!-flist:=for each ff in modular!-flist collect make!-modular!-symmetric ff; if not !*overview then factor!-trace << prin2!* "The factors mod "; prin2!* p; printstr " to start from are:"; fcount:=1; for each ff in mod!-symm!-flist do << prin2!* " f("; prin2!* fcount; prin2!* ")="; printsf ff; fcount:=iadd1 fcount >>; terpri!*(nil) >>; alphalist:=alphas(number!-of!-factors,modular!-flist,1); % 'magic' polynomials associated with the image factors. if not !*overview then factor!-trace << printstr "The following modular polynomials are chosen such that:"; terpri(); prin2!* " a(1)*h(1) + ... + a("; prin2!* number!-of!-factors; prin2!* ")*h("; prin2!* number!-of!-factors; prin2!* ") = 1 mod "; printstr p; terpri(); printstr " where h(i)=(product of all f(j) [see below])/f(i)"; printstr " and degree of a(i) < degree of f(i)."; fcount:=1; for each a in modular!-flist do << prin2!* " a("; prin2!* fcount; prin2!* ")="; printsf cdr get!-alpha a; prin2!* " f("; prin2!* fcount; prin2!* ")="; printsf a; fcount:=iadd1 fcount >> >>; k:=0; factorvec:=mkvect number!-of!-factors; modfvec:=mkvect number!-of!-factors; alphavec:=mkvect number!-of!-factors; for each modsymmf in mod!-symm!-flist do << putv(factorvec,k:=k+1,force!-lc(modsymmf,car lclist)); lclist:=cdr lclist >>; k:=0; for each modfactor in modular!-flist do << putv(modfvec,k:=k+1,modfactor); putv(alphavec,k,cdr get!-alpha modfactor); >>; % best!-fvec is now a vector of factors of poly correct % mod p with true l.c.s forced in. fhatvec:=mkvect number!-of!-factors; w:=hensel!-mod!-p(poly,modfvec,factorvec,coefftbd,nil,p); if car w='overshot then w := uhensel!.extend1(poly,w) else w := uhensel!.extend2 w; set!-modulus old!-modulus; if irreducible then << factor!-trace printstr "Two factors and overshooting means irreducible"; return t >>; factor!-trace begin scalar k; k:=0; printstr "Univariate factors, possibly with adjusted leading"; printstr "coefficients, are:"; for each ww in cdr w do << prin2!* " f("; prin2!* (k:=k #+ 1); prin2!* ")="; printsf ww >> end; return if non!-monic then (car w . primitive!.parts(cdr w,m!-image!-variable,t)) else w end; symbolic procedure uhensel!.extend1(poly,w); begin scalar oklist,badlist,m,r,ff,om,pol; m:=cadr w; % the modulus. r:=getv(factorvec,0); % the number of factors. if r=2 then return (irreducible:=t); if factors!-done then << poly:=hensel!-poly; for each ww in factors!-done do poly:=multf(poly,ww) >>; pol:=poly; om:=set!-modulus hensel!-growth!-size; alphalist:=nil; for i:=r step -1 until 1 do alphalist:= (reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i)) . alphalist; set!-modulus om; % bring alphalist up to date. for i:=1:r do << ff:=getv(factorvec,i); if not didntgo(w:=quotf(pol,ff)) then << oklist:=ff . oklist; pol:=w>> else badlist:=(i . ff) . badlist >>; if null badlist then w:='ok . oklist else << if not !*overview then factor!-trace << printstr "Overshot factors are:"; for each f in badlist do << prin2!* " f("; prin2!* car f; prin2!* ")="; printsf cdr f >> >>; w:=try!.combining(badlist,pol,m,nil); if car w='one! bad! factor then begin scalar x; w:=append(oklist,cdr w); x:=1; for each v in w do x:=multf(x,v); w:='ok . (quotfail(pol,x) . w) end else w:='ok . append(oklist,w) >>; if (not !*linear) and multivariate!-input!-poly then << poly:=1; number!-of!-factors:=0; for each facc in cdr w do << poly:=multf(poly,facc); number!-of!-factors:=1 #+ number!-of!-factors >>; % make sure poly is the product of the factors we have, % we recalculate it this way because we may have the wrong % lc in old value of poly. reset!-quadratic!-step!-fluids(poly,cdr w, number!-of!-factors); if m=deltam then errorf list("Coefft bound < prime ?", coefftbd,m); m:=deltam*deltam; while m<largest!-small!-modulus do << quadratic!-step(m,number!-of!-factors); m:=m*deltam >>; hensel!-growth!-size:=deltam; om:=set!-modulus hensel!-growth!-size; alphalist:=nil; for i:=number!-of!-factors step -1 until 1 do alphalist:= (reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i)) . alphalist; set!-modulus om >>; return w end; symbolic procedure uhensel!.extend2 w; begin scalar r,faclist,om; r:=getv(factorvec,0); % no of factors. om:=set!-modulus hensel!-growth!-size; alphalist:=nil; for i:=r step -1 until 1 do alphalist:=(reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i)) . alphalist; set!-modulus om; % bring alphalist up to date. for i:=r step -1 until 1 do faclist:=getv(factorvec,i) . faclist; return (car w . faclist) end; symbolic procedure get!-coefft!-bound(poly,ddeg); % This uses Mignotte's bound which is minimal I believe. % NB. poly had better be univariate as bound only valid for this. binomial!-coefft(ddeg/2,ddeg/4) * root!-squares(poly,0); symbolic procedure binomial!-coefft(n,r); if n<r then nil else if n=r then 1 else if r=1 then n else begin scalar n!-c!-r,b; n!-c!-r:=1; b:=min(r,n-r); for i:=1:b do n!-c!-r:=(n!-c!-r * (n - i + 1)) / i; return n!-c!-r end; symbolic procedure pmam!-sqrt n; % Find the square root of n and return integer part + 1. N is fixed pt % on input as it may be very large, i.e. > largest allowed floating pt % number so I scale it appropriately. begin scalar s,ten!*!*6,ten!*!*12,ten!*!*14; s:=0; ten!*!*6:=10**6; ten!*!*12:=ten!*!*6**2; ten!*!*14:=100*ten!*!*12; while n>ten!*!*14 do << s:=iadd1 s; n:=1+n/ten!*!*12 >>; return ((fix sqrt!-float float n) + 1) * 10**(6*s) end; symbolic procedure find!-alphas!-in!-a!-ring(n,mflist,fhatlist,gamma); % Find the alphas (as below) given that the modulus may not be prime % but is a prime power. begin scalar gg,m,ppow,i,gg!-mod!-p,modflist,wvec,alpha,alphazeros,w; if null prime!-base then errorf list("Prime base not set for finding alphas", current!-modulus,n,mflist); m:=set!-modulus prime!-base; modflist:= if m=prime!-base then mflist else for each fthing in mflist collect reduce!-mod!-p !*mod2f fthing; alphalist:=alphas(n,modflist,gamma); if m=prime!-base then << set!-modulus m; return alphalist >>; i:=0; alphazeros:=mkvect n; wvec:=mkvect n; for each modfthing in modflist do << putv(modfvec,i:=iadd1 i,modfthing); putv(alphavec,i,!*f2mod(alpha:=cdr get!-alpha modfthing)); putv(alphazeros,i,alpha); putv(wvec,i,alpha); putv(fhatvec,i,car fhatlist); fhatlist:=cdr fhatlist >>; gg:=gamma; ppow:=prime!-base; while ppow<m do << set!-modulus m; gg:=!*f2mod quotfail(!*mod2f difference!-mod!-p(gg, form!-sum!-and!-product!-mod!-m(wvec,fhatvec,n)),prime!-base); set!-modulus prime!-base; gg!-mod!-p:=reduce!-mod!-p !*mod2f gg; for k:=1:n do << putv(wvec,k,w:=remainder!-mod!-p( times!-mod!-p(getv(alphazeros,k),gg!-mod!-p), getv(modfvec,k))); putv(alphavec,k,addf(getv(alphavec,k),multf(!*mod2f w,ppow)))>>; ppow:=ppow*prime!-base >>; set!-modulus m; i:=0; return (for each fthing in mflist collect (fthing . !*f2mod getv(alphavec,i:=iadd1 i))) end; symbolic procedure alphas(n,flist,gamma); % Finds alpha,beta,delta,... wrt factors f(i) in flist s.t. % alpha*g(1) + beta*g(2) + delta*g(3) + ... = gamma mod p, % where g(i)=product(all the f(j) except f(i) itself). % (cf. xgcd!-mod!-p below). n is number of factors in flist. if n=1 then list(car flist . gamma) else begin scalar k,w,f1,f2,i,gamma1,gamma2; k:=n/2; f1:=1; f2:=1; i:=1; for each f in flist do << if i>k then f2:=times!-mod!-p(f,f2) else f1:=times!-mod!-p(f,f1); i:=i+1 >>; w:=xgcd!-mod!-p(f1,f2,1,polyzero,polyzero,1); if atom w then return 'factors! not! coprime; gamma1:=remainder!-mod!-p(times!-mod!-p(cdr w,gamma),f1); gamma2:=remainder!-mod!-p(times!-mod!-p(car w,gamma),f2); i:=1; f1:=nil; f2:=nil; for each f in flist do << if i>k then f2:=f . f2 else f1:=f . f1; i:=i+1 >>; return append( alphas(k,f1,gamma1), alphas(n-k,f2,gamma2)) end; symbolic procedure xgcd!-mod!-p(a,b,x1,y1,x2,y2); % Finds alpha and beta s.t. alpha*a+beta*b=1. % Returns alpha . beta or nil if a and b are not coprime. if null b then nil else if isdomain b then begin b:=modular!-reciprocal b; x2:=multiply!-by!-constant!-mod!-p(x2,b); y2:=multiply!-by!-constant!-mod!-p(y2,b); return x2 . y2 end else begin scalar q; q:=quotient!-mod!-p(a,b); % Truncated quotient here. return xgcd!-mod!-p(b,difference!-mod!-p(a,times!-mod!-p(b,q)), x2,y2, difference!-mod!-p(x1,times!-mod!-p(x2,q)), difference!-mod!-p(y1,times!-mod!-p(y2,q))) end; symbolic procedure hensel!-mod!-p(poly,mvec,fvec,cbd,vset,p); % Hensel construction building up in powers of p. % Given that poly=product(factors in factorvec) mod p, find the full % factors over the integers. Mvec contains the univariate factors mod p % while fvec contains our best knowledge of the factors to date. % Fvec includes leading coeffts (and in multivariate case possibly other % coeffts) of the factors. return a list whose first element is a flag % with one of the following values: % ok construction worked, the cdr of the result is a list of % the correct factors. % failed inputs must have been incorrect % overshot factors are correct mod some power of p (say p**m), % but are not correct over the integers. % result is (overshot,p**m,list of factors so far). begin scalar w,u0,delfvec,old!.mod,res,m; u0:=initialize!-hensel(number!-of!-factors,p,poly,mvec,fvec,cbd); % u0 contains the product (over integers) of factors mod p. m := p; old!.mod := set!-modulus nil; if number!-of!-factors=1 then <<putv(fvec,1,current!-factor!-product:=poly); % Added JHD 28.9.87 return hensel!-exit(m,old!.mod,p,vset,w)>>; % only one factor to grow! but need to go this deep to % construct the alphas and set things up for the % multivariate growth which may follow. hensel!-msg1(p,u0); old!.mod:=set!-modulus p; res:=addf(hensel!-poly,negf u0); % calculate the residue. from now on this is always % kept in res. m:=p; % measure of how far we have built up factors - at this % stage we know the constant terms mod p in the factors. a: if polyzerop res then return hensel!-exit(m,old!.mod,p,vset,w); if (m/2)>coefftbd then << % we started with a false split of the image so some % of the factors we have built up must amalgamate in % the complete factorization. if !*overshoot then << prin2 if null vset then "Univariate " else "Multivariate "; printc "coefft bound overshoot" >>; if not !*overview then factor!-trace printstr "We have overshot the coefficient bound"; return hensel!-exit(m,old!.mod,p,vset,'overshot)>>; res:=quotfail(res,deltam); % next term in residue. if not !*overview then factor!-trace << prin2!* "Residue divided by "; prin2!* m; prin2!* " is "; printsf res >>; if (not !*linear) and null vset and m<=largest!-small!-modulus and m>p then quadratic!-step(m,number!-of!-factors); w:=reduce!-mod!-p res; if not !*overview then factor!-trace << prin2!* "Next term in residue to kill is:"; prinsf w; prin2!* " which is of size "; printsf (deltam*m); >>; solve!-for!-corrections(w,fhatvec,modfvec,delfvec,vset); % delfvec is vector of next correction terms to factors. make!-vec!-modular!-symmetric(delfvec,number!-of!-factors); if not !*overview then factor!-trace << printstr "Correction terms are:"; w:=1; for i:=1:number!-of!-factors do << prin2!* " To f("; prin2!* w; prin2!* "): "; printsf multf(m,getv(delfvec,i)); w:=iadd1 w >>; >>; w:=terms!-done(factorvec,delfvec,m); res:=addf(res,negf w); % subtract out the terms generated by these corrections % from the residue. current!-factor!-product:= addf(current!-factor!-product,multf(m,w)); % add in the correction terms to give new factor product. for i:=1:number!-of!-factors do putv(factorvec,i, addf(getv(factorvec,i),multf(getv(delfvec,i),m))); % add the corrections into the factors. if not !*overview then factor!-trace << printstr " giving new factors as:"; w:=1; for i:=1:number!-of!-factors do << prin2!* " f("; prin2!* w; prin2!* ")="; printsf getv(factorvec,i); w:=iadd1 w >> >>; m:=m*deltam; if not polyzerop res and null vset and not reconstructing!-gcd then begin scalar j,u,fac; j:=0; while (j:=j #+ 1)<=number!-of!-factors do % IF NULL GETV(DELFVEC,J) AND % - Try dividing out every time for now. if not didntgo (u:=quotf(hensel!-poly,fac:=getv(factorvec,j))) then << hensel!-poly:=u; res:=adjust!-growth(fac,j,m); j:=number!-of!-factors >> end; go to a end; symbolic procedure hensel!-exit(m,old!.mod,p,vset,w); begin if factors!-done then << if not(w='overshot) then m:=p*p; set!-hensel!-fluids!-back p >>; if (not (w='overshot)) and null vset and (not !*linear) and multivariate!-input!-poly then while m<largest!-small!-modulus do << if not(m=deltam) then quadratic!-step(m,number!-of!-factors); m:=m*deltam >>; % set up the alphas etc so that multivariate growth can % use a Hensel growth size of about word size. set!-modulus old!.mod; % reset the old modulus. hensel!-growth!-size:=deltam; putv(factorvec,0,number!-of!-factors); return if w='overshot then list('overshot,m,factorvec) else 'ok . factorvec end; symbolic procedure hensel!-msg1(p,u0); begin scalar w; factor!-trace << printstr "We are now ready to use the Hensel construction to grow"; prin2!* "in powers of "; printstr current!-modulus; if not !*overview then <<prin2!* "Polynomial to factor (=U): "; printsf hensel!-poly>>; prin2!* "Initial factors mod "; prin2!* p; printstr " with some correct coefficients:"; w:=1; for i:=1:number!-of!-factors do << prin2!* " f("; prin2!* w; prin2!* ")="; printsf getv(factorvec,i); w:=iadd1 w >>; if not !*overview then << prin2!* "Coefficient bound = "; prin2!* coefftbd; terpri!*(nil); prin2!* "The product of factors over the integers is "; printsf u0; printstr "In each step below, the residue is U - (product of the"; printstr "factors as far as we know them). The correction to each"; printstr "factor, f(i), is (a(i)*v) mod f0(i) where f0(i) is"; prin2!* "f(i) mod "; prin2!* p; printstr "(ie. the f(i) used in calculating the a(i))" >>>> end; symbolic procedure initialize!-hensel(r,p,poly,mvec,fvec,cbd); % Set up the vectors and initialize the fluids. begin scalar u0; delfvec:=mkvect r; facvec:=mkvect r; hensel!-poly:=poly; modfvec:=mvec; factorvec:=fvec; coefftbd:=cbd; factors!-done:=nil; deltam:=p; u0:=1; for i:=1:r do u0:=multf(getv(factorvec,i),u0); current!-factor!-product:=u0; return u0 end; % symbolic procedure reset!-quadratic!-step!-fluids(poly,faclist,n); % begin scalar i,om,modf; % current!-factor!-product:=poly; % om:=set!-modulus hensel!-growth!-size; % i:=0; % for each fac in faclist do << % putv(factorvec,i:=iadd1 i,fac); % putv(modfvec,i,modf:=reduce!-mod!-p fac); % putv(alphavec,i,cdr get!-alpha modf) >>; % for i:=1:n do << % prin2 "F("; % prin2 i; % prin2 ") = "; % printsf getv(factorvec,i); % prin2 "F("; % prin2 i; % prin2 ") MOD P = "; % printsf getv(modfvec,i); % prin2 "A("; % prin2 i; % prin2 ") = "; % printsf getv(alphavec,i) >>; % set!-modulus om % end; symbolic procedure reset!-quadratic!-step!-fluids(poly,faclist,n); begin scalar i,om,facpairlist,cfp!-mod!-p,fhatlist; current!-factor!-product:=poly; om:=set!-modulus hensel!-growth!-size; cfp!-mod!-p:=reduce!-mod!-p current!-factor!-product; i:=0; facpairlist:=for each fac in faclist collect << i:= i #+ 1; (fac . reduce!-mod!-p fac) >>; fhatlist:=for each facc in facpairlist collect quotfail!-mod!-p(cfp!-mod!-p,cdr facc); if factors!-done then alphalist:= find!-alphas!-in!-a!-ring(i, for each facpr in facpairlist collect cdr facpr, fhatlist,1); % a bug has surfaced such that the alphas get out of step. % In this case so recalculate them to stop the error for now. i:=0; for each facpair in facpairlist do << putv(factorvec,i:=iadd1 i,car facpair); putv(modfvec,i,cdr facpair); putv(alphavec,i,cdr get!-alpha cdr facpair) >>; % for i:=1:n do << % prin2 "f("; % prin2 i; % prin2 ") = "; % printsf getv(factorvec,i); % prin2 "f("; % prin2 i; % prin2 ") mod p = "; % printsf getv(modfvec,i); % prin2 "a("; % prin2 i; % prin2 ") = "; % printsf getv(alphavec,i) >>; set!-modulus om end; symbolic procedure quadratic!-step(m,r); % Code for adjusting the hensel variables to take quadratic steps in % the growing process. begin scalar w,s,cfp!-mod!-p; set!-modulus m; cfp!-mod!-p:=reduce!-mod!-p current!-factor!-product; for i:=1:r do putv(facvec,i,reduce!-mod!-p getv(factorvec,i)); for i:=1:r do putv(fhatvec,i, quotfail!-mod!-p(cfp!-mod!-p,getv(facvec,i))); w:=form!-sum!-and!-product!-mod!-m(alphavec,fhatvec,r); w:=!*mod2f plus!-mod!-p(1,minus!-mod!-p w); s:=quotfail(w,deltam); set!-modulus deltam; s:=!*f2mod s; % Boxes S up to look like a poly mod deltam. for i:=1:r do << w:=remainder!-mod!-p(times!-mod!-p(s,getv(alphavec,i)), getv(modfvec,i)); putv(alphavec,i, addf(!*mod2f getv(alphavec,i),multf(!*mod2f w,deltam))) >>; s:=modfvec; modfvec:=facvec; facvec:=s; deltam:=m; % this is our new growth rate. set!-modulus deltam; for i:=1:r do << putv(facvec,i,"RUBBISH"); % we will want to overwrite facvec next time so we % had better point it to the old (no longer needed) % modvec. Also mark it as containing rubbish for safety. putv(alphavec,i,!*f2mod getv(alphavec,i)) >>; % Make sure the alphas are boxed up as being mod new deltam. if not !*overview then factor!-trace << printstr "The new modular polynomials are chosen such that:"; terpri(); prin2!* " a(1)*h(1) + ... + a("; prin2!* r; prin2!* ")*h("; prin2!* r; prin2!* ") = 1 mod "; printstr m; terpri(); printstr " where h(i)=(product of all f(j) [see below])/f(i)"; printstr " and degree of a(i) < degree of f(i)."; for i:=1:r do << prin2!* " a("; prin2!* i; prin2!* ")="; printsf getv(alphavec,i); prin2!* " f("; prin2!* i; prin2!* ")="; printsf getv(modfvec,i) >> >> end; symbolic procedure terms!-done(fvec,delfvec,m); begin scalar flist,delflist; for i:=1:number!-of!-factors do << flist:=getv(fvec,i) . flist; delflist:=getv(delfvec,i) . delflist >>; return terms!.done(number!-of!-factors,flist,delflist, number!-of!-factors,m) end; symbolic procedure terms!.done(n,flist,delflist,r,m); if n=1 then (car flist) . (car delflist) else begin scalar k,i,f1,f2,delf1,delf2; k:=n/2; i:=1; for each f in flist do << if i>k then f2:=(f . f2) else f1:=(f . f1); i:=i+1 >>; i:=1; for each delf in delflist do << if i>k then delf2:=(delf . delf2) else delf1:=(delf . delf1); i:=i+1 >>; f1:=terms!.done(k,f1,delf1,r,m); delf1:=cdr f1; f1:=car f1; f2:=terms!.done(n-k,f2,delf2,r,m); delf2:=cdr f2; f2:=car f2; delf1:= addf(addf( multf(f1,delf2), multf(f2,delf1)), multf(multf(delf1,m),delf2)); if n=r then return delf1; return (multf(f1,f2) . delf1) end; symbolic procedure try!.combining(l,poly,m,sofar); % l is a list of factors, f(i), s.t. (product of the f(i) mod m) = poly % but no f(i) divides poly over the integers. We find the combinations % of the f(i) that yield the true factors of poly over the integers. % Sofar is a list of these factors found so far. if poly=1 then if null l then sofar else errorf(list("TOO MANY BAD FACTORS:",l)) else begin scalar k,n,res,ff,v,w,w1,combined!.factors,ll; n:=length l; if n=1 then if ldeg car l > (ldeg poly)/2 then return ('one! bad! factor . sofar) else errorf(list("ONE BAD FACTOR DOES NOT FIT:",l)); if n=2 or n=3 then << w:=lc cdar l; % The LC of all the factors is the same. while not (w=lc poly) do poly:=quotfail(poly,w); % poly's LC may be a higher power of w than we want % and we must return a result with the same % LC as each of the combined factors. if not !*overview then factor!-trace << printstr "We combine:"; for each lf in l do printsf cdr lf; prin2!* " mod "; prin2!* m; printstr " to give correct factor:"; printsf poly >>; combine!.alphas(l,t); return (poly . sofar) >>; ll:=for each ff in l collect (cdr ff . car ff); k := 2; loop1: if k > n/2 then go to exit; w:=koutof(k,if 2*k=n then cdr l else l,nil); while w and (v:=factor!-trialdiv(poly,car w,m,ll))='didntgo do << w:=cdr w; while w and ((car w = '!*lazyadjoin) or (car w = '!*lazykoutof)) do if car w= '!*lazyadjoin then w:=lazy!-adjoin(cadr w,caddr w,cadr cddr w) else w:=koutof(cadr w,caddr w,cadr cddr w) >>; if not(v='didntgo) then << ff:=car v; v:=cdr v; if not !*overview then factor!-trace << printstr "We combine:"; for each a in car w do printsf a; prin2!* " mod "; prin2!* m; printstr " to give correct factor:"; printsf ff >>; for each a in car w do << w1:=l; while not (a = cdar w1) do w1:=cdr w1; combined!.factors:=car w1 . combined!.factors; l:=delete(car w1,l) >>; combine!.alphas(combined!.factors,t); res:=try!.combining(l,v,m,ff . sofar); go to exit>>; k := k + 1; go to loop1; exit: if res then return res else << w:=lc cdar l; % The LC of all the factors is the same. while not (w=lc poly) do poly:=quotfail(poly,w); % poly's LC may be a higher power of w than we want % and we must return a result with the same % LC as each of the combined factors. if not !*overview then factor!-trace << printstr "We combine:"; for each ff in l do printsf cdr ff; prin2!* " mod "; prin2!* m; printstr " to give correct factor:"; printsf poly >>; combine!.alphas(l,t); return (poly . sofar) >> end; symbolic procedure koutof(k,l,sofar); % Produces all permutations of length k from list l accumulating them % in sofar as we go. We use lazy evaluation in that this results in % a permutation dotted with: % ( '!*lazy . (argument for eval) ) % except when k=1 when the permutations are explicitly given. if k=1 then append( for each f in l collect list cdr f,sofar) else if k>length l then sofar else << while eqcar(l,'!*lazyadjoin) or eqcar(l,'!*lazykoutof) do if car l='!*lazyadjoin then l := lazy!-adjoin(cadr l,caddr l,cadr cddr l) else l := koutof(cadr l,caddr l,cadr cddr l); if k=length l then (for each ll in l collect cdr ll ) . sofar else koutof(k,cdr l, list('!*lazyadjoin,cdar l, list('!*lazykoutof,(k-1),cdr l,nil), sofar)) >>; symbolic procedure lazy!-adjoin(item,l,tail); % Dots item with each element in l using lazy evaluation on l. % If l is null tail results. << while eqcar(l,'!*lazyadjoin) or eqcar(l,'!*lazykoutof) do if car l ='!*lazyadjoin then l:=lazy!-adjoin(cadr l,caddr l,cadr cddr l) else l:=koutof(cadr l,caddr l,cadr cddr l); if null l then tail else (item . car l) . if null cdr l then tail else list('!*lazyadjoin,item,cdr l,tail) >>; symbolic procedure factor!-trialdiv(poly,flist,m,llist); % Combines the factors in FLIST mod M and test divides the result % into POLY (over integers) to see if it goes. If it doesn't % then DIDNTGO is returned, else the pair (D . Q) is % returned where Q is the quotient obtained and D is the product % of the factors mod M. if polyzerop poly then errorf "Test dividing into zero?" else begin scalar d,q; d:=combine(flist,m,llist); if didntgo(q:=quotf(poly,car d)) then << factor!-trace printstr " it didn't go (division fail)"; return 'didntgo >> else << factor!-trace printstr " it worked !"; return (car d . quotf(q,cdr d)) >> end; symbolic procedure combine(flist,m,l); % Multiply factors in flist mod m. % L is a list of the factors for use in FACTOR!-TRACE. begin scalar om,res,w,lcf,lcfinv,lcfprod; factor!-trace << prin2!* "We combine factors "; for each ff in flist do << w:=assoc(ff,l); prin2!* "f("; prin2!* cdr w; prin2!* "), " >> ; prin2!* "and try dividing : " >>; lcf := lc car flist; % all leading coeffts should be the same. lcfprod := 1; % This is one of only two places in the entire factorizer where % it is ever necessary to use a modulus larger than word-size. if m>largest!-small!-modulus then << om:=set!-general!-modulus m; lcfinv := general!-modular!-reciprocal lcf; res:=general!-reduce!-mod!-p car flist; for each ff in cdr flist do << if not lcf=lc ff then errorf "BAD LC IN FLIST"; res:=general!-times!-mod!-p( general!-times!-mod!-p(lcfinv, general!-reduce!-mod!-p ff),res); lcfprod := lcfprod*lcf >>; res:=general!-make!-modular!-symmetric res; set!-modulus om; return (res . lcfprod) >> else << om:=set!-modulus m; lcfinv := modular!-reciprocal lcf; res:=reduce!-mod!-p car flist; for each ff in cdr flist do << if not lcf=lc ff then errorf "BAD LC IN FLIST"; res:=times!-mod!-p(times!-mod!-p(lcfinv,reduce!-mod!-p ff),res); lcfprod := lcfprod*lcf >>; res:=make!-modular!-symmetric res; set!-modulus om; return (res . lcfprod) >> end; symbolic procedure combine!.alphas(flist,fixlcs); % Combine the alphas associated with each of these factors to % give the one alpha for their combination. begin scalar f1,a1,ff,aa,oldm,lcfac,lcfinv,saveflist; oldm:=set!-modulus hensel!-growth!-size; flist:=for each fac in flist collect << saveflist:= (reduce!-mod!-p cdr fac) . saveflist; (car fac) . car saveflist >>; if fixlcs then << lcfinv:=modular!-reciprocal lc cdar flist; lcfac:=modular!-expt(lc cdar flist,sub1 length flist) >> else << lcfinv:=1; lcfac:=1 >>; % If FIXLCS is set then we have combined n factors % (each with the same l.c.) to give one and we only need one % l.c. in the result, we have divided the combination by % lc**(n-1) and we must be sure to do the same for the % alphas. ff:=cdar flist; aa:=cdr get!-alpha ff; flist:=cdr flist; while flist do << f1:=cdar flist; a1:=cdr get!-alpha f1; flist:=cdr flist; aa:=plus!-mod!-p(times!-mod!-p(aa,f1),times!-mod!-p(a1,ff)); ff:=times!-mod!-p(ff,f1) >>; for each a in alphalist do if not member(car a,saveflist) then flist:=(car a . times!-mod!-p(cdr a,lcfac)) . flist; alphalist:=(quotient!-mod!-p(ff, lcfac) . aa) . flist; set!-modulus oldm end; % The following code is for dividing out factors in the middle % of the Hensel construction and adjusting all the associated % variables that go with it. symbolic procedure adjust!-growth(facdone,k,m); % One factor (at least) divides out so we can reconfigure the % problem for Hensel constrn giving a smaller growth and hopefully % reducing the coefficient bound considerably. begin scalar w,u,bound!-scale,modflist,factorlist,fhatlist, modfdone,b; factorlist:=vec2list!-without!-k(factorvec,k); modflist:=vec2list!-without!-k(modfvec,k); fhatlist:=vec2list!-without!-k(fhatvec,k); w:=number!-of!-factors; modfdone:=getv(modfvec,k); top: factors!-done:=facdone . factors!-done; if (number!-of!-factors:=number!-of!-factors #- 1)=1 then << factors!-done:=hensel!-poly . factors!-done; number!-of!-factors:=0; hensel!-poly:=1; if not !*overview then factor!-trace << printstr " All factors found:"; for each fd in factors!-done do printsf fd >>; return polyzero >>; fhatlist:=for each fhat in fhatlist collect quotfail!-mod!-p(if null fhat then polyzero else fhat,modfdone); u:=comfac facdone; % Take contents and prim. parts. if car u then errorf(list("Factor divisible by main variable: ",facdone,car u)); facdone:=quotfail(facdone,cdr u); bound!-scale:=cdr u; if not((b:=lc facdone)=1) then begin scalar b!-inv,old!-m; hensel!-poly:=quotfail(hensel!-poly,b**number!-of!-factors); b!-inv:=modular!-reciprocal modular!-number b; modflist:=for each modf in modflist collect times!-mod!-p(b!-inv,modf); % This is one of only two places in the entire factorizer where % it is ever necessary to use a modulus larger than word-size. if m>largest!-small!-modulus then << old!-m:=set!-general!-modulus m; factorlist:=for each facc in factorlist collect adjoin!-term(lpow facc,quotfail(lc facc,b), general!-make!-modular!-symmetric( general!-times!-mod!-p( general!-modular!-reciprocal general!-modular!-number b, general!-reduce!-mod!-p red facc))) >> else << old!-m:=set!-modulus m; factorlist:=for each facc in factorlist collect adjoin!-term(lpow facc,quotfail(lc facc,b), make!-modular!-symmetric( times!-mod!-p(modular!-reciprocal modular!-number b, reduce!-mod!-p red facc))) >>; % We must be careful not to destroy the information % that we have about the leading coefft. set!-modulus old!-m; fhatlist:=for each fhat in fhatlist collect times!-mod!-p( modular!-expt(b!-inv,number!-of!-factors #- 1),fhat) end; try!-another!-factor: if (w:=w #- 1)>0 then if not didntgo (u:=quotf(hensel!-poly,facdone:=car factorlist)) then << hensel!-poly:=u; factorlist:=cdr factorlist; modfdone:=car modflist; modflist:=cdr modflist; fhatlist:=cdr fhatlist; goto top >> else << factorlist:=append(cdr factorlist,list car factorlist); modflist:=append(cdr modflist,list car modflist); fhatlist:=append(cdr fhatlist,list car fhatlist); goto try!-another!-factor >>; set!-fluids!-for!-newhensel(factorlist,fhatlist,modflist); bound!-scale:= bound!-scale * get!-coefft!-bound( quotfail(hensel!-poly,bound!-scale**(number!-of!-factors #- 1)), ldeg hensel!-poly); % We expect the new coefficient bound to be smaller, but on % dividing out a factor our polynomial's height may have grown % more than enough to compensate in the bound formula for % the drop in degree. Anyway, the bound we computed last time % will still be valid, so let's stick with the smaller. if bound!-scale < coefftbd then coefftbd := bound!-scale; w:=quotfail(addf(hensel!-poly,negf current!-factor!-product), m/deltam); if not !*overview then factor!-trace << printstr " Factors found to be correct:"; for each fd in factors!-done do printsf fd; printstr "Remaining factors are:"; printvec(" f(",number!-of!-factors,") = ",factorvec); prin2!* "New coefficient bound is "; printstr coefftbd; prin2!* " and the residue is now "; printsf w >>; return w end; symbolic procedure vec2list!-without!-k(v,k); % Turn a vector into a list leaving out Kth element. begin scalar w; for i:=1:number!-of!-factors do if not(i=k) then w:=getv(v,i) . w; return w end; symbolic procedure set!-fluids!-for!-newhensel(flist,fhatlist,modflist); << current!-factor!-product:=1; alphalist:= find!-alphas!-in!-a!-ring(number!-of!-factors,modflist,fhatlist,1); for i:=number!-of!-factors step -1 until 1 do << putv(factorvec,i,car flist); putv(modfvec,i,car modflist); putv(fhatvec,i,car fhatlist); putv(alphavec,i,cdr get!-alpha car modflist); current!-factor!-product:=multf(car flist,current!-factor!-product); flist:=cdr flist; modflist:=cdr modflist; fhatlist:=cdr fhatlist >> >>; symbolic procedure set!-hensel!-fluids!-back p; % After the Hensel growth we must be careful to set back any fluids % that have been changed when we divided out a factor in the middle % of growing. Since calculating the alphas involves modular division % we cannot do it mod DELTAM which is generally a non-trivial power of % P (prime). So we calculate them mod P and if necessary we can do a % few quadratic growth steps later. begin scalar n,fd,modflist,fullf,modf; set!-modulus p; deltam:=p; n:=number!-of!-factors #+ length (fd:=factors!-done); current!-factor!-product:=hensel!-poly; for i:=(number!-of!-factors #+ 1):n do << putv(factorvec,i,fullf:=car fd); putv(modfvec,i,modf:=reduce!-mod!-p fullf); current!-factor!-product:=multf(fullf,current!-factor!-product); modflist:=modf . modflist; fd:=cdr fd >>; for i:=1:number!-of!-factors do << modf:=reduce!-mod!-p !*mod2f getv(modfvec,i); % need to 'unbox' a modpoly before reducing it mod p as we % know that the input modpoly is wrt a larger modulus % (otherwise this would be a stupid thing to do anyway!) % and so we are just pretending it is a full poly. modflist:=modf . modflist; putv(modfvec,i,modf) >>; alphalist:=alphas(n,modflist,1); for i:=1:n do putv(alphavec,i,cdr get!-alpha getv(modfvec,i)); number!-of!-factors:=n end; endmodule; end; |
Added r33/factor.red version [99af573d08].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module bigmodp; % Modular polynomial arithmetic where the modulus may % be a bignum. % Authors: A. C. Norman and P. M. A. Moore, 1981; fluid '(current!-modulus modulus!/2); symbolic procedure general!-plus!-mod!-p(a,b); % form the sum of the two polynomials a and b % working over the ground domain defined by the routines % general!-modular!-plus, general!-modular!-times etc. the inputs to % this routine are assumed to have coefficients already % in the required domain; if null a then b else if null b then a else if isdomain a then if isdomain b then !*num2f general!-modular!-plus(a,b) else (lt b) .+ general!-plus!-mod!-p(a,red b) else if isdomain b then (lt a) .+ general!-plus!-mod!-p(red a,b) else if lpow a = lpow b then adjoin!-term(lpow a, general!-plus!-mod!-p(lc a,lc b), general!-plus!-mod!-p(red a,red b)) else if comes!-before(lpow a,lpow b) then (lt a) .+ general!-plus!-mod!-p(red a,b) else (lt b) .+ general!-plus!-mod!-p(a,red b); symbolic procedure general!-times!-mod!-p(a,b); if (null a) or (null b) then nil else if isdomain a then gen!-mult!-by!-const!-mod!-p(b,a) else if isdomain b then gen!-mult!-by!-const!-mod!-p(a,b) else if mvar a=mvar b then general!-plus!-mod!-p( general!-plus!-mod!-p(general!-times!-term!-mod!-p(lt a,b), general!-times!-term!-mod!-p(lt b,red a)), general!-times!-mod!-p(red a,red b)) else if ordop(mvar a,mvar b) then adjoin!-term(lpow a,general!-times!-mod!-p(lc a,b), general!-times!-mod!-p(red a,b)) else adjoin!-term(lpow b, general!-times!-mod!-p(a,lc b),general!-times!-mod!-p(a,red b)); symbolic procedure general!-times!-term!-mod!-p(term,b); %multiply the given polynomial by the given term; if null b then nil else if isdomain b then adjoin!-term(tpow term, gen!-mult!-by!-const!-mod!-p(tc term,b),nil) else if tvar term=mvar b then adjoin!-term(mksp(tvar term,iplus(tdeg term,ldeg b)), general!-times!-mod!-p(tc term,lc b), general!-times!-term!-mod!-p(term,red b)) else if ordop(tvar term,mvar b) then adjoin!-term(tpow term,general!-times!-mod!-p(tc term,b),nil) else adjoin!-term(lpow b, general!-times!-term!-mod!-p(term,lc b), general!-times!-term!-mod!-p(term,red b)); symbolic procedure gen!-mult!-by!-const!-mod!-p(a,n); % multiply the polynomial a by the constant n; if null a then nil else if n=1 then a else if isdomain a then !*num2f general!-modular!-times(a,n) else adjoin!-term(lpow a,gen!-mult!-by!-const!-mod!-p(lc a,n), gen!-mult!-by!-const!-mod!-p(red a,n)); symbolic procedure general!-difference!-mod!-p(a,b); general!-plus!-mod!-p(a,general!-minus!-mod!-p b); symbolic procedure general!-minus!-mod!-p a; if null a then nil else if isdomain a then general!-modular!-minus a else (lpow a .* general!-minus!-mod!-p lc a) .+ general!-minus!-mod!-p red a; symbolic procedure general!-reduce!-mod!-p a; %converts a multivariate poly from normal into modular polynomial; if null a then nil else if isdomain a then !*num2f general!-modular!-number a else adjoin!-term(lpow a, general!-reduce!-mod!-p lc a, general!-reduce!-mod!-p red a); symbolic procedure general!-make!-modular!-symmetric a; % input is a multivariate MODULAR poly A with nos in the range 0->(p-1). % This folds it onto the symmetric range (-p/2)->(p/2); if null a then nil else if domainp a then if a>modulus!/2 then !*num2f(a - current!-modulus) else a else adjoin!-term(lpow a, general!-make!-modular!-symmetric lc a, general!-make!-modular!-symmetric red a); endmodule; module degsets; % degree set processing. % Authors: A. C. Norman and P. M. A. Moore, 1981. fluid '(!*trallfac !*trfac bad!-case best!-set!-pointer dpoly factor!-level factor!-trace!-list factored!-lc irreducible modular!-info one!-complete!-deg!-analysis!-done previous!-degree!-map split!-list valid!-image!-sets); symbolic procedure check!-degree!-sets(n,multivariate!-case); % MODULAR!-INFO (vector of size N) contains the modular factors now. begin scalar degree!-sets,w,x!-is!-factor,degs; w:=split!-list; for i:=1:n do << if multivariate!-case then x!-is!-factor:=not numberp get!-image!-content getv(valid!-image!-sets,cdar w); degs:=for each v in getv(modular!-info,cdar w) collect ldeg v; degree!-sets:= (if x!-is!-factor then 1 . degs else degs) . degree!-sets; w:=cdr w >>; check!-degree!-sets!-1 degree!-sets; best!-set!-pointer:=cdar split!-list; if multivariate!-case and factored!-lc then << while null(w:=get!-f!-numvec getv(valid!-image!-sets,best!-set!-pointer)) and (split!-list:=cdr split!-list) do best!-set!-pointer:=cdar split!-list; if null w then bad!-case:=t >>; % make sure the set is ok for distributing the % leading coefft where necessary; end; symbolic procedure check!-degree!-sets!-1 l; % L is a list of degree sets. Try to discover if the entries % in it are consistent, or if they imply that some of the % modular splittings were 'false'; begin scalar i,degree!-map,degree!-map1,dpoly, plausible!-split!-found,target!-count; factor!-trace << printc "Degree sets are:"; for each s in l do << prin2 " "; for each n in s do << prin2 " "; prin2 n >>; terpri() >> >>; dpoly:=sum!-list car l; target!-count:=length car l; for each s in cdr l do target!-count:=min(target!-count,length s); % This used to be IMIN, but since it was the only use, it was % eliminated. if null previous!-degree!-map then << degree!-map:=mkvect dpoly; % To begin with all degrees of factors may be possible; for i:=0:dpoly do putv(degree!-map,i,t) >> else << factor!-trace "Refine an existing degree map"; degree!-map:=previous!-degree!-map >>; degree!-map1:=mkvect dpoly; for each s in l do << % For each degree set S I will collect in DEGREE-MAP1 a % bitmap showing what degree factors would be consistent % with that set. By ANDing together all these maps % (into DEGREE-MAP) I find what degrees for factors are % consistent with the whole of the information I have; for i:=0:dpoly do putv(degree!-map1,i,nil); putv(degree!-map1,0,t); putv(degree!-map1,dpoly,t); for each d in s do for i:=dpoly#-d#-1 step -1 until 0 do if getv(degree!-map1,i) then putv(degree!-map1,i#+d,t); for i:=0:dpoly do putv(degree!-map,i,getv(degree!-map,i) and getv(degree!-map1,i)) >>; factor!-trace << printc "Possible degrees for factors are: "; for i:=1:dpoly#-1 do if getv(degree!-map,i) then << prin2 i; prin2 " " >>; terpri() >>; i:=dpoly#-1; while i#>0 do if getv(degree!-map,i) then i:=-1 else i:=i#-1; if i=0 then << factor!-trace printc "Degree analysis proves polynomial irreducible"; return irreducible:=t >>; for each s in l do if length s=target!-count then begin % Sets with too many factors are not plausible anyway; i:=s; while i and getv(degree!-map,car i) do i:=cdr i; % If I drop through with I null it was because the set was % consistent, otherwise it represented a false split; if null i then plausible!-split!-found:=t end; previous!-degree!-map:=degree!-map; if plausible!-split!-found or one!-complete!-deg!-analysis!-done then return nil; % PRINTC "Going to try getting some more images"; return bad!-case:=t end; symbolic procedure sum!-list l; if null cdr l then car l else car l #+ sum!-list cdr l; endmodule; module facmod; % Modular factorization: discover the factor count mod p. % Authors: A. C. Norman and P. M. A. Moore, 1979. fluid '(!*timings current!-modulus dpoly dwork1 dwork2 known!-factors linear!-factors m!-image!-variable modular!-info null!-space!-basis number!-needed poly!-mod!-p poly!-vector safe!-flag split!-list work!-vector1 work!-vector2); safe!-flag:=carcheck 0; % For speed of array access - important here; symbolic procedure get!-factor!-count!-mod!-p (n,poly!-mod!-p,p,x!-is!-factor); % gets the factor count mod p from the nth image using the % first half of Berlekamp's method; begin scalar old!-m,f!-count,wtime; old!-m:=set!-modulus p; % PRIN2 "prime = ";% printc current!-modulus; % PRIN2 "degree = ";% printc ldeg poly!-mod!-p; trace!-time display!-time("Entered GET-FACTOR-COUNT after ",time()); wtime:=time(); f!-count:=modular!-factor!-count(); trace!-time display!-time("Factor count obtained in ",time()-wtime); split!-list:= ((if x!-is!-factor then car f!-count#+1 else car f!-count) . n) . split!-list; putv(modular!-info,n,cdr f!-count); set!-modulus old!-m end; symbolic procedure modular!-factor!-count(); begin scalar poly!-vector,wvec1,wvec2,x!-to!-p, n,wtime,w,lin!-f!-count,null!-space!-basis; known!-factors:=nil; dpoly:=ldeg poly!-mod!-p; wvec1:=mkvect (2#*dpoly); wvec2:=mkvect (2#*dpoly); x!-to!-p:=mkvect dpoly; poly!-vector:=mkvect dpoly; for i:=0:dpoly do putv(poly!-vector,i,0); poly!-to!-vector poly!-mod!-p; w:=count!-linear!-factors!-mod!-p(wvec1,wvec2,x!-to!-p); lin!-f!-count:=car w; if dpoly#<4 then return (if dpoly=0 then lin!-f!-count else lin!-f!-count#+1) . list(lin!-f!-count . cadr w, dpoly . poly!-vector, nil); % When I use Berlekamp I certainly know that the polynomial % involved has no linear factors; wtime:=time(); null!-space!-basis:=use!-berlekamp(x!-to!-p,caddr w,wvec1); trace!-time display!-time("Berlekamp done in ",time()-wtime); n:=lin!-f!-count #+ length null!-space!-basis #+ 1; % there is always 1 more factor than the number of % null vectors we have picked up; return n . list( lin!-f!-count . cadr w, dpoly . poly!-vector, null!-space!-basis) end; %**********************************************************************; % Extraction of linear factors is done specially; symbolic procedure count!-linear!-factors!-mod!-p(wvec1,wvec2,x!-to!-p); % Compute gcd(x**p-x,u). It will be the product of all the % linear factors of u mod p; begin scalar dx!-to!-p,lin!-f!-count,linear!-factors; for i:=0:dpoly do putv(wvec2,i,getv(poly!-vector,i)); dx!-to!-p:=make!-x!-to!-p(current!-modulus,wvec1,x!-to!-p); for i:=0:dx!-to!-p do putv(wvec1,i,getv(x!-to!-p,i)); if dx!-to!-p#<1 then << if dx!-to!-p#<0 then putv(wvec1,0,0); putv(wvec1,1,modular!-minus 1); dx!-to!-p:=1 >> else << putv(wvec1,1,modular!-difference(getv(wvec1,1),1)); if dx!-to!-p=1 and getv(wvec1,1)=0 then if getv(wvec1,0)=0 then dx!-to!-p:=-1 else dx!-to!-p:=0 >>; if dx!-to!-p#<0 then lin!-f!-count:=copy!-vector(wvec2,dpoly,wvec1) else lin!-f!-count:=gcd!-in!-vector(wvec1,dx!-to!-p, wvec2,dpoly); linear!-factors:=mkvect lin!-f!-count; for i:=0:lin!-f!-count do putv(linear!-factors,i,getv(wvec1,i)); dpoly:=quotfail!-in!-vector(poly!-vector,dpoly, linear!-factors,lin!-f!-count); return list(lin!-f!-count,linear!-factors,dx!-to!-p) end; symbolic procedure make!-x!-to!-p(p,wvec1,x!-to!-p); begin scalar dx!-to!-p,dw1; if p#<dpoly then << for i:=0:p#-1 do putv(x!-to!-p,i,0); putv(x!-to!-p,p,1); return p >>; dx!-to!-p:=make!-x!-to!-p(p/2,wvec1,x!-to!-p); dw1:=times!-in!-vector(x!-to!-p,dx!-to!-p,x!-to!-p,dx!-to!-p,wvec1); dw1:=remainder!-in!-vector(wvec1,dw1, poly!-vector,dpoly); if not(iremainder(p,2)=0) then << for i:=dw1 step -1 until 0 do putv(wvec1,i#+1,getv(wvec1,i)); putv(wvec1,0,0); dw1:=remainder!-in!-vector(wvec1,dw1#+1, poly!-vector,dpoly) >>; for i:=0:dw1 do putv(x!-to!-p,i,getv(wvec1,i)); return dw1 end; symbolic procedure find!-linear!-factors!-mod!-p(p,n); % P is a vector representing a polynomial of degree N which has % only linear factors. Find all the factors and return a list of % them; begin scalar root,var,w,vec1; if n#<1 then return nil; vec1:=mkvect 1; putv(vec1,1,1); root:=0; while (n#>1) and not (root #> current!-modulus) do << w:=evaluate!-in!-vector(p,n,root); if w=0 then << %a factor has been found!!; if var=nil then var:=mksp(m!-image!-variable,1) . 1; w:=!*f2mod adjoin!-term(car var,cdr var,!*n2f modular!-minus root); known!-factors:=w . known!-factors; putv(vec1,0,modular!-minus root); n:=quotfail!-in!-vector(p,n,vec1,1) >>; root:=root#+1 >>; known!-factors:= vector!-to!-poly(p,n,m!-image!-variable) . known!-factors end; %**********************************************************************; % Berlekamp's algorithm part 1: find null space basis giving factor % count; symbolic procedure use!-berlekamp(x!-to!-p,dx!-to!-p,wvec1); % Set up a basis for the set of remaining (nonlinear) factors % using Berlekamp's algorithm; begin scalar berl!-m,berl!-m!-size,w, dcurrent,current!-power,wtime; berl!-m!-size:=dpoly#-1; berl!-m:=mkvect berl!-m!-size; for i:=0:berl!-m!-size do << w:=mkvect berl!-m!-size; for j:=0:berl!-m!-size do putv(w,j,0); %initialize to zero; putv(berl!-m,i,w) >>; % Note that column zero of the matrix (as used in the % standard version of Berlekamp's algorithm) is not in fact % needed and is not used here; % I want to set up a matrix that has entries % x**p, x**(2*p), ... , x**((n-1)*p) % as its columns, % where n is the degree of poly-mod-p % and all the entries are reduced mod poly-mod-p; % Since I computed x**p I have taken out some linear factors, % so reduce it further; dx!-to!-p:=remainder!-in!-vector(x!-to!-p,dx!-to!-p, poly!-vector,dpoly); dcurrent:=0; current!-power:=mkvect berl!-m!-size; putv(current!-power,0,1); for i:=1:berl!-m!-size do << if current!-modulus#>dpoly then dcurrent:=times!-in!-vector( current!-power,dcurrent, x!-to!-p,dx!-to!-p, wvec1) else << % Multiply by shifting; for i:=0:current!-modulus#-1 do putv(wvec1,i,0); for i:=0:dcurrent do putv(wvec1,current!-modulus#+i, getv(current!-power,i)); dcurrent:=dcurrent#+current!-modulus >>; dcurrent:=remainder!-in!-vector( wvec1,dcurrent, poly!-vector,dpoly); for j:=0:dcurrent do putv(getv(berl!-m,j),i,putv(current!-power,j, getv(wvec1,j))); % also I need to subtract 1 from the diagonal of the matrix; putv(getv(berl!-m,i),i, modular!-difference(getv(getv(berl!-m,i),i),1)) >>; wtime:=time(); % print!-m("Q matrix",berl!-m,berl!-m!-size); w := find!-null!-space(berl!-m,berl!-m!-size); trace!-time display!-time("Null space found in ",time()-wtime); return w end; symbolic procedure find!-null!-space(berl!-m,berl!-m!-size); % Diagonalize the matrix to find its rank and hence the number of % factors the input polynomial had; begin scalar null!-space!-basis; % find a basis for the null-space of the matrix; for i:=1:berl!-m!-size do null!-space!-basis:= clear!-column(i,null!-space!-basis,berl!-m,berl!-m!-size); % print!-m("Null vectored",berl!-m,berl!-m!-size); return tidy!-up!-null!-vectors(null!-space!-basis,berl!-m,berl!-m!-size) end; symbolic procedure print!-m(m,berl!-m,berl!-m!-size); << printc m; for i:=0:berl!-m!-size do << for j:=0:berl!-m!-size do << prin2 getv(getv(berl!-m,i),j); ttab((4#*j)#+4) >>; terpri() >> >>; symbolic procedure clear!-column(i, null!-space!-basis,berl!-m,berl!-m!-size); % Process column I of the matrix so that (if possible) it % just has a '1' in row I and zeros elsewhere; begin scalar ii,w; % I want to bring a non-zero pivot to the position (i,i) % and then add multiples of row i to all other rows to make % all but the i'th element of column i zero. First look for % a suitable pivot; ii:=0; search!-for!-pivot: if getv(getv(berl!-m,ii),i)=0 or ((ii#<i) and not(getv(getv(berl!-m,ii),ii)=0)) then if (ii:=ii#+1)#>berl!-m!-size then return (i . null!-space!-basis) else go to search!-for!-pivot; % Here ii references a row containing a suitable pivot element for % column i. Permute rows in the matrix so as to bring the pivot onto % the diagonal; w:=getv(berl!-m,ii); putv(berl!-m,ii,getv(berl!-m,i)); putv(berl!-m,i,w); % swop rows ii and i ; w:=modular!-minus modular!-reciprocal getv(getv(berl!-m,i),i); % w = -1/pivot, and is used in zeroing out the rest of column i; for row:=0:berl!-m!-size do if row neq i then begin scalar r; %process one row; r:=getv(getv(berl!-m,row),i); if not(r=0) then << r:=modular!-times(r,w); %that is now the multiple of row i that must be added to row ii; for col:=i:berl!-m!-size do putv(getv(berl!-m,row),col, modular!-plus(getv(getv(berl!-m,row),col), modular!-times(r,getv(getv(berl!-m,i),col)))) >> end; for col:=i:berl!-m!-size do putv(getv(berl!-m,i),col, modular!-times(getv(getv(berl!-m,i),col),w)); return null!-space!-basis end; symbolic procedure tidy!-up!-null!-vectors(null!-space!-basis, berl!-m,berl!-m!-size); begin scalar row!-to!-use; row!-to!-use:=berl!-m!-size#+1; null!-space!-basis:= for each null!-vector in null!-space!-basis collect build!-null!-vector(null!-vector, getv(berl!-m,row!-to!-use:=row!-to!-use#-1),berl!-m); berl!-m:=nil; % Release the store for full matrix; % prin2 "Null vectors: "; % print null!-space!-basis; return null!-space!-basis end; symbolic procedure build!-null!-vector(n,vec,berl!-m); % At the end of the elimination process (the CLEAR-COLUMN loop) % certain columns, indicated by the entries in NULL-SPACE-BASIS % will be null vectors, save for the fact that they need a '1' % inserted on the diagonal of the matrix. This procedure copies % these null-vectors into some of the vectors that represented % rows of the Berlekamp matrix; begin % putv(vec,0,0); % Not used later!!; for i:=1:n#-1 do putv(vec,i,getv(getv(berl!-m,i),n)); putv(vec,n,1); % for i:=n#+1:berl!-m!-size do % putv(vec,i,0); return vec . n end; %**********************************************************************; % Berlekamp's algorithm part 2: retrieving the factors mod p; symbolic procedure get!-factors!-mod!-p(n,p); % given the modular info (for the nth image) generated by the % previous half of Berlekamp's method we can reconstruct the % actual factors mod p; begin scalar nth!-modular!-info,old!-m,wtime; nth!-modular!-info:=getv(modular!-info,n); old!-m:=set!-modulus p; wtime:=time(); putv(modular!-info,n, convert!-null!-vectors!-to!-factors nth!-modular!-info); trace!-time display!-time("Factors constructed in ",time()-wtime); set!-modulus old!-m end; symbolic procedure convert!-null!-vectors!-to!-factors m!-info; % Using the null space found, complete the job % of finding modular factors by taking gcd's of the % modular input polynomial and variants on the % null space generators; begin scalar number!-needed,factors, work!-vector1,dwork1,work!-vector2,dwork2,wtime; known!-factors:=nil; wtime:=time(); find!-linear!-factors!-mod!-p(cdar m!-info,caar m!-info); trace!-time display!-time("Linear factors found in ",time()-wtime); dpoly:=caadr m!-info; poly!-vector:=cdadr m!-info; null!-space!-basis:=caddr m!-info; if dpoly=0 then return known!-factors; % All factors were linear; if null null!-space!-basis then return known!-factors:= vector!-to!-poly(poly!-vector,dpoly,m!-image!-variable) . known!-factors; number!-needed:=length null!-space!-basis; % count showing how many more factors I need to find; work!-vector1:=mkvect dpoly; work!-vector2:=mkvect dpoly; factors:=list (poly!-vector . dpoly); try!-next!-null: if null!-space!-basis=nil then errorf "RAN OUT OF NULL VECTORS TOO EARLY"; wtime:=time(); factors:=try!-all!-constants(factors, caar null!-space!-basis,cdar null!-space!-basis); trace!-time display!-time("All constants tried in ",time()-wtime); if number!-needed=0 then return known!-factors:=append!-new!-factors(factors, known!-factors); null!-space!-basis:=cdr null!-space!-basis; go to try!-next!-null end; symbolic procedure try!-all!-constants(list!-of!-polys,v,dv); % use gcd's of v, v+1, v+2, ... to try to split up the % polynomials in the given list; begin scalar a,b,aa,s; % aa is a list of factors that can not be improved using this v, % b is a list that might be; aa:=nil; b:=list!-of!-polys; s:=0; try!-next!-constant: putv(v,0,s); % Fix constant term of V to be S; % wtime:=time(); a:=split!-further(b,v,dv); % trace!-time display!-time("Polys split further in ",time()-wtime); b:=cdr a; a:=car a; aa:=nconc(a,aa); % Keep aa up to date as a list of polynomials that this poly % v can not help further with; if b=nil then return aa; % no more progress possible here; if number!-needed=0 then return nconc(b,aa); % no more progress needed; s:=s#+1; if s#<current!-modulus then go to try!-next!-constant; % Here I have run out of choices for the constant % coefficient in v without splitting everything; return nconc(b,aa) end; symbolic procedure split!-further(list!-of!-polys,v,dv); % list-of-polys is a list of polynomials. try to split % its members further by taking gcd's with the polynomial % v. return (a . b) where the polys in a can not possibly % be split using v+constant, but the polys in b might % be; if null list!-of!-polys then nil . nil else begin scalar a,b,gg,q; a:=split!-further(cdr list!-of!-polys,v,dv); b:=cdr a; a:=car a; if number!-needed=0 then go to no!-split; % if all required factors have been found there is no need to % search further; dwork1:=copy!-vector(v,dv,work!-vector1); dwork2:=copy!-vector(caar list!-of!-polys,cdar list!-of!-polys, work!-vector2); dwork1:=gcd!-in!-vector(work!-vector1,dwork1, work!-vector2,dwork2); if dwork1=0 or dwork1=cdar list!-of!-polys then go to no!-split; dwork2:=copy!-vector(caar list!-of!-polys,cdar list!-of!-polys, work!-vector2); dwork2:=quotfail!-in!-vector(work!-vector2,dwork2, work!-vector1,dwork1); % Here I have a splitting; gg:=mkvect dwork1; copy!-vector(work!-vector1,dwork1,gg); a:=((gg . dwork1) . a); copy!-vector(work!-vector2,dwork2,q:=mkvect dwork2); b:=((q . dwork2) . b); number!-needed:=number!-needed#-1; return (a . b); no!-split: return (a . ((car list!-of!-polys) . b)) end; symbolic procedure append!-new!-factors(a,b); % Convert to REDUCE (rather than vector) form; if null a then b else vector!-to!-poly(caar a,cdar a,m!-image!-variable) . append!-new!-factors(cdr a,b); carcheck safe!-flag; % Restore status quo; endmodule; module factrr; % Full factorization of polynomials. % Author: P. M. A. Moore, 1979. fluid '(!*all!-contents !*exp !*ezgcd !*force!-prime !*gcd !*kernreverse !*mcd !*timings !*trfac base!-time current!-modulus dmode!* factor!-count factor!-level factor!-trace!-list gc!-base!-time last!-displayed!-gc!-time last!-displayed!-time m!-image!-variable modulus!/2 polynomial!-to!-factor polyzero); global '(!*ifactor); symbolic procedure factoreval u; % Factorize the polynomial in the car of u, returning the factors found. % If cadr u exists then if it is a number, use it as a force prime. % Otherwise, use cadr u as a fill object, and check to see if caddr u % is now a force prime. begin scalar p,w,!*force!-prime,x,z,factor!-count; p := length u; if p<1 or p>3 then rederr "FACTORIZE called with wrong number of arguments"; p := !*q2f simp!* car u; if cdr u then <<w := cadr u; if fixp w then <<!*force!-prime := w; w := nil>> else if cddr u and fixp caddr u then !*force!-prime := caddr u; if !*force!-prime and not primep !*force!-prime then typerr(!*force!-prime,"prime")>>; x := if dmode!* then if z := get(dmode!*,'factorfn) then apply1(z,p) else rederr list("Factorization not supported over domain", get(dmode!*,'dname)) else factorf1(p,!*force!-prime); % Note that car x is expected to be a number. z:= (0 . car x) . nil; x := reversip!* cdr x; % This puts factors in better order. factor!-count:=0; for each fff in x do for i:=1:cdr fff do z:=((factor!-count:=factor!-count+1) . mk!*sq(car fff ./ 1)) . z; z := multiple!-result(z,w); if numberp z then return z % old style input else if numberp cadr z and cadr z<0 and cddr z then z := car z . (- cadr z) . mk!*sq negsq simp caddr z . cdddr z; % make numerical coefficient positive. return if cadr z = 1 then car z . cddr z else if !*ifactor and numberp cadr z and fixp cadr z then car z . append(pairlist2list reversip zfactor cadr z, cddr z) else z end; put('factorize,'psopfn,'factoreval); symbolic procedure pairlist2list u; for each x in u conc nlist(car x,cdr x); symbolic procedure factorf u; % This is the entry to the factorizer that is to be used by programmers % working at the symbolic level. U is to be a standard form. FACTORF % hands back a list giving the factors of U. The format of said list is % described below in the comments with FACTORIZE!-FORM. Entry to the % factorizer at any level other than this is at the programmers own % risk!! ; factorf1(u,nil); symbolic procedure factorf1(u,!*force!-prime); % This entry to the factorizer allows one to force % the code to use some particular prime for its % modular factorization. It is not for casual % use; begin scalar factor!-level,base!-time,last!-displayed!-time, gc!-base!-time,last!-displayed!-gc!-time,current!-modulus, modulus!/2,expsave,!*ezgcd,!*gcd; if null !*mcd then rederr "Factorization invalid with MCD off"; expsave := !*exp; !*exp := !*gcd := t; % This code will not work otherwise; !*ezgcd := t; if null expsave then u := !*q2f resimp !*f2q u; set!-time(); factor!-level := 0; u := factorize!-form u; !*exp := expsave; return u end; symbolic procedure factorize!-form p; % input: % p is a reduce standard form that is to be factorized % over the integers % result: (nc . l) % where nc is numeric (may be just 1) % and l is list of the form: % ((p1 . x1) (p2 . x2) .. (pn . xn)) % where p<i> are standard forms and x<i> are integers, % and p= product<i> p<i>**x<i>; % % method: % (a) reorder polynomial to make the variable of lowest maximum % degree the main one and the rest ordered similarly; % (b) use contents and primitive parts to split p up as far as possible % (c) use square-free decomposition to continue the process % (c.1) detect & perform special processing on cyclotomic polynomials % (d) use modular-based method to find factors over integers; begin scalar new!-korder,old!-korder; new!-korder:=kernord(p,polyzero); if !*kernreverse then new!-korder:=reverse new!-korder; old!-korder:=setkorder new!-korder; p:=reorder p; % Make var of lowest degree the main one; p:=factorize!-form1(p,new!-korder); setkorder old!-korder; p := (car p . for each w in cdr p collect (reorder car w . cdr w)); return p end; symbolic procedure factorize!-form1(p,given!-korder); % input: % p is a reduce standard form that is to be factorized % over the integers % given-korder is a list of kernels in the order of importance % (ie when finding leading terms etc. we use this list) % See FACTORIZE-FORM above; if domainp p then (p . nil) else begin scalar m!-image!-variable,var!-list, polynomial!-to!-factor,n; if !*all!-contents then var!-list:=given!-korder else << m!-image!-variable:=car given!-korder; var!-list:=list m!-image!-variable >>; return (lambda factor!-level; << factor!-trace << prin2!* "FACTOR : "; printsf p; prin2!* "Chosen main variable is "; printvar m!-image!-variable >>; polynomial!-to!-factor:=p; n:=numeric!-content p; p:=quotf(p,n); if poly!-minusp p then << p:=negf p; n:=-n >>; factor!-trace << prin2!* "Numeric content = "; printsf n >>; p:=factorize!-by!-contents(p,var!-list); p:=n . sort!-factors p; factor!-trace << terpri(); terpri(); printstr "Final result is:"; fac!-printfactors p >>; p >>) (factor!-level+1) end; symbolic procedure factorize!-form!-recursion p; % this is essentially the same as FACTORIZE!-FORM except that % we must be careful of stray minus signs due to a possible % reordering in the recursive factoring; begin scalar s,n,x,res,new!-korder,old!-korder; new!-korder:=kernord(p,polyzero); if !*kernreverse then new!-korder:=reverse new!-korder; old!-korder:=setkorder new!-korder; p:=reorder p; % Make var of lowest degree the main one; x:=factorize!-form1(p,new!-korder); setkorder old!-korder; n := car x; x := for each p in cdr x collect (reorder car p . cdr p); if minusp n then << s:=-1; n:=-n >> else s:=1; res:=for each ff in x collect if poly!-minusp car ff then << s:=s*((-1)**cdr ff); (negf car ff . cdr ff) >> else ff; if minusp s then errorf list( "Stray minus sign in recursive factorisation:",x); return (n . res) end; symbolic procedure sort!-factors l; %sort factors as found into some sort of standard order. The order %used here is more or less random, but will be self-consistent; sort(l,function orderfactors); % ***** Contents and primitive parts as applied to factorization ***** symbolic procedure factorize!-by!-contents(p,v); %use contents wrt variables in list v to split the %polynomial p. return a list of factors; % specification is that on entry p *must* be positive; if domainp p then errorf list("FACTORIZE-BY-CONTENTS HANDED DOMAIN ELT:",p) else if null v then square!.free!.factorize p else begin scalar c,w,l,wtime; w:=contents!-with!-respect!-to(p,car v); % contents!-with!-respect!-to returns a pair (g . c) where % if g=nil the content is just c, otherwise g is a power % [ x ** n ] and g*c is the content; if not null car w then << % here a power of v divides p; l:=(!*k2f caar w . cdar w) . nil; p:=quotfail(p,!*p2f car w); if p=1 then return l else if domainp p then errorf "P SHOULD NOT BE CONSTANT HERE" >>; c:=cdr w; if c=1 then << %no progress here; if null l then factor!-trace << prin2!* "Polynomial is primitive wrt "; prinvar car v; terpri!*(nil) >> else factor!-trace << printstr "Content is: "; fac!-printfactors(1 . l) >>; return if !*all!-contents then append(factorize!-by!-contents(p,cdr v),l) else append(square!.free!.factorize p,l) >>; p:=quotfail(p,c); %primitive part; % p is now primitive, so if it is not a real polynomial it % must be a unit. since input was +ve it had better be +1 !! ; if p=-1 then errorf "NEGATIVE PRIMITIVE PART IN FACTORIZE-BY-CONTENTS"; trace!-time printc "Factoring the content:"; wtime:=time(); l:=append(cdr1 factorize!-form!-recursion c,l); trace!-time display!-time("Content factored in ", time()-wtime); factor!-trace << prin2!* "Content wrt "; prinvar car v; prin2!* " is: "; printsf comfac!-to!-poly w; printstr "Factors of content are: "; fac!-printfactors(1 . l) >>; if p=1 then return l else if !*all!-contents then return append(factorize!-by!-contents(p,cdr v),l) else return append(square!.free!.factorize p,l) end; symbolic procedure cdr1 a; if car a=1 then cdr a else errorf list("NUMERIC CONTENT NOT EXTRACTED:",car a); endmodule; module facuni; % Authors: A. C. Norman and P. M. A. Moore, 1979; fluid '(!*force!-prime !*trfac alphalist bad!-case best!-factor!-count best!-known!-factors best!-modulus best!-set!-pointer chosen!-prime factor!-level factor!-trace!-list forbidden!-primes hensel!-growth!-size input!-leading!-coefficient input!-polynomial irreducible known!-factors m!-image!-variable modular!-info no!-of!-best!-primes no!-of!-random!-primes non!-monic null!-space!-basis number!-of!-factors one!-complete!-deg!-analysis!-done poly!-mod!-p previous!-degree!-map reduction!-count split!-list target!-factor!-count univariate!-factors univariate!-input!-poly valid!-primes); symbolic procedure univariate!-factorize poly; % input poly a primitive square-free univariate polynomial at least % quadratic and with +ve lc. output is a list of the factors of poly % over the integers ; if testx!*!*n!+1 poly then factorizex!*!*n!+1(m!-image!-variable,ldeg poly,1) else if testx!*!*n!-1 poly then factorizex!*!*n!-1(m!-image!-variable,ldeg poly,1) else univariate!-factorize1 poly; symbolic procedure univariate!-factorize1 poly; begin scalar valid!-primes,univariate!-input!-poly,best!-set!-pointer, number!-of!-factors,irreducible,forbidden!-primes, no!-of!-best!-primes,no!-of!-random!-primes,bad!-case, target!-factor!-count,modular!-info,univariate!-factors, hensel!-growth!-size,alphalist,previous!-degree!-map, one!-complete!-deg!-analysis!-done,reduction!-count, multivariate!-input!-poly; %note that this code works by using a local database of %fluid variables that are updated by the subroutines directly %called here. this allows for the relativly complicated %interaction between flow of data and control that occurs in %the factorization algorithm; factor!-trace << prin2!* "Univariate polynomial="; printsf poly; printstr "The polynomial is univariate, primitive and square-free"; printstr "so we can treat it slightly more specifically. We"; printstr "factorise mod several primes,then pick the best one"; printstr "to use in the Hensel construction." >>; initialize!-univariate!-fluids poly; % set up the fluids to start things off; tryagain: get!-some!-random!-primes(); choose!-the!-best!-prime(); if irreducible then << univariate!-factors:=list univariate!-input!-poly; goto exit >> else if bad!-case then << bad!-case:=nil; goto tryagain >>; reconstruct!-factors!-over!-integers(); if irreducible then << univariate!-factors:=list univariate!-input!-poly; goto exit >>; exit: factor!-trace << printstr "The univariate factors are:"; for each ff in univariate!-factors do printsf ff >>; return univariate!-factors end; %********************************************************************** % univariate factorization part 1. initialization and setting fluids; symbolic procedure initialize!-univariate!-fluids u; % Set up the fluids to be used in factoring primitive poly; begin if !*force!-prime then << no!-of!-random!-primes:=1; no!-of!-best!-primes:=1 >> else << no!-of!-random!-primes:=5; % we generate this many modular images and calculate % their factor counts; no!-of!-best!-primes:=3; % we find the modular factors of this many; >>; univariate!-input!-poly:=u; target!-factor!-count:=ldeg u end; %**********************************************************************; % univariate factorization part 2. creating modular images and picking % the best one; symbolic procedure get!-some!-random!-primes(); % here we create a number of random primes to reduce the input mod p; begin scalar chosen!-prime,poly!-mod!-p,i; valid!-primes:=mkvect no!-of!-random!-primes; i:=0; while i < no!-of!-random!-primes do << poly!-mod!-p:= find!-a!-valid!-prime(lc univariate!-input!-poly, univariate!-input!-poly,nil); if not(poly!-mod!-p='not!-square!-free) then << i:=iadd1 i; putv(valid!-primes,i,chosen!-prime . poly!-mod!-p); forbidden!-primes:=chosen!-prime . forbidden!-primes >> >> end; symbolic procedure choose!-the!-best!-prime(); % given several random primes we now choose the best by factoring % the poly mod its chosen prime and taking one with the % lowest factor count as the best for hensel growth; begin scalar split!-list,poly!-mod!-p,null!-space!-basis, known!-factors,w,n; modular!-info:=mkvect no!-of!-random!-primes; for i:=1:no!-of!-random!-primes do << w:=getv(valid!-primes,i); get!-factor!-count!-mod!-p(i,cdr w,car w,nil) >>; split!-list:=sort(split!-list,function lessppair); % this now contains a list of pairs (m . n) where % m is the no: of factors in set no: n. the list % is sorted with best split (smallest m) first; if caar split!-list = 1 then << irreducible:=t; return nil >>; w:=split!-list; for i:=1:no!-of!-best!-primes do << n:=cdar w; get!-factors!-mod!-p(n,car getv(valid!-primes,n)); w:=cdr w >>; % pick the best few of these and find out their % factors mod p; split!-list:=delete(w,split!-list); % throw away the other sets; check!-degree!-sets(no!-of!-best!-primes,nil); % the best set is pointed at by best!-set!-pointer; one!-complete!-deg!-analysis!-done:=t; factor!-trace << w:=getv(valid!-primes,best!-set!-pointer); prin2!* "The chosen prime is "; printstr car w; prin2!* "The polynomial mod "; prin2!* car w; printstr ", made monic, is:"; printsf cdr w; printstr "and the factors of this modular polynomial are:"; for each x in getv(modular!-info,best!-set!-pointer) do printsf x; >> end; %**********************************************************************; % univariate factorization part 3. reconstruction of the % chosen image over the integers; symbolic procedure reconstruct!-factors!-over!-integers(); % the hensel construction from modular case to univariate % over the integers; begin scalar best!-modulus,best!-factor!-count,input!-polynomial, input!-leading!-coefficient,best!-known!-factors,s; s:=getv(valid!-primes,best!-set!-pointer); best!-known!-factors:=getv(modular!-info,best!-set!-pointer); input!-leading!-coefficient:=lc univariate!-input!-poly; best!-modulus:=car s; best!-factor!-count:=length best!-known!-factors; input!-polynomial:=univariate!-input!-poly; univariate!-factors:=reconstruct!.over!.integers(); if irreducible then return t; number!-of!-factors:=length univariate!-factors; if number!-of!-factors=1 then return irreducible:=t end; symbolic procedure reconstruct!.over!.integers(); begin scalar w,lclist,non!-monic; set!-modulus best!-modulus; for i:=1:best!-factor!-count do lclist:=input!-leading!-coefficient . lclist; if not (input!-leading!-coefficient=1) then << best!-known!-factors:= for each ff in best!-known!-factors collect multf(input!-leading!-coefficient,!*mod2f ff); non!-monic:=t; factor!-trace << printstr "(a) Now the polynomial is not monic so we multiply each"; printstr "of the modular factors, f(i), by the absolute value of"; prin2!* "the leading coefficient: "; prin2!* input!-leading!-coefficient; printstr '!.; printstr "To bring the polynomial into agreement with this, we"; prin2!* "multiply it by "; if best!-factor!-count > 2 then << prin2!* input!-leading!-coefficient; prin2!* "**"; printstr isub1 best!-factor!-count >> else printstr input!-leading!-coefficient >> >>; w:=uhensel!.extend(input!-polynomial, best!-known!-factors,lclist,best!-modulus); if irreducible then return t; if car w ='ok then return cdr w else errorf w end; % Now some special treatment for cyclotomic polynomials; symbolic procedure testx!*!*n!+1 u; not domainp u and ( lc u=1 and red u = 1); symbolic procedure testx!*!*n!-1 u; not domainp u and ( lc u=1 and red u = -1); symbolic procedure factorizex!*!*n!+1(var,degree,vorder); % Deliver factors of (VAR**VORDER)**DEGREE+1 given that it is % appropriate to treat VAR**VORDER as a kernel; if evenp degree then factorizex!*!*n!+1(var,degree/2,2*vorder) else begin scalar w; w := factorizex!*!*n!-1(var,degree,vorder); w := negf car w . cdr w; return for each p in w collect negate!-variable(var,2*vorder,p) end; symbolic procedure negate!-variable(var,vorder,p); % VAR**(VORDER/2) -> -VAR**(VORDER/2) in the polynomial P; if domainp p then p else if mvar p=var then if remainder(ldeg p,vorder)=0 then lt p .+ negate!-variable(var,vorder,red p) else (lpow p .* negf lc p) .+ negate!-variable(var,vorder,red p) else (lpow p .* negate!-variable(var,vorder,lc p)) .+ negate!-variable(var,vorder,red p); symbolic procedure integer!-factors n; % Return integer factors of N, with attached multiplicities. Assumes % that N is fairly small; begin scalar l,q,m,w; % L is list of results generated so far, Q is current test divisor, % and M is associated multiplicity; if n=1 then return '((1 . 1)); q := 2; m := 0; % Test divide by 2,3,5,7,9,11,13,... top: w := divide(n,q); while cdr w=0 do << n := car w; w := divide(n,q); m := m+1 >>; if not m=0 then l := (q . m) . l; if q>car w then << if not n=1 then l := (n . 1) . l; return reversewoc l >>; % q := ilogor(1,iadd1 q); q := iadd1 q; if q #> 3 then q := iadd1 q; m := 0; go to top end; symbolic procedure factored!-divisors fl; % FL is an association list of primes and exponents. Return a list % of all subsets of this list, i.e. of numbers dividing the % original integer. Exclude '1' from the list; if null fl then nil else begin scalar l,w; w := factored!-divisors cdr fl; l := w; for i := 1:cdar fl do << l := list (caar fl . i) . l; for each p in w do l := ((caar fl . i) . p) . l >>; return l end; symbolic procedure factorizex!*!*n!-1(var,degree,vorder); if evenp degree then append(factorizex!*!*n!+1(var,degree/2,vorder), factorizex!*!*n!-1(var,degree/2,vorder)) else if degree=1 then list((mksp(var,vorder) .* 1) .+ (-1)) else begin scalar facdeg; facdeg := '((1 . 1)) . factored!-divisors integer!-factors degree; return for each fl in facdeg collect cyclotomic!-polynomial(var,fl,vorder) end; symbolic procedure cyclotomic!-polynomial(var,fl,vorder); % Create Psi<degree>(var**order) % where degree is given by the association list of primes and % multiplicities FL; if not cdar fl=1 then cyclotomic!-polynomial(var,(caar fl . sub1 cdar fl) . cdr fl, vorder*caar fl) else if cdr fl=nil then if caar fl=1 then (mksp(var,vorder) .* 1) .+ (-1) else quotfail((mksp(var,vorder*caar fl) .* 1) .+ (-1), (mksp(var,vorder) .* 1) .+ (-1)) else quotfail(cyclotomic!-polynomial(var,cdr fl,vorder*caar fl), cyclotomic!-polynomial(var,cdr fl,vorder)); endmodule; module imageset; % Authors: A. C. Norman and P. M. A. Moore, 1979; fluid '(!*force!-prime !*force!-zero!-set !*timings !*trfac bad!-case chosen!-prime current!-modulus f!-numvec factor!-level factor!-trace!-list factor!-x factored!-lc forbidden!-primes forbidden!-sets image!-content image!-lc image!-mod!-p image!-poly image!-set image!-set!-modulus kord!* m!-image!-variable modulus!/2 multivariate!-input!-poly no!-of!-primes!-to!-try othervars polyzero save!-zset usable!-set!-found vars!-to!-kill zero!-set!-tried zerovarset zset); %*******************************************************************; % % this section deals with the image sets used in % factorising multivariate polynomials according % to wang's theories. % ref: math. comp. vol.32 no.144 oct 1978 pp 1217-1220 % 'an improved multivariate polynomial factoring algorithm' % %*******************************************************************; %*******************************************************************; % first we have routines for generating the sets %*******************************************************************; symbolic procedure generate!-an!-image!-set!-with!-prime good!-set!-needed; % given a multivariate poly (in a fluid) we generate an image set % to make it univariate and also a random prime to use in the % modular factorization. these numbers are random except that % we will not allow anything in forbidden!-sets or forbidden!-primes; begin scalar currently!-forbidden!-sets,u,wtime; u:=multivariate!-input!-poly; % a bit of a handful to type otherwise!!!! ; image!-set:=nil; currently!-forbidden!-sets:=forbidden!-sets; tryanotherset: if image!-set then currently!-forbidden!-sets:=image!-set . currently!-forbidden!-sets; wtime:=time(); image!-set:=get!-new!-set currently!-forbidden!-sets; % princ "Trying imageset= "; % printc image!-set; trace!-time << display!-time(" New image set found in ",time()-wtime); wtime:=time() >>; image!-lc:=make!-image!-lc!-list(lc u,image!-set); % list of image lc's wrt different variables in IMAGE-SET; % princ "Image set to try is:";% printc image!-set; % prin2!* "L.C. of poly is:";% printsf lc u; % printc "Image l.c.s with variables substituted on order:"; % for each imlc in image!-lc do printsf imlc; trace!-time display!-time(" Image of lc made in ",time()-wtime); if (caar image!-lc)=0 then goto tryanotherset; wtime:=time(); image!-poly:=make!-image(u,image!-set); trace!-time << display!-time(" Image poly made in ",time()-wtime); wtime:=time() >>; image!-content:=get!.content image!-poly; % note: the content contains the image variable if it % is a factor of the image poly; trace!-time display!-time(" Content found in ",time()-wtime); image!-poly:=quotfail(image!-poly,image!-content); % make sure the image polynomial is primitive which includes % making the leading coefft positive (-ve content if % necessary). % If the image polynomial was of the form k*v^2 where v is % the image variable then GET.CONTENT will have taken out % one v and the k leaving the polynomial v here. % Divisibility by v here thus indicates that the image was % not square free, and so we will not be able to find a % sensible prime to use. if not didntgo quotf(image!-poly,!*k2f m!-image!-variable) then go to tryanotherset; wtime:=time(); image!-mod!-p:=find!-a!-valid!-prime(image!-lc,image!-poly, not numberp image!-content); if image!-mod!-p='not!-square!-free then goto tryanotherset; trace!-time << display!-time(" Prime and image mod p found in ",time()-wtime); wtime:=time() >>; if factored!-lc then if f!-numvec:=unique!-f!-nos(factored!-lc,image!-content, image!-set) then << usable!-set!-found:=t; trace!-time display!-time(" Nos for lc found in ",time()-wtime) >> else << trace!-time display!-time(" Nos for lc failed in ", time()-wtime); if (not usable!-set!-found) and good!-set!-needed then goto tryanotherset >> end; symbolic procedure get!-new!-set forbidden!-s; % associate each variable in vars-to-kill with a random no. mod % image-set-modulus. If the boolean tagged with a variable is true then % a value of 1 or 0 is no good and so rejected, however all other % variables can take these values so they are tried exhaustively before % using truly random values. sets in forbidden!-s not allowed; begin scalar old!.m,alist,n,nextzset,w; if zero!-set!-tried then << if !*force!-zero!-set then errorf "Zero set tried - possibly it was invalid"; image!-set!-modulus:=iadd1 image!-set!-modulus; old!.m:=set!-modulus image!-set!-modulus; alist:=for each v in vars!-to!-kill collect << n:=modular!-number next!-random!-number(); if n>modulus!/2 then n:=n-current!-modulus; if cdr v then << while n=0 or n=1 or (n = (isub1 current!-modulus)) do n:=modular!-number next!-random!-number(); if n>modulus!/2 then n:=n-current!-modulus >>; car v . n >> >> else << old!.m:=set!-modulus image!-set!-modulus; nextzset:=car zset; alist:=for each zv in zerovarset collect << w:=zv . car nextzset; nextzset:=cdr nextzset; w >>; if othervars then alist:= append(alist,for each v in othervars collect << n:=modular!-number next!-random!-number(); while n=0 or n=1 or (n = (isub1 current!-modulus)) do n:=modular!-number next!-random!-number(); if n>modulus!/2 then n:=n-current!-modulus; v . n >>); if null(zset:=cdr zset) then if null save!-zset then zero!-set!-tried:=t else zset:=make!-next!-zset save!-zset; alist:=for each v in cdr kord!* collect atsoc(v,alist); % Puts the variables in alist in the right order; >>; set!-modulus old!.m; return if member(alist,forbidden!-s) then get!-new!-set forbidden!-s else alist end; %********************************************************************** % now given an image/univariate polynomial find a suitable random prime; symbolic procedure find!-a!-valid!-prime(lc!-u,u,factor!-x); % finds a suitable random prime for reducing a poly mod p. % u is the image/univariate poly. we are not allowed to use % any of the primes in forbidden!-primes (fluid). % lc!-u is either numeric or (in the multivariate case) a list of % images of the lc; begin scalar currently!-forbidden!-primes,res,prime!-count,v,w; if factor!-x then u:=multf(u,v:=!*k2f m!-image!-variable); chosen!-prime:=nil; currently!-forbidden!-primes:=forbidden!-primes; prime!-count:=1; tryanotherprime: if chosen!-prime then currently!-forbidden!-primes:=chosen!-prime . currently!-forbidden!-primes; chosen!-prime:=get!-new!-prime currently!-forbidden!-primes; set!-modulus chosen!-prime; if not atom lc!-u then << w:=lc!-u; while w and ((domainp caar w and not(modular!-number caar w = 0)) or not (domainp caar w or modular!-number l!-numeric!-c(caar w,cdar w)=0)) do w:=cdr w; if w then goto tryanotherprime >> else if modular!-number lc!-u=0 then goto tryanotherprime; res:=monic!-mod!-p reduce!-mod!-p u; if not square!-free!-mod!-p res then if multivariate!-input!-poly and (prime!-count:=prime!-count+1)>no!-of!-primes!-to!-try then <<no!-of!-primes!-to!-try := no!-of!-primes!-to!-try+1; res:='not!-square!-free>> else goto tryanotherprime; if factor!-x and not(res='not!-square!-free) then res:=quotfail!-mod!-p(res,!*f2mod v); return res end; symbolic procedure get!-new!-prime forbidden!-p; % get a small prime that is not in the list forbidden!-p; % we pick one of the first 10 primes if we can; if !*force!-prime then !*force!-prime else begin scalar p,primes!-done; for each pp in forbidden!-p do if pp<32 then primes!-done:=pp.primes!-done; tryagain: if null(p:=random!-teeny!-prime primes!-done) then << p:=random!-small!-prime(); primes!-done:='all >> else primes!-done:=p . primes!-done; if member(p,forbidden!-p) then goto tryagain; return p end; %*********************************************************************** % find the numbers associated with each factor of the leading % coefficient of our multivariate polynomial. this will help % to distribute the leading coefficient later.; symbolic procedure unique!-f!-nos(v,cont!.u0,im!.set); % given an image set (im!.set), this finds the numbers associated with % each factor in v subject to wang's condition (2) on the image set. % this is an implementation of his algorithm n. if the condition % is met the result is a vector containing the images of each factor % in v, otherwise the result is nil; begin scalar d,k,q,r,lc!.image!.vec; % v's integer factor is at the front: ; k:=length cdr v; % no. of non-trivial factors of v; if not numberp cont!.u0 then cont!.u0:=lc cont!.u0; putv(d:=mkvect k,0,abs(cont!.u0 * car v)); % d will contain the special numbers to be used in the % loop below; putv(lc!.image!.vec:=mkvect k,0,abs(cont!.u0 * car v)); % vector for result with 0th entry filled in; v:=cdr v; % throw away integer factor of v; % k is no. of non-trivial factors (say f(i)) in v; % d will contain the nos. associated with each f(i); % v is now a list of the f(i) (and their multiplicities); for i:=1:k do << q:=abs make!-image(caar v,im!.set); putv(lc!.image!.vec,i,q); v:=cdr v; for j:=isub1 i step -1 until 0 do << r:=getv(d,j); while not onep r do << r:=gcd(r,q); q:=q/r >>; if onep q then <<lc!.image!.vec:=nil; j := -1>> % if q=1 here then we have failed the condition so exit; >>; if null lc!.image!.vec then i := k+1 else putv(d,i,q); % else q is the ith number we want; >>; return lc!.image!.vec end; symbolic procedure get!.content u; % u is a univariate square free poly. gets the content of u (=integer); % if lc u is negative then the minus sign is pulled out as well; % nb. the content includes the variable if it is a factor of u; begin scalar c; c:=if poly!-minusp u then -(numeric!-content u) else numeric!-content u; if not didntgo quotf(u,!*k2f m!-image!-variable) then c:=adjoin!-term(mksp(m!-image!-variable,1),c,polyzero); return c end; %********************************************************************; % finally we have the routines that use the numbers generated % by unique.f.nos to determine the true leading coeffts in % the multivariate factorization we are doing and which image % factors will grow up to have which true leading coefft. %********************************************************************; symbolic procedure distribute!.lc(r,im!.factors,s,v); % v is the factored lc of a poly, say u, whose image factors (r of % them) are in the vector im.factors. s is a list containing the % image information including the image set, the image poly etc. % this uses wang's ideas for distributing the factors in v over % those in im.factors. result is (delta . vector of the lc's of % the full factors of u) , where delta is the remaining integer part % of the lc that we have been unable to distribute. ; (lambda factor!-level; begin scalar k,delta,div!.count,q,uf,i,d,max!.mult,f,numvec, dvec,wvec,dtwid,w; delta:=get!-image!-content s; % the content of the u image poly; dist!.lc!.msg1(delta,im!.factors,r,s,v); v:=cdr v; % we are not interested in the numeric factors of v; k:=length v; % number of things to distribute; numvec:=get!-f!-numvec s; % nos. associated with factors in v; dvec:=mkvect r; wvec:=mkvect r; for j:=1:r do << putv(dvec,j,1); putv(wvec,j,delta*lc getv(im!.factors,j)) >>; % result lc's will go into dvec which we initialize to 1's; % wvec is a work vector that we use in the division process % below; v:=reverse v; for j:=k step -1 until 1 do << % (for each factor in v, call it f(j) ); f:=caar v; % f(j) itself; max!.mult:=cdar v; % multiplicity of f(j) in v (=lc u); v:=cdr v; d:=getv(numvec,j); % number associated with f(j); i:=1; % we trial divide d into lc of each image % factor starting with 1st; div!.count:=0; % no. of d's that have been distributed; factor!-trace << prin2!* "f("; prin2!* j; prin2!* ")= "; printsf f; prin2!* "There are "; prin2!* max!.mult; printstr " of these in the leading coefficient."; prin2!* "The absolute value of the image of f("; prin2!* j; prin2!* ")= "; printstr d >>; while ilessp(div!.count,max!.mult) and not igreaterp(i,r) do << q:=divide(getv(wvec,i),d); % first trial division; factor!-trace << prin2!* " Trial divide into "; prin2!* getv(wvec,i); printstr " :" >>; while (zerop cdr q) and ilessp(div!.count,max!.mult) do << putv(dvec,i,multf(getv(dvec,i),f)); % f(j) belongs in lc of ith factor; factor!-trace << prin2!* " It goes so an f("; prin2!* j; prin2!* ") belongs in "; printsf getv(im!.factors,i); printstr " Try again..." >>; div!.count:=iadd1 div!.count; % another d done; putv(wvec,i,car q); % save the quotient for next factor to distribute; q:=divide(car q,d); % try again; >>; i:=iadd1 i; % as many d's as possible have gone into that % factor so now try next factor; factor!-trace <<printstr " no good so try another factor ..." >>>>; % at this point the whole of f(j) should have been % distributed by dividing d the maximum no. of times % (= max!.mult), otherwise we have an extraneous factor; if ilessp(div!.count,max!.mult) then <<bad!-case:=t; div!.count := max!.mult>> >>; if bad!-case then return; dist!.lc!.msg2(dvec,im!.factors,r); if onep delta then << for j:=1:r do << w:=lc getv(im!.factors,j) / evaluate!-in!-order(getv(dvec,j),get!-image!-set s); if w<0 then begin scalar oldpoly; delta:= -delta; oldpoly:=getv(im!.factors,j); putv(im!.factors,j,negf oldpoly); % to keep the leading coefficients positive we negate the % image factors when necessary; multiply!-alphas(-1,oldpoly,getv(im!.factors,j)); % remember to fix the alphas as well; end; putv(dvec,j,multf(abs w,getv(dvec,j))) >>; dist!.lc!.msg3(dvec,im!.factors,r); return (delta . dvec) >>; % if delta=1 then we know the true lc's exactly so put in their % integer contents and return with result. % otherwise try spreading delta out over the factors: ; dist!.lc!.msg4 delta; for j:=1:r do << dtwid:=evaluate!-in!-order(getv(dvec,j),get!-image!-set s); uf:=getv(im!.factors,j); d:=gcddd(lc uf,dtwid); putv(dvec,j,multf(lc uf/d,getv(dvec,j))); putv(im!.factors,j,multf(dtwid/d,uf)); % have to fiddle the image factors by an integer multiple; multiply!-alphas!-recip(dtwid/d,uf,getv(im!.factors,j)); % fix the alphas; delta:=delta/(dtwid/d) >>; % now we've done all we can to distribute delta so we return with % what's left: ; if delta<=0 then errorf list("FINAL DELTA IS -VE IN DISTRIBUTE!.LC",delta); factor!-trace << printstr " Finally we have:"; for j:=1:r do << prinsf getv(im!.factors,j); prin2!* " with l.c. "; printsf getv(dvec,j) >> >>; return (delta . dvec) end) (factor!-level * 10); symbolic procedure dist!.lc!.msg1(delta,im!.factors,r,s,v); factor!-trace << terpri(); terpri(); printstr "We have a polynomial whose image factors (call"; printstr "them the IM-factors) are:"; prin2!* delta; printstr " (= numeric content, delta)"; printvec(" f(",r,")= ",im!.factors); prin2!* " wrt the image set: "; for each x in get!-image!-set s do << prinvar car x; prin2!* "="; prin2!* cdr x; prin2!* ";" >>; terpri!*(nil); printstr "We also have its true multivariate leading"; printstr "coefficient whose factors (call these the"; printstr "LC-factors) are:"; fac!-printfactors v; printstr "We want to determine how these LC-factors are"; printstr "distributed over the leading coefficients of each"; printstr "IM-factor. This enables us to feed the resulting"; printstr "image factors into a multivariate Hensel"; printstr "construction."; printstr "We distribute each LC-factor in turn by dividing"; printstr "its image into delta times the leading coefficient"; printstr "of each IM-factor until it finds one that it"; printstr "divides exactly. The image set is chosen such that"; printstr "this will only happen for the IM-factors to which"; printstr "this LC-factor belongs - (there may be more than"; printstr "one if the LC-factor occurs several times in the"; printstr "leading coefficient of the original polynomial)."; printstr "This choice also requires that we distribute the"; printstr "LC-factors in a specific order:" >>; symbolic procedure dist!.lc!.msg2(dvec,im!.factors,r); factor!-trace << printstr "The leading coefficients are now correct to within an"; printstr "integer factor and are as follows:"; for j:=1:r do << prinsf getv(im!.factors,j); prin2!* " with l.c. "; printsf getv(dvec,j) >> >>; symbolic procedure dist!.lc!.msg3(dvec,im!.factors,r); factor!-trace << printstr "Since delta=1, we have no non-trivial content of the"; printstr "image to deal with so we know the true leading coefficients"; printstr "exactly. We fix the signs of the IM-factors to match those"; printstr "of their true leading coefficients:"; for j:=1:r do << prinsf getv(im!.factors,j); prin2!* " with l.c. "; printsf getv(dvec,j) >> >>; symbolic procedure dist!.lc!.msg4 delta; factor!-trace << prin2!* " Here delta is not 1 meaning that we have a content, "; printstr delta; printstr "of the image to distribute among the factors somehow."; printstr "For each IM-factor we can divide its leading"; printstr "coefficient by the image of its determined leading"; printstr "coefficient and see if there is a non-trivial result."; printstr "This will indicate a factor of delta belonging to this"; printstr "IM-factor's leading coefficient." >>; endmodule; module pfactor; % Factorization of polynomials modulo p. % Author: A. C. Norman, 1978. fluid '(!*backtrace !*gcd base!-time current!-modulus gc!-base!-time last!-displayed!-gc!-time last!-displayed!-time m!-image!-variable modular!-info modulus!/2 user!-prime); symbolic procedure pfactor(q,p); % Q is a standard form. Factorize and return the factors mod p. begin scalar base!-time,last!-displayed!-time, gc!-base!-time,last!-displayed!-gc!-time, user!-prime,current!-modulus,modulus!/2,r,x; set!-time(); if not numberp p then typerr(p,"number") else if not primep p then typerr(p,"prime"); user!-prime:=p; set!-modulus p; if domainp q or null reduce!-mod!-p lc q then printc "*** Degenerate case in modular factorization"; if not (length variables!-in!-form q=1) then rederr "Multivariate input to modular factorization"; r:=reduce!-mod!-p q; % LNCOEFF := LC R; x := lnc r; r :=monic!-mod!-p r; print!-time "About to call FACTOR-FORM-MOD-P"; r:=errorset(list('factor!-form!-mod!-p,mkquote r),t,!*backtrace); print!-time "FACTOR-FORM-MOD-P returned"; if not errorp r then return x . car r; printc "****** FACTORIZATION FAILED******"; return list(1,prepf q) % 1 needed by factorize. end; symbolic procedure factor!-form!-mod!-p p; % input: % p is a reduce standard form that is to be factorized % mod prime; % result: % ((p1 . x1) (p2 . x2) .. (pn . xn)) % where p<i> are standard forms and x<i> are integers, % and p= product<i> p<i>**x<i>; sort!-factors factorize!-by!-square!-free!-mod!-p p; symbolic procedure factorize!-by!-square!-free!-mod!-p p; if p=1 then nil else if domainp p then (p . 1) . nil else begin scalar dp,v; v:=(mksp(mvar p,1).* 1) .+ nil; dp:=0; while evaluate!-mod!-p(p,mvar v,0)=0 do << p:=quotfail!-mod!-p(p,v); dp:=dp+1 >>; if dp>0 then return ((v . dp) . factorize!-by!-square!-free!-mod!-p p); dp:=derivative!-mod!-p p; if dp=nil then << %here p is a something to the power current!-modulus; p:=divide!-exponents!-by!-p(p,current!-modulus); p:=factorize!-by!-square!-free!-mod!-p p; return multiply!-multiplicities(p,current!-modulus) >>; dp:=gcd!-mod!-p(p,dp); if dp=1 then return factorize!-pp!-mod!-p p; %now p is not square-free; p:=quotfail!-mod!-p(p,dp); %factorize p and dp separately; p:=factorize!-pp!-mod!-p p; dp:=factorize!-by!-square!-free!-mod!-p dp; % i feel that this scheme is slightly clumsy, but % square-free decomposition mod p is not as straightforward % as square free decomposition over the integers, and pfactor % is probably not going to be slowed down too badly by % this; return mergefactors(p,dp) end; %**********************************************************************; % code to factorize primitive square-free polynomials mod p; symbolic procedure divide!-exponents!-by!-p(p,n); if isdomain p then p else (mksp(mvar p,exactquotient(ldeg p,n)) .* lc p) .+ divide!-exponents!-by!-p(red p,n); symbolic procedure exactquotient(a,b); begin scalar w; w:=divide(a,b); if cdr w=0 then return car w; error(50,list("Inexact division",list(a,b,w))) end; symbolic procedure multiply!-multiplicities(l,n); if null l then nil else (caar l . (n*cdar l)) . multiply!-multiplicities(cdr l,n); symbolic procedure mergefactors(a,b); % a and b are lists of factors (with multiplicities), % merge them so that no factor occurs more than once in % the result; if null a then b else mergefactors(cdr a,addfactor(car a,b)); symbolic procedure addfactor(a,b); %add factor a into list b; if null b then list a else if car a=caar b then (car a . (cdr a + cdar b)) . cdr b else car b . addfactor(a,cdr b); symbolic procedure factorize!-pp!-mod!-p p; %input a primitive square-free polynomial p, % output a list of irreducible factors of p; begin scalar vars; if p=1 then return nil else if isdomain p then return (p . 1) . nil; % now I am certain that p is not degenerate; print!-time "primitive square-free case detected"; vars:=variables!-in!-form p; if length vars=1 then return unifac!-mod!-p p; errorf "SHAMBLED IN PFACTOR - MULTIVARIATE CASE RESURFACED" end; symbolic procedure unifac!-mod!-p p; %input p a primitive square-free univariate polynomial %output a list of the factors of p over z mod p; begin scalar modular!-info,m!-image!-variable; if isdomain p then return nil else if ldeg p=1 then return (p . 1) . nil; modular!-info:=mkvect 1; m!-image!-variable:=mvar p; get!-factor!-count!-mod!-p(1,p,user!-prime,nil); print!-time "Factor counts obtained"; get!-factors!-mod!-p(1,user!-prime); print!-time "Actual factors extracted"; return for each z in getv(modular!-info,1) collect (z . 1) end; endmodule; module vecpoly; % Authors: A. C. Norman and P. M. A. Moore, 1979; fluid '(current!-modulus safe!-flag); %**********************************************************************; % Routines for working with modular univariate polynomials % stored as vectors. Used to avoid unwarranted storage management % in the mod-p factorization process; safe!-flag:=carcheck 0; symbolic procedure copy!-vector(a,da,b); % Copy A into B; << for i:=0:da do putv(b,i,getv(a,i)); da >>; symbolic procedure times!-in!-vector(a,da,b,db,c); % Put the product of A and B into C and return its degree. % C must not overlap with either A or B; begin scalar dc,ic,w; if da#<0 or db#<0 then return minus!-one; dc:=da#+db; for i:=0:dc do putv(c,i,0); for ia:=0:da do << w:=getv(a,ia); for ib:=0:db do << ic:=ia#+ib; putv(c,ic,modular!-plus(getv(c,ic), modular!-times(w,getv(b,ib)))) >> >>; return dc end; symbolic procedure quotfail!-in!-vector(a,da,b,db); % Overwrite A with (A/B) and return degree of result. % The quotient must be exact; if da#<0 then da else if db#<0 then errorf "Attempt to divide by zero" else if da#<db then errorf "Bad degrees in QUOTFAIL-IN-VECTOR" else begin scalar dc; dc:=da#-db; % Degree of result; for i:=dc step -1 until 0 do begin scalar q; q:=modular!-quotient(getv(a,db#+i),getv(b,db)); for j:=0:db#-1 do putv(a,i#+j,modular!-difference(getv(a,i#+j), modular!-times(q,getv(b,j)))); putv(a,db#+i,q) end; for i:=0:db#-1 do if getv(a,i) neq 0 then errorf "Quotient not exact in QUOTFAIL!-IN!-VECTOR"; for i:=0:dc do putv(a,i,getv(a,db#+i)); return dc end; symbolic procedure remainder!-in!-vector(a,da,b,db); % Overwrite the vector A with the remainder when A is % divided by B, and return the degree of the result; begin scalar delta,db!-1,recip!-lc!-b,w; if db=0 then return minus!-one else if db=minus!-one then errorf "ATTEMPT TO DIVIDE BY ZERO"; recip!-lc!-b:=modular!-minus modular!-reciprocal getv(b,db); db!-1:=db#-1; % Leading coeff of B treated specially, hence this; while not((delta:=da#-db) #< 0) do << w:=modular!-times(recip!-lc!-b,getv(a,da)); for i:=0:db!-1 do putv(a,i#+delta,modular!-plus(getv(a,i#+delta), modular!-times(getv(b,i),w))); da:=da#-1; while not(da#<0) and getv(a,da)=0 do da:=da#-1 >>; return da end; symbolic procedure evaluate!-in!-vector(a,da,n); % Evaluate A at N; begin scalar r; r:=getv(a,da); for i:=da#-1 step -1 until 0 do r:=modular!-plus(getv(a,i), modular!-times(r,n)); return r end; symbolic procedure gcd!-in!-vector(a,da,b,db); % Overwrite A with the gcd of A and B. On input A and B are % vectors of coefficients, representing polynomials % of degrees DA and DB. Return DG, the degree of the gcd; begin scalar w; if da=0 or db=0 then << putv(a,0,1); return 0 >> else if da#<0 or db#<0 then errorf "GCD WITH ZERO NOT ALLOWED"; top: % Reduce the degree of A; da:=remainder!-in!-vector(a,da,b,db); if da=0 then << putv(a,0,1); return 0 >> else if da=minus!-one then << w:=modular!-reciprocal getv(b,db); for i:=0:db do putv(a,i,modular!-times(getv(b,i),w)); return db >>; % Now reduce degree of B; db:=remainder!-in!-vector(b,db,a,da); if db=0 then << putv(a,0,1); return 0 >> else if db=minus!-one then << w:=modular!-reciprocal getv(a,da); if not (w=1) then for i:=0:da do putv(a,i,modular!-times(getv(a,i),w)); return da >>; go to top end; carcheck safe!-flag; endmodule; end; |
Added r33/gentran.red version [34306458a2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 | module util; %% GENTRAN Utility Functions %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Points: ALL FUNCTIONS symbolic$ % User-Accessible Primitive Function % operator genstmtnum$ % User-Accessible Global Variables % global '(genstmtincr!* genstmtnum!* tablen!*)$ share 'genstmtincr!*, 'genstmtnum!*, 'tablen!*$ genstmtincr!* := 1$ genstmtnum!* := 25000$ tablen!* := 4$ % GENTRAN Global Variables % global '(!*lisparithexpops!* !*lispdefops!* !*lisplogexpops!* !*lispstmtgpops!* !*lispstmtops!* !*symboltable!*)$ !*lisparithexpops!* := '(expt minus plus quotient times)$ %LISP arithmetic expression operators !*lispdefops!* := '(defun)$ %LISP function definition operator !*lisplogexpops!* := '(and equal geq greaterp leq lessp neq not or)$ %LISP logical & relational exp operators !*lispstmtgpops!* := '(prog progn)$ %LISP statement group operators !*lispstmtops!* := '(break cond end for go read repeat return setq stop while write)$ %LISP statement operators !*symboltable!* := '(!*main!*)$ %symbol table global '(!*for!*)$ %% %% %% Statement Number Generation Function %% %% %% procedure genstmtnum; genstmtnum!* := genstmtnum!* + genstmtincr!*$ %% %% %% Symbol Table Insertion, Retrieval & Deletion Functions %% %% %% procedure symtabput(name, type, value); % % % CALL INSERTS % % SymTabPut(subprogname, NIL, NIL ) subprogram name % % SymTabPut(subprogname, '!*Type!*, subprogtype ) subprogram type % % SymTabPut(subprogname, '!*Params!*, paramlist ) parameter list % % SymTabPut(subprogname, vname, '(type d1 d2 ...)) type & dimensions % % for variable, % % variable range, % % if subprogname=NIL parameter, or % % then subprogname <-- Car symboltable function name % % % << name := name or car !*symboltable!*; !*symboltable!* := name . delete(name, !*symboltable!*); if type memq '(!*type!* !*params!*) then put(name, type, value) else if type then begin scalar v, vtype, vdims, dec, decs; v := type; vtype := car value; vdims := cdr value; decs := get(name, '!*decs!*); dec := assoc(v, decs); decs := delete(dec, decs); vtype := vtype or (if length dec > 1 then cadr dec); vdims := vdims or (if length dec > 2 then cddr dec); dec := v . vtype . vdims; put(name, '!*decs!*, append(decs, list dec)) end >>$ procedure symtabget(name, type); % % % CALL RETRIEVES % % SymTabGet(NIL, NIL ) all subprogram names % % SymTabGet(subprogname, '!*Type!* ) subprogram type % % SymTabGet(subprogname, '!*Params!*) parameter list % % SymTabGet(subprogname, vname ) type & dimensions for variable, % % variable range, parameter, or % % function name % % SymTabGet(subprogname, '!*Decs!* ) all types & dimensions % % % % if subprogname=NIL & 2nd arg is non-NIL % % then subprogname <-- Car symboltable % % % << if type then name := name or car !*symboltable!*; if null name then !*symboltable!* else if type memq '(!*type!* !*params!* !*decs!*) then get(name, type) else assoc(type, get(name, '!*decs!*)) >>$ procedure symtabrem(name, type); % % % CALL DELETES % % SymTabRem(subprogname, NIL ) subprogram name % % SymTabRem(subprogname, '!*Type!* ) subprogram type % % SymTabRem(subprogname, '!*Params!*) parameter list % % SymTabRem(subprogname, vname ) type & dimensions for variable, % % variable range, parameter, or % % function name % % SymTabRem(subprogname, '!*Decs!* ) all types & dimensions % % % % if subprogname=NIL % % then subprogname <-- Car symboltable % % % << name := name or car !*symboltable!*; if null type then !*symboltable!* := delete(name, !*symboltable!*) or '(!*main!*) else if type memq '(!*type!* !*params!* !*decs!*) then remprop(name, type) else begin scalar v, dec, decs; v := type; decs := get(name, '!*decs!*); dec := assoc(v, decs); decs := delete(dec, decs); put(name, '!*decs!*, decs) end >>$ procedure getvartype var; begin scalar type; if listp var then var := car var; type := symtabget(nil, var); if type and length type >= 2 then type := cadr type else type := nil; return type end$ procedure arrayeltp exp; length symtabget(nil, car exp) > 2$ %% %% %% Functions for Making LISP Forms %% %% %% procedure mkassign(var, exp); list('setq, var, exp)$ procedure mkcond pairs; 'cond . pairs$ procedure mkdef(name, params, body); append(list('defun, name, params), body)$ procedure mkreturn exp; list('return, exp)$ procedure mkstmtgp(vars, stmts); if numberp vars then 'progn . stmts else 'prog . vars . stmts$ %% LISP Form Predicates %% procedure lispassignp stmt; eqcar(stmt,'setq); procedure lispbreakp form; eqcar(form,'break); procedure lispcallp form; listp form$ procedure lispcondp stmt; eqcar(stmt,'cond); procedure lispdefp form; not atom form and car form memq !*lispdefops!*$ procedure lispexpp form; atom form or car form memq !*lisparithexpops!* or car form memq !*lisplogexpops!* or not (car form memq !*lispstmtops!*) and not (car form memq !*lispstmtgpops!*) and not (car form memq !*lispdefops!*)$ procedure lispendp form; eqcar(form,'end); procedure lispforp form; eqcar(form,!*for!*); procedure lispgop form; eqcar(form,'go); procedure lisplabelp form; atom form$ procedure lispprintp form; eqcar(form,'write); procedure lispreadp form; eqcar(form,'read); procedure lisprepeatp form; eqcar(form,'repeat); procedure lispreturnp stmt; eqcar(stmt,'return); procedure lispstmtp form; atom form or car form memq !*lispstmtops!* or ( atom car form and not (car form memq !*lisparithexpops!* or car form memq !*lisplogexpops!* or car form memq !*lispstmtgpops!* or car form memq !*lispdefops!*) )$ procedure lispstmtgpp form; listp form and car form memq !*lispstmtgpops!*$ procedure lispstopp form; eqcar(form,'stop); procedure lispwhilep form; eqcar(form,'while); %% %% %% Type Predicates & Type List Forming Functions %% %% %% procedure formtypelists varlists; % ( (var TYPE d1 d2...) ( (TYPE (var d1 d2...) ...) % % : ==> : % % (var TYPE d1 d2...) ) (TYPE (var d1 d2...) ...) ) % begin scalar type, typelists, tl; for each vl in varlists do << type := cadr vl; if onep length(vl := delete(type, vl)) then vl := car vl; if (tl := assoc(type, typelists)) then typelists := delete(tl, typelists) else tl := list type; typelists := append(typelists, list append(tl, list vl)) >>; return typelists end$ procedure functionformp(stmt, name); % Does stmt contain an assignment which assigns a value to name? % % Does it contain a RETURN exp; stmt? % % (i.e., (SETQ name exp) -or- (RETURN exp) % if null stmt or atom stmt then nil else if car stmt eq 'setq and cadr stmt eq name then t else if car stmt eq 'return and cdr stmt then t else eval('or . for each st in stmt collect functionformp(st, name))$ procedure implicitp type; begin scalar xtype, ximp, r; xtype := explode2 type; ximp := explode2 'implicit; r := t; repeat r := r and (car xtype eq car ximp) until null(xtype := cdr xtype) or null(ximp := cdr ximp); return r end$ %% %% %% Misc. Functions %% %% %% procedure insertcommas lst; begin scalar result; if null lst then return nil; result := list car lst; while lst := cdr lst do result := car lst . '!, . result; return reverse result end$ procedure insertparens exp; '!( . append(exp, list '!))$ procedure optype op; get(op, '!*optype!*)$ put('minus, '!*optype!*, 'unary )$ put('not, '!*optype!*, 'unary )$ put('quotient, '!*optype!*, 'binary)$ put('expt, '!*optype!*, 'binary)$ put('equal, '!*optype!*, 'binary)$ put('neq, '!*optype!*, 'binary)$ put('greaterp, '!*optype!*, 'binary)$ put('geq, '!*optype!*, 'binary)$ put('lessp, '!*optype!*, 'binary)$ put('leq, '!*optype!*, 'binary)$ put('plus, '!*optype!*, 'nary )$ put('times, '!*optype!*, 'nary )$ put('and, '!*optype!*, 'nary )$ put('or, '!*optype!*, 'nary )$ procedure seqtogp lst; if null lst or atom lst or lispstmtp lst or lispstmtgpp lst then lst else if onep length lst and listp car lst then seqtogp car lst else mkstmtgp(nil, for each st in lst collect seqtogp st)$ procedure stringtoatom a; intern compress foreach c in append('!" . explode2 a, list '!") conc list('!!, c)$ procedure stripquotes a; if atom a then intern compress for each c in explode2 a conc list('!!, c) else if car a eq 'quote then stripquotes cadr a else a$ endmodule; module intrfc; %% GENTRAN Parsing Routines & Control Functions %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Points: % DeclareStat, GENDECS, GenInStat (GentranIn), GenOutStat % (GentranOutPush), GenPopStat (GentranPop), GenPushStat, GenShutStat % (GentranShut), GenStat (Gentran), (GENTRANPAIRS), % LiteralStat, SYM!-GENTRAN, SYM!-GENTRANIN, SYM!-GENTRANOUT, % SYM!-GENTRANSHUT, % SYM!-GENTRANPUSH, SYM!-GENTRANPOP symbolic$ % GENTRAN Commands % put('gentran, 'stat, 'genstat )$ put('gentranin, 'stat, 'geninstat )$ put('gentranout, 'stat, 'genoutstat )$ put('gentranshut, 'stat, 'genshutstat)$ put('gentranpush, 'stat, 'genpushstat)$ put('gentranpop, 'stat, 'genpopstat )$ % Form Analysis Function % put('gentran, 'formfn, 'formgentran)$ put('gentranin, 'formfn, 'formgentran)$ put('gentranoutpush, 'formfn, 'formgentran)$ put('gentranshut, 'formfn, 'formgentran)$ put('gentranpop, 'formfn, 'formgentran)$ % GENTRAN Functions % put('declare, 'stat, 'declarestat)$ put('literal, 'stat, 'literalstat)$ % GENTRAN Operators % newtok '((!: !: !=) lsetq )$ infix ::= $ newtok '((!: != !:) rsetq )$ infix :=: $ newtok '((!: !: != !:) lrsetq)$ infix ::=:$ % User-Accessible Primitive Function % operator gendecs$ % GENTRAN Mode Switches % global '(!*gendecs)$ !*gendecs := t$ put('gendecs, 'simpfg, '((nil) (t (gendecs nil))))$ switch gendecs$ % GENTRAN Flags % global '( %% !*GENTRANOPT !*gentranseg !*period)$ %%!*GENTRANOPT := NIL$ !*gentranseg := t$ switch gentranseg$ % User-Accessible Global Variable % global '(gentranlang!*)$ share gentranlang!*$ gentranlang!* := 'fortran$ % GENTRAN Global Variable % global '(!*term!* !*stdin!* !*stdout!* !*instk!* !*currin!* !*outstk!* !*currout!* !*outchanl!*)$ !*term!* := (t . nil)$ %terminal filepair !*stdin!* := !*term!*$ %standard input filepair !*stdout!* := !*term!*$ %standard output filepair !*instk!* := list !*stdin!*$ %template file stack !*currin!* := car !*instk!*$ %current input filepair !*outstk!* := list !*stdout!*$ %output file stack !*currout!* := car !*outstk!*$ %current output filepair !*outchanl!* := list cdr !*currout!*$ %current output channel list global '(!*do!* !*for!*)$ off quotenewnam$ !*do!* := 'do$ !*for!* := 'for$ on quotenewnam$ % REDUCE Variables % global '(cursym!* !*vars!*)$ fluid '(!*mode)$ %% %% %% PARSING ROUTINES %% %% %% %% GENTRAN Command Parsers %% procedure genstat; % % % GENTRAN % % stmt % % [OUT f1,f2,...,fn]; % % % begin scalar st; flag('(out), 'delim); st := xread t; remflag('(out), 'delim); if cursym!* eq 'out then return list('gentran, st, readfargs()) else if endofstmtp() then return list('gentran, st, nil) else gentranerr('e, nil, "INVALID SYNTAX", nil) end$ procedure geninstat; % % % GENTRANIN % % f1,f2,...,fm % % [OUT f1,f2,...,fn]; % % % begin scalar f1, f2; flag('(out), 'delim); f1 := xread nil; if atom f1 then f1 := list f1 else f1 := cdr f1; remflag('(out), 'delim); if cursym!* eq 'out then f2 := readfargs(); return list('gentranin, f1, f2) end$ procedure genoutstat; % % % GENTRANOUT f1,f2,...,fn; % % % list('gentranoutpush, readfargs())$ procedure genshutstat; % % % GENTRANSHUT f1,f2,...,fn; % % % list('gentranshut, readfargs())$ procedure genpushstat; % % % GENTRANPUSH f1,f2,...,fn; % % % list('gentranoutpush, readfargs())$ procedure genpopstat; % % % GENTRANPOP f1,f2,...,fn; % % % list('gentranpop, readfargs())$ %% GENTRAN Function Parsers %% procedure declarestat; % % % DECLARE v1,v2,...,vn : type; % % % % DECLARE % % << % % v1,v2,...,vn1 : type1; % % v1,v2,...,vn2 : type2; % % . % % . % % v1,v2,...,vnn : typen % % >>; % % % begin scalar res, varlst, type; scan(); if cursym!* eq '!*lsqb!* then << scan(); while cursym!* neq '!*rsqb!* do << varlst := list xread1 'for; while cursym!* neq '!*colon!* do varlst := append(varlst, list xread 'for); type := declarestat1(); res := append(res, list(type . varlst)); if cursym!* eq '!*semicol!* then scan() >>; scan() >> else << varlst := list xread1 'for; while cursym!* neq '!*colon!* do varlst := append(varlst, list xread 'for); type := declarestat1(); res := list (type . varlst); >>; if not endofstmtp() then gentranerr('e, nil, "INVALID SYNTAX", nil); return ('declare . res) end$ procedure declarestat1; begin scalar res; scan(); if endofstmtp() then return nil; if cursym!* eq 'implicit then << scan(); res := intern compress append(explode 'implicit! , explode cursym!*) >> else res := cursym!*; scan(); if cursym!* eq 'times then << scan(); if numberp cursym!* then << res := intern compress append(append(explode res, explode '!*), explode cursym!*); scan() >> else gentranerr('e, nil, "INVALID SYNTAX", nil) >>; return res end$ procedure literalstat; % % % LITERAL arg1,arg2,...,argn; % % % begin scalar res; repeat res := append(res, list xread t) until endofstmtp(); if atom res then return list('literal, res) else if car res eq '!*comma!* then return rplaca(res, 'literal) else return('literal . res) end$ %% %% %% Symbolic Mode Functions %% %% %% procedure sym!-gentran form; eval formgentran(list('gentran, form, nil), !*vars!*, !*mode)$ procedure sym!-gentranin flist; eval formgentran(list('gentranin, if atom flist then list flist else flist, nil), !*vars!*, !*mode)$ procedure sym!-gentranout flist; eval formgentran(list('gentranoutpush, if atom flist then list flist else flist), !*vars!*, !*mode)$ procedure sym!-gentranshut flist; eval formgentran(list('gentranshut, if atom flist then list flist else flist), !*vars!*, !*mode)$ procedure sym!-gentranpush flist; eval formgentran(list('gentranoutpush, if atom flist then list flist else flist), !*vars!*, !*mode)$ procedure sym!-gentranpop flist; eval formgentran(list('gentranpop, if atom flist then list flist else flist), !*vars!*, !*mode)$ %% %% %% Form Analysis Functions %% %% %% procedure formgentran(u, vars, mode); (car u) . foreach arg in cdr u collect formgentran1(arg, vars, mode)$ procedure formgentran1(u, vars, mode); if pairp u and not listp u then gentranerr('e, u, "SCALAR DEFINITIONS CANNOT BE TRANSLATED", nil) else if atom u then mkquote u else if car u eq 'eval then list('aeval, form1(cadr u, vars, mode)) else if car u memq '(lsetq rsetq lrsetq) then % (LSETQ (var s1 s2 ... sn) exp) % % -> (SETQ (var (EVAL s1) (EVAL s2) ... (EVAL sn)) exp) % % (RSETQ var exp) % % -> (SETQ var (EVAL exp)) % % (LRSETQ (var s1 s2 ... sn) exp) % % -> (SETQ (var (EVAL s1) (EVAL s2) ... (EVAL sn)) (EVAL exp)) % begin scalar op, lhs, rhs; op := car u; lhs := cadr u; rhs := caddr u; if op memq '(lsetq lrsetq) and listp lhs then lhs := car lhs . foreach s in cdr lhs collect list('eval, s); if op memq '(rsetq lrsetq) then rhs := list('eval, rhs); return formgentran1(list('setq, lhs, rhs), vars, mode) end else 'list . foreach elt in u collect formgentran1(elt, vars, mode)$ %% %% %% Control Functions %% %% %% %% Command Control Functions %% procedure gentran(forms, flist); begin if flist then eval list('gentranoutpush, list('quote, flist)); forms := preproc list forms; gentranparse forms; forms := lispcode forms; %%IF !*GENTRANOPT THEN forms := Opt forms; if !*gentranseg then forms := seg forms; if gentranlang!* eq 'ratfor then formatrat ratcode forms else if gentranlang!* eq 'c then formatc ccode forms else formatfort fortcode forms; if flist then << flist := car !*currout!* or ('list . cdr !*currout!*); eval '(gentranpop '(nil)); return flist >> else return car !*currout!* or ('list . cdr !*currout!*) end$ procedure gentranin(inlist, outlist); begin scalar ich; foreach f in inlist do if listp f then gentranerr('e, f, "Wrong Type of Arg", nil) else if not !*filep!* f and f neq car !*stdin!* then gentranerr('e, f, "Nonexistent Input File", nil); if outlist then eval list('gentranoutpush, mkquote outlist); ich := rds nil; foreach f in inlist do << if f = car !*stdin!* then pushinputstack !*stdin!* else if retrieveinputfilepair f then gentranerr('e, f, "Template File Already Open for Input", nil) else pushinputstack makeinputfilepair f; rds cdr !*currin!*; if gentranlang!* eq 'ratfor then procrattem() else if gentranlang!* eq 'c then procctem() else procforttem(); rds ich; popinputstack() >>; if outlist then << outlist := car !*currout!* or ('list . cdr !*currout!*); eval '(gentranpop '(nil)); return outlist >> else return car !*currout!* or ('list . cdr !*currout!*) end$ procedure gentranoutpush flist; << if onep length (flist := fargstonames(flist, t)) then flist := car flist; pushoutputstack (retrieveoutputfilepair flist or makeoutputfilepair flist); car !*currout!* or ('list . cdr !*currout!*) >>$ procedure gentranshut flist; % close, delete, [output to T] % begin scalar trm; flist := fargstonames(flist, nil); trm := if onep length flist then (car flist = car !*currout!*) else if car !*currout!* then (if car !*currout!* member flist then t) else eval('and . foreach f in cdr !*currout!* collect (if f member flist then t)); deletefromoutputstack flist; if trm and !*currout!* neq !*stdout!* then pushoutputstack !*stdout!*; return car !*currout!* or ('list . cdr !*currout!*) end$ procedure gentranpop flist; << if 'all!* member flist then while !*outstk!* neq list !*stdout!* do eval '(gentranpop '(nil)) else << flist := fargstonames(flist,nil); if onep length flist then flist := car flist; popoutputstack flist >>; car !*currout!* or ('list . cdr !*currout!*) >>$ %% Mode Switch Control Function %% procedure gendecs name; % % % ON/OFF GENDECS; % % % % GENDECS subprogname; % % % << if name equal 0 then name := nil; if gentranlang!* eq 'ratfor then formatrat ratdecs symtabget(name, '!*decs!*) else if gentranlang!* eq 'c then formatc cdecs symtabget(name, '!*decs!*) else formatfort fortdecs symtabget(name, '!*decs!*); symtabrem(name, nil); symtabrem(name, '!*decs!*) >>$ %% Misc. Control Functions %% procedure gentranpairs prs; % % % GENTRANPAIRS dottedpairlist; % % % if gentranlang!* eq 'ratfor then for each pr in prs do formatrat mkfratassign(lispcodeexp(car pr, !*period), lispcodeexp(cdr pr, !*period)) else if gentranlang!* eq 'c then for each pr in prs do formatc mkfcassign(lispcodeexp(car pr, !*period), lispcodeexp(cdr pr, !*period)) else for each pr in prs do formatfort mkffortassign(lispcodeexp(car pr, !*period), lispcodeexp(cdr pr, !*period))$ %% %% %% Input & Output File Stack Manipulation Functions %% %% %% %% Input Stack Manipulation Functions %% procedure makeinputfilepair fname; (fname . open(mkfil fname, 'input))$ procedure retrieveinputfilepair fname; retrievefilepair(fname, !*instk!*)$ procedure pushinputstack pr; << !*instk!* := pr . !*instk!*; !*currin!* := car !*instk!*; !*instk!* >>$ procedure popinputstack; begin scalar x; x := !*currin!*; if cdr !*currin!* then close cdr !*currin!*; !*instk!* := cdr !*instk!* or list !*stdin!*; !*currin!* := car !*instk!*; return x end$ %% Output File Stack Manipulation Functions %% procedure makeoutputfilepair f; if atom f then (f . open(mkfil f, 'output)) else aconc((nil . f) . foreach fn in f conc if not retrieveoutputfilepair fn then list makeoutputfilepair fn, (nil . nil))$ procedure retrieveoutputfilepair f; if atom f then retrievefilepair(f, !*outstk!*) else retrievepfilepair(f, !*outstk!*)$ procedure pushoutputstack pr; << !*outstk!* := if atom cdr pr then (pr . !*outstk!*) else append(pr, !*outstk!*); !*currout!* := car !*outstk!*; !*outchanl!* := if car !*currout!* then list cdr !*currout!* else foreach f in cdr !*currout!* collect cdr retrieveoutputfilepair f; !*outstk!* >>$ procedure popoutputstack f; % [close], remove top-most exact occurrence, reset vars % begin scalar pr, s; if atom f then << pr := retrieveoutputfilepair f; while !*outstk!* and car !*outstk!* neq pr do if caar !*outstk!* then <<s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!*>> else << while car !*outstk!* neq (nil . nil) do << s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >>; s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >>; if !*outstk!* then s := append(s, cdr !*outstk!*); !*outstk!* := s; if not retrieveoutputfilepair f then close cdr pr >> else << pr := foreach fn in f collect retrieveoutputfilepair fn; while !*outstk!* and not filelistequivp(cdar !*outstk!*, f) do if caar !*outstk!* then << s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >> else << while car !*outstk!* neq (nil . nil) do << s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >>; s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >>; if !*outstk!* then << while car !*outstk!* neq (nil . nil) do !*outstk!* := cdr !*outstk!*; s := append(s, cdr !*outstk!*) >>; !*outstk!* := s; foreach fn in f do pr := delete(retrieveoutputfilepair fn, pr); foreach p in pr do close cdr p >>; !*outstk!* := !*outstk!* or list !*stdout!*; !*currout!* := car !*outstk!*; !*outchanl!* := if car !*currout!* then list cdr !*currout!* else foreach fn in cdr !*currout!* collect cdr retrieveoutputfilepair fn; return f end$ procedure deletefromoutputstack f; begin scalar s, pr; if atom f then << pr := retrieveoutputfilepair f; while retrieveoutputfilepair f do !*outstk!* := delete(pr, !*outstk!*); close cdr pr; foreach pr in !*outstk!* do if listp cdr pr and f member cdr pr then rplacd(pr, delete(f, cdr pr)) >> else << foreach fn in f do deletefromoutputstack fn; foreach fn in f do foreach pr in !*outstk!* do if listp cdr pr and fn member cdr pr then rplacd(pr, delete(fn, cdr pr)) >>; while !*outstk!* do if caar !*outstk!* and caar !*outstk!* neq 't then << s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >> else if cdar !*outstk!* and cdar !*outstk!* neq '(t) then << while car !*outstk!* neq (nil . nil) do << s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >>; s := aconc(s, car !*outstk!*); !*outstk!* := cdr !*outstk!* >> else !*outstk!* := cddr !*outstk!*; !*outstk!* := s or list !*stdout!*; !*currout!* := car !*outstk!*; !*outchanl!* := if car !*currout!* then list cdr !*currout!* else foreach fn in cdr !*currout!* collect cdr retrieveoutputfilepair fn; return f end$ procedure retrievefilepair(fname, stk); if null stk then nil else if caar stk and mkfil fname = mkfil caar stk then car stk else retrievefilepair(fname, cdr stk)$ procedure retrievepfilepair(f, stk); if null stk then nil else if null caar stk and filelistequivp(f, cdar stk) then list(car stk, (nil . nil)) else retrievepfilepair(f, cdr stk)$ procedure filelistequivp(f1, f2); if listp f1 and listp f2 then << f1 := foreach f in f1 collect mkfil f; f2 := foreach f in f2 collect mkfil f; while (car f1 member f2) do << f2 := delete(car f1, f2); f1 := cdr f1 >>; null f1 and null f2 >>$ %% procedure !*filep!* f; not errorp errorset(list('close, list('open,list('mkfil,mkquote f),''input)), nil,nil)$ %% %% %% Scanning & Arg-Conversion Functions %% %% %% procedure endofstmtp; if cursym!* member '(!*semicol!* !*rsqb!* end) then t$ procedure fargstonames(fargs, openp); begin scalar names; fargs := for each a in fargs conc if a memq '(nil 0) then if car !*currout!* then list car !*currout!* else cdr !*currout!* else if a eq 't then list car !*stdout!* else if a eq 'all!* then for each fp in !*outstk!* conc (if car fp and not(fp equal !*stdout!*) then list car fp) else if atom a then if openp then << if !*filep!* a and null assoc(a, !*outstk!*) then gentranerr('w, a, "OUTPUT FILE ALREADY EXISTS", "CONTINUE?"); list a >> else if retrieveoutputfilepair a then list a else gentranerr('w, a, "File not Open for Output", nil) else gentranerr('e, a, "WRONG TYPE OF ARG", nil); repeat if not (car fargs member names) then names := append(names, list car fargs) until null (fargs := cdr fargs); return names end$ procedure readfargs; begin scalar f; while not endofstmtp() do f := append(f, list xread t); return f or list nil end$ endmodule; module templt; %% GENTRAN Template Processing Routines %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Points: ProcCTem, ProcFortTem, ProcRatTem symbolic$ % User-Accessible Global Variables % global '(gentranlang!* !*gendecs !$!#)$ share 'gentranlang!*, '!$!#$ gentranlang!* := 'fortran$ !$!# := 0$ switch gendecs$ global '(!*space!* !*stdout!* !$eof!$ !$eol!$)$ % GENTRAN Global Variables % !*space!* := '! $ fluid '(!*mode)$ %% %% %% Text Processing Routines %% %% %% %% FORTRAN %% procedure procforttem; begin scalar c, linelen; linelen := linelength 150; c := procfortcomm(); while c neq !$eof!$ do if c memq '(!F !f !S !s) then << pprin2 c; c := procsubprogheading c >> else if c eq !$eol!$ then << pterpri(); c := procfortcomm() >> else if c eq '!; then c := procactive() else << pprin2 c; c := readch() >>; linelength linelen end$ procedure procfortcomm; % <col 1>C ... <cr> % % <col 1>c ... <cr> % begin scalar c; while (c := readch()) memq '(!C !c) do << pprin2 c; repeat if (c := readch()) neq !$eol!$ then pprin2 c until c eq !$eol!$; pterpri() >>; return c end$ %% RATFOR %% procedure procrattem; begin scalar c, linelen; linelen := linelength 150; c := readch(); while c neq !$eof!$ do if c memq '(!F !f !S !s) then << pprin2 c; c := procsubprogheading c >> else if c eq '!# then c := procratcomm() else if c eq '!; then c := procactive() else if c eq !$eol!$ then << pterpri(); c := readch() >> else << pprin2 c; c := readch() >>; linelength linelen end$ procedure procratcomm; % # ... <cr> % begin scalar c; pprin2 '!#; while (c := readch()) neq !$eol!$ do pprin2 c; pterpri(); return readch() end$ %% procedure procsubprogheading c; begin scalar lst, name, i, propname; lst := if c memq '(!F !f) then '((!U !u) (!N !n) (!C !c) (!T !t) (!I !i) (!O !o) (!N !n)) else '((!U !u) (!B !b) (!R !r) (!O !o) (!U !u) (!T !t) (!I !i) (!N !n) (!E !e)); while lst and (c := readch()) memq car lst do << pprin2 c; lst := cdr lst >>; if lst then return c; while seprp(c := readch()) do if c eq !$eol!$ then pterpri() else pprin2 c; while not(seprp c or c eq '!() do << name := aconc(name, c); pprin2 c; c := readch() >>; name := intern compress name; if not !*gendecs then symtabput(name, nil, nil); propname := if gentranlang!* eq 'fortran then '!*fortranname!* else '!*ratforname!*; put('!$0, propname, name); while seprp c do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >>; if c neq '!( then return c; i := 1; pprin2 c; c := readch(); while c neq '!) do << while seprp c or c eq '!, do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >>; name := list c; pprin2 c; while not (seprp (c := readch()) or c memq list('!,, '!))) do << name := aconc(name, c); pprin2 c >>; put(intern compress append(explode2 '!$, explode2 i), propname, intern compress name); i := add1 i; while seprp c do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >> >>; !$!# := sub1 i; while get(name := intern compress append(explode2 '!$, explode2 i), propname) do remprop(name, propname); return c end$ %% C %% procedure procctem; begin scalar c, linelen; linelen := linelength 150; c := readch(); if c eq '!# then c := procc!#line c; while c neq !$eof!$ do if c eq !$eol!$ then c := procc!#line c else if c eq '!/ then c := procccomm() else if c eq '!; then c := procactive() else c := proccheader(c); linelength linelen end$ procedure procc!#line c; % # ... <cr> % begin if c eq !$eol!$ then << pterpri(); c := readch() >>; if c eq '!# then repeat << pprin2 c; c := readch() >> until c eq !$eol!$; return c end$ procedure procccomm; % /* ... */ % begin scalar c; pprin2 '!/; c := readch(); if c eq '!* then << pprin2 c; c := readch(); repeat << while c neq '!* do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >>; pprin2 c; c := readch() >> until c eq '!/; pprin2 c; c := readch() >>; return c end$ procedure proccheader c; begin scalar name, i; while seprp c and c neq !$eol!$ do << pprin2 c; c := readch() >>; while not(seprp c or c memq list('!/, '!;, '!()) do << name := aconc(name, c); pprin2 c; c := readch() >>; if c memq list(!$eol!$, '!/, '!;) then return c; while seprp c and c neq !$eol!$ do << pprin2 c; c := readch() >>; if c neq '!( then return c; name := intern compress name; if not !*gendecs then symtabput(name, nil, nil); put('!$0, '!*cname!*, name); pprin2 c; i := 1; c := readch(); while c neq '!) do << while seprp c or c eq '!, do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >>; name := list c; pprin2 c; while not(seprp (c := readch()) or c memq list('!,, '!))) do << name := aconc(name, c); pprin2 c >>; put(intern compress append(explode2 '!$, explode2 i), '!*cname!*, intern compress name); i := add1 i; while seprp c do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >> >>; !$!# := sub1 i; while get(name := intern compress append(explode2 '!$, explode2 i), '!*cname!*) do remprop(name, '!*cname!*); return proccfunction c end$ procedure proccfunction c; begin scalar !{!}count; while c neq '!{ do if c eq '!/ then c := procccomm() else if c eq '!; then c := procactive() else if c eq !$eol!$ then << pterpri(); c := readch() >> else << pprin2 c; c := readch() >>; pprin2 c; !{!}count := 1; c := readch(); while !{!}count > 0 do if c eq '!{ then << !{!}count := add1 !{!}count; pprin2 c; c := readch() >> else if c eq '!} then << !{!}count := sub1 !{!}count; pprin2 c; c := readch() >> else if c eq '!/ then c := procccomm() else if c eq '!; then c := procactive() else if c eq !$eol!$ then << pterpri(); c := readch() >> else << pprin2 c; c := readch() >>; return c end$ %% %% %% Template File Active Part Handler %% %% %% procedure procactive; % active parts: ;BEGIN; ... ;END; % % eof markers: ;END; % begin scalar c, buf, mode, och; c := readch(); if c eq 'e then if (c := readch()) eq 'n then if (c := readch()) eq 'd then if (c := readch()) eq '!; then return !$eof!$ else buf := '!;end else buf := '!;en else buf := '!;e else if c eq 'b then if (c := readch()) eq 'e then if (c := readch()) eq 'g then if (c := readch()) eq 'i then if (c := readch()) eq 'n then if (c := readch()) eq '!; then << mode := !*mode; !*mode := 'algebraic; och := wrs cdr !*stdout!*; begin1(); wrs och; !*mode := mode; linelength 150; return if (c := readch()) eq !$eol!$ then readch() else c >> else buf := '!;begin else buf := '!;begi else buf := '!;beg else buf := '!;be else buf := '!;b else buf := '!;; pprin2 buf; return c end$ endmodule; module pre; %% GENTRAN Preprocessing Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: Preproc symbolic$ procedure preproc exp; begin scalar r; r := preproc1 exp; if r then return car r else return r end$ procedure preproc1 exp; if atom exp then list exp else if car exp eq '!*sq then % (!*SQ dpexp) --> (PREPSQ dpexp) % preproc1 prepsq cadr exp else if car exp eq 'procedure then << % Store subprogram name & parameters in symbol table % symtabput(cadr exp, '!*params!*, car cddddr exp); list for each e in exp conc preproc1 e >> else if car exp eq 'declare then << % Store type declarations in symbol table % exp := car preproc1 cdr exp; exp := preprocdec exp; for each dec in exp do for each var in cdr dec do if car dec memq '(subroutine function) then symtabput(var, '!*type!*, car dec) else symtabput(nil, if atom var then var else car var, if atom var then list car dec else (car dec . cdr var)); nil >> else list for each e in exp conc preproc1 e$ procedure preprocdec arg; % (TIMES type int) --> type!*int % % (IMPLICIT type) --> IMPLICIT! type % % (DIFFERENCE v1 v2) --> v1!-v2 % if atom arg then arg else if car arg eq 'times then intern compress append( append( explode cadr arg, explode '!* ), explode caddr arg ) else if car arg eq 'implicit then intern compress append( explode 'implicit! , explode preprocdec cadr arg ) else if car arg eq 'difference then intern compress append( append( explode cadr arg, explode '!- ), explode caddr arg ) else for each a in arg collect preprocdec a$ endmodule; module gparser; %% GENTRAN Parser Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: GentranParse symbolic$ % GENTRAN Global Variable % global '(!*reservedops!*)$ !*reservedops!* := '(and block cond difference equal expt for geq go greaterp leq lessp mat minus neq not or plus procedure progn quotient read recip repeat return setq times while write)$ %reserved operators procedure gentranparse forms; for each f in forms do if not(gpstmtp f or gpexpp f or gpdefnp f) then gentranerr('e, f, "CANNOT BE TRANSLATED", nil)$ procedure gpexpp exp; % exp ::= id | number | (PLUS exp exp') | (MINUS exp) | % % (DIFFERENCE exp exp) | (TIMES exp exp exp') | % % (RECIP exp) |(QUOTIENT exp exp) | (EXPT exp exp) | (id arg') % if atom exp then idp exp or numberp exp else if car exp eq 'plus then length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp else if car exp memq '(minus recip) then length exp=2 and gpexpp cadr exp else if car exp memq '(difference quotient expt) then length exp=3 and gpexpp cadr exp and gpexpp caddr exp else if car exp eq 'times then length exp >= 3 and gpexpp cadr exp and gpexpp caddr exp and gpexp1p cdddr exp else if unresidp car exp then gparg1p cdr exp$ procedure gpexp1p exp; % exp' ::= exp exp' | eps % null exp or (gpexpp car exp and gpexp1p cdr exp)$ procedure gplogexpp exp; % logexp ::= id | (EQUAL exp exp) | (NEQ exp exp) | % % (GREATERP exp exp) |(GEQ exp exp) | (LESSP exp exp) | % % (LEQ exp exp) | (NOT logexp) | (AND logexp logexp logexp')% % | (OR logexp logexp logexp') | (id arg') % if atom exp then idp exp else if car exp memq '(equal neq greaterp geq lessp leq) then length exp=3 and gpexpp cadr exp and gpexpp caddr exp else if car exp eq 'not then length exp=2 and gplogexpp cadr exp else if car exp memq '(and or) then length exp >= 3 and gplogexpp cadr exp and gplogexpp caddr exp and gplogexp1p cdddr exp else if unresidp car exp then gparg1p cdr exp$ procedure gplogexp1p exp; % logexp' ::= logexp logexp' | eps % null exp or (gplogexpp car exp and gplogexp1p cdr exp)$ procedure gpargp exp; % arg ::= string | exp | logexp % stringp exp or gpexpp exp or gplogexpp exp$ procedure gparg1p exp; % arg' ::= arg arg' | eps % null exp or (gpargp car exp and gparg1p cdr exp)$ procedure gpvarp exp; % var ::= id | (id exp exp') % if atom exp then idp exp else if unresidp car exp then length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp$ procedure gplistp exp; % list ::= (exp exp') % if listp exp then length exp >= 1 and gpexpp car exp and gpexp1p cdr exp$ procedure gplist1p exp; % list' ::= list list' | eps % null exp or (gplistp car exp and gplist1p cdr exp)$ procedure gpid1p exp; % id' ::= id id' | eps % null exp or (idp car exp and gpid1p cdr exp)$ procedure gpstmtp exp; % stmt ::= id | (SETQ setq') | (COND cond') | (WHILE logexp stmt) | % % (REPEAT stmt logexp) | (FOR var (exp exp exp) DO stmt) | % % (GO id) | (RETURN arg) | (WRITE arg arg') | % % (PROGN stmt stmt') | (BLOCK (id') stmt') | (id arg') % if atom exp then idp exp else if car exp eq 'setq then gpsetq1p cdr exp else if car exp eq 'cond then gpcond1p cdr exp else if car exp eq 'while then length exp=3 and gplogexpp cadr exp and gpstmtp caddr exp else if car exp eq 'repeat then length exp=3 and gpstmtp cadr exp and gplogexpp caddr exp else if car exp eq 'for then length exp=5 and gpvarp cadr exp and listp caddr exp and (length caddr exp=3 and gpexpp car caddr exp and gpexpp cadr caddr exp and gpexpp caddr caddr exp) and cadddr exp eq 'do and gpstmtp car cddddr exp else if car exp eq 'go then length exp=2 and idp cadr exp else if car exp eq 'return then length exp=2 and gpargp cadr exp else if car exp eq 'write then length exp >= 2 and gpargp cadr exp and gparg1p cddr exp else if car exp eq 'progn then length exp >= 2 and gpstmtp cadr exp and gpstmt1p cddr exp else if car exp eq 'block then length exp >= 2 and gpid1p cadr exp and gpstmt1p cddr exp else if unresidp car exp then gparg1p cdr exp$ procedure gpsetq1p exp; % setq' ::= id setq'' | (id exp exp') setq''' % if exp and length exp=2 then if atom car exp then idp car exp and gpsetq2p cdr exp else (length car exp >= 2 and idp car car exp and unresidp car car exp and gpexpp cadr car exp and gpexp1p cddr car exp) and gpsetq3p cdr exp$ procedure gpsetq2p exp; % setq'' ::= (MAT list list') | setq''' % if exp then if listp car exp and caar exp eq 'mat then onep length exp and (gplistp cadar exp and gplist1p cddar exp) else gpsetq3p exp$ procedure gpsetq3p exp; % setq''' ::= (FOR var (exp exp exp) forop exp) | (READ) | exp | logexp if exp and onep length exp then gpexpp car exp or gplogexpp car exp or (if caar exp eq 'for then length car exp=5 and gpvarp cadar exp and (listp caddar exp and length caddar exp=3 and gpexpp car caddar exp and gpexpp cadr caddar exp and gpexpp caddr caddar exp) and gpforopp car cdddar exp and gpexpp cadr cdddar exp else if caar exp eq 'read then onep length car exp)$ procedure gpforopp exp; % forop ::= SUM | PRODUCT % exp memq '(sum product)$ procedure gpcond1p exp; % cond' ::= (logexp stmt) cond' | eps % null exp or (listp car exp and length car exp=2 and gplogexpp caar exp and gpstmtp cadar exp and gpcond1p cdr exp)$ procedure gpstmt1p exp; % stmt' ::= stmt stmt' | eps % null exp or (gpstmtp car exp and gpstmt1p cdr exp)$ procedure gpdefnp exp; % defn ::= (PROCEDURE id NIL EXPR (id') stmt) % listp exp and car exp eq 'procedure and length exp=6 and idp cadr exp and null caddr exp and atom cadddr exp and gpid1p car cddddr exp and gpstmtp cadr cddddr exp and not idp cadr cddddr exp$ %% %% %% Predicates %% %% %% procedure unresidp id; not (id memq !*reservedops!*)$ endmodule; module redlsp; %% GENTRAN LISP Code Generation Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: LispCode symbolic$ % GENTRAN Global Variables % global '(!*lisparithexpops!* !*lisplogexpops!* !*redarithexpops!* !*redlogexpops!* !*redreswds!* !*redstmtgpops!* !*redstmtops!*)$ !*redarithexpops!*:= '(difference expt minus plus quotient recip times)$ !*redlogexpops!* := '(and equal geq greaterp leq lessp neq not or)$ !*redreswds!* := '(and block cond de difference end equal expt !~for for geq getel go greaterp leq lessp list minus neq not or plus plus2 prog progn procedure quotient read recip repeat return setel setk setq stop times times2 while write)$ %REDUCE reserved words !*redstmtgpops!* := '(block progn)$ !*redstmtops!* := '(cond end !~for for go repeat return setq stop while write)$ % REDUCE Global Variable % global '(!*period)$ global '(!*do!* !*for!*)$ procedure lispcode forms; for each f in forms collect if redexpp f then lispcodeexp(f, !*period) else if redstmtp f or redstmtgpp f then lispcodestmt f else if reddefp f then lispcodedef f else if listp f then for each e in f collect lispcode e$ procedure lispcodeexp(form, fp); % (RECIP exp) ==> (QUOTIENT 1.0 exp) % % (DIFFERENCE exp1 exp2) ==> (PLUS exp1 (MINUS exp2)) % % integer ==> floating point iff PERIOD flag is ON & % % not exponent & % % not subscript & % % not loop index % if numberp form then if fp then float form else form else if atom form then form else if car form eq 'expt then list('expt, lispcodeexp(cadr form, fp), lispcodeexp(caddr form, nil)) else if car form eq 'recip then if fp then list('quotient, 1.0, lispcodeexp(cadr form, fp)) else list('quotient, 1, lispcodeexp(cadr form, fp)) else if car form eq 'difference then list('plus, lispcodeexp(cadr form, fp), list('minus, lispcodeexp(caddr form, fp))) else if not car form memq !*lisparithexpops!* and not car form memq !*lisplogexpops!* then for each elt in form collect lispcodeexp(elt, nil) else for each elt in form collect lispcodeexp(elt, fp)$ procedure lispcodestmt form; if atom form then form else if redassignp form then lispcodeassign form else if redreadp form then lispcoderead form else if redprintp form then lispcodeprint form else if redwhilep form then lispcodewhile form else if redrepeatp form then lispcoderepeat form else if redforp form then lispcodefor form else if redcondp form then lispcodecond form else if redreturnp form then lispcodereturn form else if redstmtgpp form then lispcodestmtgp form else if reddefp form then lispcodedef form else if car form eq 'literal then for each elt in form collect lispcodeexp(elt, nil) else for each elt in form collect lispcodeexp(elt, !*period)$ procedure lispcodeassign form; % (SETQ var (MAT lst lst')) --> (PROGN (SETQ (var 1 1) exp11) % % (SETQ (var 1 2) exp12) % % . % % . % % (SETQ (var m n) expmn)) % if listp caddr form and caaddr form eq 'mat then begin scalar name, r, c, relts, result; name := cadr form; form := caddr form; r := c := 1; while form := cdr form do << relts := car form; repeat << result := mkassign(list(name, r, c), lispcodeexp(car relts, !*period)) . result; c := add1 c >> until null(relts := cdr relts); r := add1 r; c := 1 >>; return mkstmtgp(nil, reverse result) end else mkassign(lispcodeexp(cadr form, !*period), lispcodeexp(caddr form, !*period))$ procedure lispcoderead form; % (SETQ var (READ)) --> (READ var) % list('read, lispcodeexp(cadr form, nil))$ procedure lispcodeprint form; 'write . for each elt in cdr form collect lispcodeexp(elt, !*period)$ procedure lispcodewhile form; 'while . lispcodeexp(cadr form, !*period) . foreach st in cddr form collect lispcodestmt st$ procedure lispcoderepeat form; begin scalar body, logexp; body := reverse cdr form; logexp := car body; body := reverse cdr body; return 'repeat . append(foreach st in body collect lispcodestmt st, list lispcodeexp(logexp, !*period)) end$ procedure lispcodefor form; % (SETQ var1 (FOR var (exp1 exp2 exp3) SUM exp)) % --> (PROGN (SETQ var1 0/0.0) % (FOR var (exp1 exp2 exp3) DO (SETQ var1 (PLUS var1 exp)))) % (SETQ var1 (FOR var (exp1 exp2 exp3) PRODUCT exp)) % --> (PROGN (SETQ var1 1/1.0) % (FOR var (exp1 exp2 exp3) DO (SETQ var1 (TIMES var1 exp)))) if car form eq 'for then begin scalar explst, stmtlst; explst := list(cadr form, caddr form); stmtlst := cddddr form; return append(!*for!* . foreach exp in explst collect lispcodeexp(exp, nil), !*do!* . foreach st in stmtlst collect lispcodestmt st) end else begin scalar var1, var, explst, op, exp; var1 := cadr form; form := caddr form; var := cadr form; explst := caddr form; if cadddr form eq 'sum then op := 'plus else op := 'times; exp := car cddddr form; form := list('prog, nil, list('setq, var1, if op eq 'plus then 0 else 1), list(!*for!*, var, explst, !*do!*, list('setq, var1, list(op, var1, exp)))); return lispcodestmt form end$ procedure lispcodecond form; begin scalar result, pr; while form := cdr form do << pr := car form; pr := lispcodeexp(car pr, !*period) . for each stmt in cdr pr collect lispcodestmt stmt; result := pr . result >>; return mkcond reverse result end$ procedure lispcodereturn form; % (RETURN NIL) --> (RETURN) % if form member '((return) (return nil)) then list 'return else mkreturn lispcodeexp(cadr form, !*period)$ procedure lispcodestmtgp form; % (BLOCK () stmt1 stmt2 .. stmtm) % % --> (PROG () stmt1 stmt2 .. stmtm) % if car form memq '(prog block) then mkstmtgp(cadr form, for each stmt in cddr form collect lispcodestmt stmt) else mkstmtgp(0, for each stmt in cdr form collect lispcodestmt stmt)$ procedure lispcodedef form; % (PROCEDURE id NIL EXPR (p1 p2 .. pn) stmt') % % --> (DEFUN id (p1 p2 .. pn) stmt') % if car form eq 'procedure then mkdef(cadr form, car cddddr form, for each stmt in cdr cddddr form collect lispcodestmt stmt) else mkdef(cadr form, caddr form, for each stmt in cdddr form collect lispcodestmt stmt)$ %% REDUCE Form Predicates %% procedure redassignp form; listp form and car form eq 'setq and redassign1p caddr form$ procedure redassign1p form; if atom form then t else if car form eq 'setq then redassign1p caddr form else if car form memq '(read for) then nil else t$ procedure redcondp form; listp form and car form eq 'cond$ procedure reddefp form; listp form and car form eq 'procedure$ procedure redexpp form; atom form or car form memq !*redarithexpops!* or car form memq !*redlogexpops!* or not(car form memq !*redreswds!*)$ procedure redforp form; if listp form then if car form eq 'for then t else if car form eq 'setq then redfor1p caddr form$ procedure redfor1p form; if atom form then nil else if car form eq 'setq then redfor1p caddr form else if car form eq 'for then t$ procedure redprintp form; listp form and car form eq 'write$ procedure redreadp form; listp form and car form eq 'setq and redread1p caddr form$ procedure redread1p form; if atom form then nil else if car form eq 'setq then redread1p caddr form else if car form eq 'read then t$ procedure redrepeatp form; listp form and car form eq 'repeat$ procedure redreturnp form; listp form and car form eq 'return$ procedure redstmtp form; atom form or car form memq !*redstmtops!* or atom car form and not(car form memq !*redreswds!*)$ procedure redstmtgpp form; listp form and car form memq !*redstmtgpops!*$ procedure redwhilep form; listp form and car form eq 'while$ endmodule; module segmnt; %% Segmentation Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry points: Seg, MARKEDVARP, MARKVAR, TEMPVAR, UNMARKVAR symbolic$ % User-Accessible Global Variables % global '(gentranlang!* maxexpprintlen!* tempvarname!* tempvarnum!* tempvartype!*)$ share 'gentranlang!*, 'maxexpprintlen!*, 'tempvarname!*, 'tempvarnum!*, 'tempvartype!*$ maxexpprintlen!* := 800$ tempvarname!* := 't$ tempvarnum!* := 0$ tempvartype!* := nil$ % User-Accessible Primitive Functions % operator markedvarp, markvar, tempvar, unmarkvar$ global '(!*do!* !*for!*)$ %% %% %% Segmentation Routines %% %% %% procedure seg forms; % exp --+--> exp % % +--> (assign assign ... assign exp ) % % (1) (2) (n-1) (n) % % stmt --+--> stmt % % +--> stmtgp % % stmtgp --> stmtgp % % def --> def % for each f in forms collect if lispexpp f then if toolongexpp f then segexp(f, 'unknown) else f else if lispstmtp f then segstmt f else if lispstmtgpp f then if toolongstmtgpp f then seggroup f else f else if lispdefp f then if toolongdefp f then segdef f else f else f$ procedure segexp(exp, type); % exp --> (assign assign ... assign exp ) % % (1) (2) (n-1) (n) % reverse segexp1(exp, type)$ procedure segexp1(exp, type); % exp --> (exp assign assign ... assign ) % % (n) (n-1) (n-2) (1) % begin scalar res; res := segexp2(exp, type); unmarkvar res; if car res = cadadr res then << res := cdr res; rplaca(res, caddar res) >>; return res end$ procedure segexp2(exp, type); % exp --> (exp assign assign ... assign ) % % (n) (n-1) (n-2) (1) % begin scalar expn, assigns, newassigns, unops, op, termlist, var, tmp; expn := exp; while length expn=2 do << unops := car expn . unops; expn := cadr expn >>; op := car expn; for each term in cdr expn do << if toolongexpp term then << tmp := segexp2(term, type); term := car tmp; newassigns := cdr tmp >> else newassigns := '(); if toolongexpp (op . term . termlist) and termlist and (length termlist > 1 or listp car termlist) then << unmarkvar termlist; var := var or tempvar type; markvar var; assigns := mkassign(var, if onep length termlist then car termlist else op . termlist) . assigns; termlist := list(var, term) >> else termlist := append(termlist, list term); assigns := append(newassigns, assigns) >>; expn := if onep length termlist then car termlist else op . termlist; while unops do << expn := list(car unops, expn); unops := cdr unops >>; if expn = exp then << unmarkvar expn; var := var or tempvar type; markvar var; assigns := list mkassign(var, expn); expn := var >>; return expn . assigns end$ procedure segstmt stmt; % assign --+--> assign % % +--> stmtgp % % cond --+--> cond % % +--> stmtgp % % while --+--> while % % +--> stmtgp % % repeat --> repeat % % for --+--> for % % +--> stmtgp % % return --+--> return % % +--> stmtgp % if lispassignp stmt then if toolongassignp stmt then segassign stmt else stmt else if lispcondp stmt then if toolongcondp stmt then segcond stmt else stmt else if lispwhilep stmt then if toolongwhilep stmt then segwhile stmt else stmt else if lisprepeatp stmt then if toolongrepeatp stmt then segrepeat stmt else stmt else if lispforp stmt then if toolongforp stmt then segfor stmt else stmt else if lispreturnp stmt then if toolongreturnp stmt then segreturn stmt else stmt else stmt$ procedure segassign stmt; % assign --> stmtgp % begin scalar var, exp, type; var := cadr stmt; type := getvartype var; exp := caddr stmt; stmt := segexp1(exp, type); rplaca(stmt, mkassign(var, car stmt)); return mkstmtgp(nil, reverse stmt) end$ procedure segcond condd; % cond --+--> cond % % +--> stmtgp % begin scalar tassigns, res, markedvars, type; if gentranlang!* eq 'c then type := 'int else type := 'logical; while condd := cdr condd do begin scalar exp, stmt; if toolongexpp(exp := caar condd) then << exp := segexp1(exp, type); tassigns := append(cdr exp, tassigns); exp := car exp; markvar exp; markedvars := exp . markedvars >>; stmt := for each st in cdar condd conc seg list st; res := (exp . stmt) . res end; unmarkvar markedvars; return if tassigns then mkstmtgp(nil, reverse(mkcond reverse res . tassigns)) else mkcond reverse res end$ procedure segwhile stmt; % while --+--> while % % +--> stmtgp % begin scalar logexp, stmtlst, tassigns, type, res; logexp := cadr stmt; stmtlst := cddr stmt; if toolongexpp logexp then << if gentranlang!* eq 'c then type := 'int else type := 'logical; tassigns := segexp1(logexp, type); logexp := car tassigns; tassigns := cdr tassigns >>; stmtlst := foreach st in stmtlst conc seg list st; res := 'while . logexp . stmtlst; if tassigns then << res := append(res, reverse tassigns); res := 'progn . append(reverse tassigns, list res) >>; return res end$ procedure segrepeat stmt; % repeat --> repeat % begin scalar stmtlst, logexp, type; stmt := reverse cdr stmt; logexp := car stmt; stmtlst := reverse cdr stmt; stmtlst := foreach st in stmtlst conc seg list st; if toolongexpp logexp then << if gentranlang!* eq 'c then type := 'int else type := 'logical; logexp := segexp1(logexp, type); stmtlst := append(stmtlst, reverse cdr logexp); logexp := car logexp >>; return 'repeat . append(stmtlst, list logexp) end$ procedure segfor stmt; % for --+--> for % % +--> stmtgp % begin scalar var, loexp, stepexp, hiexp, stmtlst, tassigns1, tassigns2, type, markedvars, res; var := cadr stmt; type := getvartype var; stmt := cddr stmt; loexp := caar stmt; stepexp := cadar stmt; hiexp := caddar stmt; stmtlst := cddr stmt; if toolongexpp loexp then << loexp := segexp1(loexp, type); tassigns1 := reverse cdr loexp; loexp := car loexp; markvar loexp; markedvars := loexp . markedvars >>; if toolongexpp stepexp then << stepexp := segexp1(stepexp, type); tassigns2 := reverse cdr stepexp; stepexp := car stepexp; markvar stepexp; markedvars := stepexp . markedvars >>; if toolongexpp hiexp then << hiexp := segexp1(hiexp, type); tassigns1 := append(tassigns1, reverse cdr hiexp); tassigns2 := append(tassigns2, reverse cdr hiexp); hiexp := car hiexp >>; unmarkvar markedvars; stmtlst := foreach st in stmtlst conc seg list st; stmtlst := append(stmtlst, tassigns2); res := !*for!* . var . list(loexp, stepexp, hiexp) . !*do!* . stmtlst; if tassigns1 then return mkstmtgp(nil, append(tassigns1, list res)) else return res end$ procedure segreturn ret; % return --> stmtgp % << ret := segexp1(cadr ret, 'unknown); rplaca(ret, mkreturn car ret); mkstmtgp(nil, reverse ret) >>$ procedure seggroup stmtgp; % stmtgp --> stmtgp % begin scalar locvars, res; if car stmtgp eq 'prog then << locvars := cadr stmtgp; stmtgp := cdr stmtgp >> else locvars := 0; while stmtgp := cdr stmtgp do res := append(seg list car stmtgp, res); return mkstmtgp(locvars, reverse res) end$ procedure segdef deff; % def --> def % mkdef(cadr deff, caddr deff, for each stmt in cdddr deff conc seg list stmt)$ %% %% %% Long Statement & Expression Predicates %% %% %% procedure toolongexpp exp; numprintlen exp > maxexpprintlen!*$ procedure toolongstmtp stmt; if atom stmt then nil else if lispstmtp stmt then if lispcondp stmt then toolongcondp stmt else if lispassignp stmt then toolongassignp stmt else if lispreturnp stmt then toolongreturnp stmt else if lispwhilep stmt then toolongwhilep stmt else if lisprepeatp stmt then toolongrepeatp stmt else if lispforp stmt then toolongforp stmt else eval('or . for each exp in stmt collect toolongexpp exp) else toolongstmtgpp stmt$ procedure toolongassignp assign; toolongexpp caddr assign$ procedure toolongcondp condd; begin scalar toolong; while condd := cdr condd do if toolongexpp caar condd or toolongstmtp cadar condd then toolong := t; return toolong end$ procedure toolongwhilep stmt; toolongexpp cadr stmt or eval('or . foreach st in cddr stmt collect toolongstmtp st )$ procedure toolongrepeatp stmt; << stmt := reverse cdr stmt; toolongexpp car stmt or eval('or . foreach st in cdr stmt collect toolongstmtp st ) >>$ procedure toolongforp stmt; eval('or . foreach exp in caddr stmt collect toolongexpp exp ) or eval('or . foreach st in cddddr stmt collect toolongstmtp st )$ procedure toolongreturnp ret; toolongexpp cadr ret$ procedure toolongstmtgpp stmtgp; eval('or . for each stmt in cdr stmtgp collect toolongstmtp stmt )$ procedure toolongdefp deff; if lispstmtgpp cadddr deff then toolongstmtgpp cadddr deff else eval('or . for each stmt in cdddr deff collect toolongstmtp stmt )$ %% %% %% Print Length Function %% %% %% procedure numprintlen exp; if atom exp then length explode exp else if onep length exp then numprintlen car exp else length exp + eval('plus . for each elt in cdr exp collect numprintlen elt )$ %% %% %% Temporary Variable Generation, Marking & Unmarking Functions %% %% %% procedure tempvar type; % % % IF type Member '(NIL 0) THEN type <- TEMPVARTYPE!* % % % % IF type Neq 'NIL And type Neq 'UNKNOWN THEN % % var <- 1st unmarked tvar of VType type or of VType NIL % % which isn't in the symbol table % % put type on var's VType property list % % put declaration in symbol table % % ELSE IF type = NIL THEN % % var <- 1st unmarked tvar of type NIL which isn't in the % % symbol table % % ELSE type = 'UNKNOWN % % var <- 1st unmarked tvar of type NIL which isn't in the % % symbol table % % put 'UNKNOWN on var's VType property list % % print warning - "undeclared" % % % % RETURN var % % % begin scalar tvar, xname, num; if type memq '(nil 0) then type := tempvartype!*; xname := explode tempvarname!*; num := tempvarnum!*; if type memq '(nil unknown) then repeat << tvar := intern compress append(xname, explode num); num := add1 num >> until not markedvarp tvar and not get(tvar, '!*vtype!*) and not getvartype tvar else repeat << tvar := intern compress append(xname, explode num); num := add1 num >> until not markedvarp tvar and (get(tvar, '!*vtype!*) eq type or not get(tvar, '!*vtype!*) and not getvartype tvar); put(tvar, '!*vtype!*, type); if type eq 'unknown then gentranerr('w, tvar, "UNDECLARED VARIABLE", nil) else if type then symtabput(nil, tvar, list type); return tvar end$ procedure markvar var; if numberp var then var else if atom var then << flag(list var, '!*marked!*); var >> else << for each v in var do markvar v; var >>$ procedure markedvarp var; flagp(var, '!*marked!*)$ procedure unmarkvar var; if atom var then if numberp var then var else remflag(list var, '!*marked!*) else foreach elt in var do unmarkvar elt$ endmodule; module lspfor; %% GENTRAN LISP-to-FORTRAN Translation Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: FortCode symbolic$ global '(!*gendecs)$ switch gendecs$ % User-Accessible Global Variables % global '(fortcurrind!* tablen!*)$ share 'fortcurrind!*, 'tablen!*$ fortcurrind!* := 0$ % GENTRAN Global Variables % global '(!*endofloopstack!* !*subprogname!*)$ !*endofloopstack!* := nil$ !*subprogname!* := nil$ %name of subprogram being generated global '(!*do!*)$ %% %% %% LISP-to-FORTRAN Translation Functions %% %% %% %% Control Function %% procedure fortcode forms; for each f in forms conc if atom f then fortexp f else if lispstmtp f or lispstmtgpp f then if !*gendecs then begin scalar r; r := append(fortdecs symtabget('!*main!*, '!*decs!*), fortstmt f); symtabrem('!*main!*, '!*decs!*); return r end else fortstmt f else if lispdefp f then fortsubprog f else fortexp f$ %% Subprogram Translation %% procedure fortsubprog deff; begin scalar type, stype, name, params, body, lastst, r; name := !*subprogname!* := cadr deff; if onep length (body := cdddr deff) and lispstmtgpp car body then << body := cdar body; if null car body then body := cdr body >>; if lispreturnp (lastst := car reverse body) then body := append(body, list '(end)) else if not lispendp lastst then body := append(body, list('(return), '(end))); if (type := symtabget(name, name)) then << type := cadr type; symtabrem(name, name) >>; stype := symtabget(name, '!*type!*) or ( if type or functionformp(body, name) then 'function else 'subroutine ); symtabrem(name, '!*type!*); params := symtabget(name, '!*params!*) or caddr deff; symtabrem(name, '!*params!*); r := mkffortsubprogdec(type, stype, name, params); if !*gendecs then r := append(r, fortdecs symtabget(name, '!*decs!*)); r := append(r, for each s in body conc fortstmt s); if !*gendecs then << symtabrem(name, nil); symtabrem(name, '!*decs!*) >>; return r end$ %% Generation of Declarations %% procedure fortdecs decs; for each tl in formtypelists decs conc mkffortdec(car tl, cdr tl)$ %% Expression Translation %% procedure fortexp exp; fortexp1(exp, 0)$ procedure fortexp1(exp, wtin); if atom exp then list fortranname exp else if onep length exp then fortranname exp else if optype car exp then begin scalar wt, op, res; wt := fortranprecedence car exp; op := fortranop car exp; exp := cdr exp; if onep length exp then res := op . fortexp1(car exp, wt) else << res := fortexp1(car exp, wt); if op eq '!+ then while exp := cdr exp do << if atom car exp or caar exp neq 'minus then res := append(res, list op); res := append(res, fortexp1(car exp, wt)) >> else while exp := cdr exp do res := append(append(res, list op), fortexp1(car exp, wt)) >>; if wtin > wt then res := insertparens res; return res end else if car exp eq 'literal then fortliteral exp else begin scalar op, res; op := fortranname car exp; exp := cdr exp; res := fortexp1(car exp, 0); while exp := cdr exp do res := append(append(res, list '!,), fortexp1(car exp, 0)); return op . insertparens res end$ procedure fortranop op; get(op, '!*fortranop!*) or op$ put('or, '!*fortranop!*, '!.or!. )$ put('and, '!*fortranop!*, '!.and!.)$ put('not, '!*fortranop!*, '!.not!.)$ put('equal, '!*fortranop!*, '!.eq!. )$ put('neq, '!*fortranop!*, '!.ne!. )$ put('greaterp, '!*fortranop!*, '!.gt!. )$ put('geq, '!*fortranop!*, '!.ge!. )$ put('lessp, '!*fortranop!*, '!.lt!. )$ put('leq, '!*fortranop!*, '!.le!. )$ put('plus, '!*fortranop!*, '!+ )$ put('times, '!*fortranop!*, '!* )$ put('quotient, '!*fortranop!*, '/ )$ put('minus, '!*fortranop!*, '!- )$ put('expt, '!*fortranop!*, '!*!* )$ procedure fortranname a; if stringp a then stringtoatom a % convert a to atom containing "'s else get(a, '!*fortranname!*) or a$ put(t, '!*fortranname!*, '!.true!. )$ put(nil, '!*fortranname!*, '!.false!.)$ procedure fortranprecedence op; get(op, '!*fortranprecedence!*) or 9$ put('or, '!*fortranprecedence!*, 1)$ put('and, '!*fortranprecedence!*, 2)$ put('not, '!*fortranprecedence!*, 3)$ put('equal, '!*fortranprecedence!*, 4)$ put('neq, '!*fortranprecedence!*, 4)$ put('greaterp, '!*fortranprecedence!*, 4)$ put('geq, '!*fortranprecedence!*, 4)$ put('lessp, '!*fortranprecedence!*, 4)$ put('leq, '!*fortranprecedence!*, 4)$ put('plus, '!*fortranprecedence!*, 5)$ put('times, '!*fortranprecedence!*, 6)$ put('quotient, '!*fortranprecedence!*, 6)$ put('minus, '!*fortranprecedence!*, 7)$ put('expt, '!*fortranprecedence!*, 8)$ %% Statement Translation %% procedure fortstmt stmt; if null stmt then nil else if lisplabelp stmt then fortstmtnum stmt else if car stmt eq 'literal then fortliteral stmt else if lispreadp stmt then fortread stmt else if lispassignp stmt then fortassign stmt else if lispprintp stmt then fortwrite stmt else if lispcondp stmt then fortif stmt else if lispbreakp stmt then fortbreak stmt else if lispgop stmt then fortgoto stmt else if lispreturnp stmt then fortreturn stmt else if lispstopp stmt then fortstop stmt else if lispendp stmt then fortend stmt else if lispwhilep stmt then fortwhile stmt else if lisprepeatp stmt then fortrepeat stmt else if lispforp stmt then fortfor stmt else if lispstmtgpp stmt then fortstmtgp stmt else if lispdefp stmt then fortsubprog stmt else if lispcallp stmt then fortcall stmt$ procedure fortassign stmt; mkffortassign(cadr stmt, caddr stmt)$ procedure fortbreak stmt; if null !*endofloopstack!* then gentranerr('e, nil, "BREAK NOT INSIDE LOOP - CANNOT BE TRANSLATED", nil) else if atom car !*endofloopstack!* then begin scalar n1; n1 := genstmtnum(); rplaca(!*endofloopstack!*, list(car !*endofloopstack!*, n1)); return mkffortgo n1 end else mkffortgo cadar !*endofloopstack!*$ procedure fortcall stmt; mkffortcall(car stmt, cdr stmt)$ procedure fortfor stmt; begin scalar n1, result, var, loexp, stepexp, hiexp, stmtlst; var := cadr stmt; stmt := cddr stmt; loexp := caar stmt; stepexp := cadar stmt; hiexp := caddar stmt; stmtlst := cddr stmt; n1 := genstmtnum(); !*endofloopstack!* := n1 . !*endofloopstack!*; result := mkffortdo(n1, var, loexp, hiexp, stepexp); indentfortlevel(+1); result := append(result, for each st in stmtlst conc fortstmt st); indentfortlevel(-1); result := append(result, mkffortcontinue n1); if listp car !*endofloopstack!* then result := append(result, mkffortcontinue cadar !*endofloopstack!*); !*endofloopstack!* := cdr !*endofloopstack!*; return result end$ procedure fortend stmt; mkffortend()$ procedure fortgoto stmt; begin scalar stmtnum; if not ( stmtnum := get(cadr stmt, '!*stmtnum!*) ) then stmtnum := put(cadr stmt, '!*stmtnum!*, genstmtnum()); return mkffortgo stmtnum end$ procedure fortif stmt; begin scalar n1, n2, res; stmt := cdr stmt; if onep length stmt then if caar stmt eq t then return for each st in cdar stmt conc fortstmt st else return << n1 := genstmtnum(); res := mkffortifgo(list('not, caar stmt), n1); indentfortlevel(+1); res := append(res, for each st in cdar stmt conc fortstmt st); indentfortlevel(-1); append(res, mkffortcontinue n1) >> else return << n1 := genstmtnum(); n2 := genstmtnum(); res := mkffortifgo(list('not, caar stmt), n1); indentfortlevel(+1); res := append(res, for each st in cdar stmt conc fortstmt st); res := append(res, mkffortgo n2); indentfortlevel(-1); res := append(res, mkffortcontinue n1); indentfortlevel(+1); res := append(res, fortif('cond . cdr stmt)); indentfortlevel(-1); append(res, mkffortcontinue n2) >> end$ procedure fortliteral stmt; mkffortliteral cdr stmt$ procedure fortread stmt; mkffortread cadr stmt$ procedure fortrepeat stmt; begin scalar n, result, stmtlst, logexp; stmtlst := reverse cdr stmt; logexp := car stmtlst; stmtlst := reverse cdr stmtlst; n := genstmtnum(); !*endofloopstack!* := 'dummy . !*endofloopstack!*; result := mkffortcontinue n; indentfortlevel(+1); result := append(result, for each st in stmtlst conc fortstmt st); indentfortlevel(-1); result := append(result, mkffortifgo(list('not, logexp), n)); if listp car !*endofloopstack!* then result := append(result, mkffortcontinue cadar !*endofloopstack!*); !*endofloopstack!* := cdr !*endofloopstack!*; return result end$ procedure fortreturn stmt; if onep length stmt then mkffortreturn() else if !*subprogname!* then append(mkffortassign(!*subprogname!*, cadr stmt), mkffortreturn()) else gentranerr('e, nil, "RETURN NOT INSIDE FUNCTION - CANNOT BE TRANSLATED", nil)$ procedure fortstmtgp stmtgp; << if car stmtgp eq 'progn then stmtgp := cdr stmtgp else stmtgp := cddr stmtgp; for each stmt in stmtgp conc fortstmt stmt >>$ procedure fortstmtnum label; begin scalar stmtnum; if not ( stmtnum := get(label, '!*stmtnum!*) ) then stmtnum := put(label, '!*stmtnum!*, genstmtnum()); return mkffortcontinue stmtnum end$ procedure fortstop stmt; mkffortstop()$ procedure fortwhile stmt; begin scalar n1, n2, result, logexp, stmtlst; logexp := cadr stmt; stmtlst := cddr stmt; n1 := genstmtnum(); n2 := genstmtnum(); !*endofloopstack!* := n2 . !*endofloopstack!*; result := append(list(n1, '! ), mkffortifgo(list('not, logexp), n2)); indentfortlevel(+1); result := append(result, for each st in stmtlst conc fortstmt st); result := append(result, mkffortgo n1); indentfortlevel(-1); result := append(result, mkffortcontinue n2); if listp car !*endofloopstack!* then result := append(result, mkffortcontinue cadar !*endofloopstack!*); !*endofloopstack!* := cdr !*endofloopstack!*; return result end$ procedure fortwrite stmt; mkffortwrite cdr stmt$ %% %% %% FORTRAN Code Formatting Functions %% %% %% %% Statement Formatting %% procedure mkffortassign(lhs, rhs); append(append(mkforttab() . fortexp lhs, '!= . fortexp rhs), list mkfortterpri())$ procedure mkffortcall(fname, params); << if params then params := append(append(list '!(, for each p in insertcommas params conc fortexp p), list '!)); append(append(list(mkforttab(), 'call, '! ), fortexp fname), append(params, list mkfortterpri())) >>$ procedure mkffortcontinue stmtnum; list(stmtnum, '! , mkforttab(), 'continue, mkfortterpri())$ procedure mkffortdec(type, varlist); << type := type or 'dimension; varlist := for each v in insertcommas varlist conc fortexp v; if implicitp type then append(list(mkforttab(), type, '! , '!(), append(varlist, list('!), mkfortterpri()))) else append(list(mkforttab(), type, '! ), append(varlist,list mkfortterpri())) >>$ procedure mkffortdo(stmtnum, var, lo, hi, incr); << if onep incr then incr := nil else if incr then incr := '!, . fortexp incr; append(append(append(list(mkforttab(), !*do!*, '! , stmtnum, '! ), fortexp var), append('!= . fortexp lo, '!, . fortexp hi)), append(incr, list mkfortterpri())) >>$ procedure mkffortend; list(mkforttab(), 'end, mkfortterpri())$ procedure mkffortgo stmtnum; list(mkforttab(), 'goto, '! , stmtnum, mkfortterpri())$ procedure mkffortifgo(exp, stmtnum); append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp), list('!), '! , 'goto, '! , stmtnum, mkfortterpri()))$ procedure mkffortliteral args; for each a in args conc if a eq 'tab!* then list mkforttab() else if a eq 'cr!* then list mkfortterpri() else if listp a then fortexp a else list stripquotes a$ procedure mkffortread var; append(list(mkforttab(), 'read, '!(!*!,!*!), '! ), append(fortexp var, list mkfortterpri()))$ procedure mkffortreturn; list(mkforttab(), 'return, mkfortterpri())$ procedure mkffortstop; list(mkforttab(), 'stop, mkfortterpri())$ procedure mkffortsubprogdec(type, stype, name, params); << if params then params := append('!( . for each p in insertcommas params conc fortexp p, list '!)); if type then type := list(mkforttab(), type, '! , stype, '! ) else type := list(mkforttab(), stype, '! ); append(append(type, fortexp name), append(params, list mkfortterpri())) >>$ procedure mkffortwrite arglist; append(append(list(mkforttab(), 'write, '!(!*!,!*!), '! ), for each arg in insertcommas arglist conc fortexp arg), list mkfortterpri())$ %% Indentation Control %% procedure mkforttab; list('forttab, fortcurrind!* + 6)$ procedure indentfortlevel n; fortcurrind!* := fortcurrind!* + n * tablen!*$ procedure mkfortterpri; list 'fortterpri$ endmodule; module lsprat; %% GENTRAN LISP-to-RATFOR Translation Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: RatCode symbolic$ global '(!*gendecs)$ switch gendecs$ % User-Accessible Global Variables % global '(ratcurrind!* tablen!*)$ share 'ratcurrind!*, 'tablen!*$ ratcurrind!* := 0$ global '(!*do!*)$ %% %% %% LISP-to-RATFOR Translation Functions %% %% %% %% Control Function %% procedure ratcode forms; for each f in forms conc if atom f then ratexp f else if lispstmtp f or lispstmtgpp f then if !*gendecs then begin scalar r; r := append(ratdecs symtabget('!*main!*, '!*decs!*), ratstmt f); symtabrem('!*main!*, '!*decs!*); return r end else ratstmt f else if lispdefp f then ratsubprog f else ratexp f$ %% Subprogram Translation %% procedure ratsubprog deff; begin scalar type, stype, name, params, body, lastst, r; name := cadr deff; if onep length(body := cdddr deff) and lispstmtgpp car body then << body := cdar body; if null car body then body := cdr body >>; if lispreturnp (lastst := car reverse body) then body := append(body, list '(end)) else if not lispendp lastst then body := append(body, list('(return), '(end))); if (type := symtabget(name, name)) then << type := cadr type; symtabrem(name, name) >>; stype := symtabget(name, '!*type!*) or ( if type or functionformp(body, name) then 'function else 'subroutine ); symtabrem(name, '!*type!*); params := symtabget(name, '!*params!*) or caddr deff; symtabrem(name, '!*params!*); r := mkfratsubprogdec(type, stype, name, params); if !*gendecs then r := append(r, ratdecs symtabget(name, '!*decs!*)); r := append(r, for each s in body conc ratstmt s); if !*gendecs then << symtabrem(name, nil); symtabrem(name, '!*decs!*) >>; return r end$ %% Generation of Declarations %% procedure ratdecs decs; for each tl in formtypelists decs conc mkfratdec(car tl, cdr tl)$ %% Expression Translation %% procedure ratexp exp; ratexp1(exp, 0)$ procedure ratexp1(exp, wtin); if atom exp then list ratforname exp else if onep length exp then ratforname exp else if optype car exp then begin scalar wt, op, res; wt := ratforprecedence car exp; op := ratforop car exp; exp := cdr exp; if onep length exp then res := op . ratexp1(car exp, wt) else << res := ratexp1(car exp, wt); if op eq '!+ then while exp := cdr exp do << if atom car exp or caar exp neq 'minus then res := append(res, list op); res := append(res, ratexp1(car exp, wt)) >> else while exp := cdr exp do res := append(append(res, list op), ratexp1(car exp, wt)) >>; if wtin > wt then res := insertparens res; return res end else if car exp eq 'literal then ratliteral exp else begin scalar op, res; op := ratforname car exp; exp := cdr exp; res := ratexp1(car exp, 0); while exp := cdr exp do res := append(append(res, list '!,), ratexp1(car exp, 0)); return op . insertparens res end$ procedure ratforop op; get(op, '!*ratforop!*) or op$ put('or, '!*ratforop!*, '| )$ put('and, '!*ratforop!*, '& )$ put('not, '!*ratforop!*, '!! )$ put('equal, '!*ratforop!*, '!=!=)$ put('neq, '!*ratforop!*, '!!!=)$ put('greaterp, '!*ratforop!*, '> )$ put('geq, '!*ratforop!*, '!>!=)$ put('lessp, '!*ratforop!*, '< )$ put('leq, '!*ratforop!*, '!<!=)$ put('plus, '!*ratforop!*, '!+ )$ put('times, '!*ratforop!*, '* )$ put('quotient, '!*ratforop!*, '/ )$ put('minus, '!*ratforop!*, '!- )$ put('expt, '!*ratforop!*, '!*!*)$ procedure ratforname a; if stringp a then stringtoatom a % convert a to atom containing "'s else get(a, '!*ratforname!*) or a$ put(t, '!*ratforname!*, '!.true!. )$ put(nil, '!*ratforname!*, '!.false!.)$ procedure ratforprecedence op; get(op, '!*ratforprecedence!*) or 9$ put('or, '!*ratforprecedence!*, 1)$ put('and, '!*ratforprecedence!*, 2)$ put('not, '!*ratforprecedence!*, 3)$ put('equal, '!*ratforprecedence!*, 4)$ put('neq, '!*ratforprecedence!*, 4)$ put('greaterp, '!*ratforprecedence!*, 4)$ put('geq, '!*ratforprecedence!*, 4)$ put('lessp, '!*ratforprecedence!*, 4)$ put('leq, '!*ratforprecedence!*, 4)$ put('plus, '!*ratforprecedence!*, 5)$ put('times, '!*ratforprecedence!*, 6)$ put('quotient, '!*ratforprecedence!*, 6)$ put('minus, '!*ratforprecedence!*, 7)$ put('expt, '!*ratforprecedence!*, 8)$ %% Statement Translation %% procedure ratstmt stmt; if null stmt then nil else if lisplabelp stmt then ratstmtnum stmt else if car stmt eq 'literal then ratliteral stmt else if lispreadp stmt then ratread stmt else if lispassignp stmt then ratassign stmt else if lispprintp stmt then ratwrite stmt else if lispcondp stmt then ratif stmt else if lispbreakp stmt then ratbreak stmt else if lispgop stmt then ratgoto stmt else if lispreturnp stmt then ratreturn stmt else if lispstopp stmt then ratstop stmt else if lispendp stmt then ratend stmt else if lisprepeatp stmt then ratrepeat stmt else if lispwhilep stmt then ratwhile stmt else if lispforp stmt then ratforfor stmt else if lispstmtgpp stmt then ratstmtgp stmt else if lispdefp stmt then ratsubprog stmt else if lispcallp stmt then ratcall stmt$ procedure ratassign stmt; mkfratassign(cadr stmt, caddr stmt)$ procedure ratbreak stmt; mkfratbreak()$ procedure ratcall stmt; mkfratcall(car stmt, cdr stmt)$ procedure ratforfor stmt; begin scalar r, var, loexp, stepexp, hiexp, stmtlst; var := cadr stmt; stmt := cddr stmt; loexp := caar stmt; stepexp := cadar stmt; hiexp := caddar stmt; stmtlst := cddr stmt; r := mkfratdo(var, loexp, hiexp, stepexp); indentratlevel(+1); r := append(r, foreach st in stmtlst conc ratstmt st); indentratlevel(-1); return r end$ procedure ratend stmt; mkfratend()$ procedure ratgoto stmt; begin scalar stmtnum; stmtnum := get(cadr stmt, '!*stmtnum!*) or put(cadr stmt, '!*stmtnum!*, genstmtnum()); return mkfratgo stmtnum end$ procedure ratif stmt; begin scalar r, st; r := mkfratif caadr stmt; indentratlevel(+1); st := seqtogp cdadr stmt; if listp st and car st eq 'cond and length st=2 then st := mkstmtgp(0, list st); r := append(r, ratstmt st); indentratlevel(-1); stmt := cdr stmt; while (stmt := cdr stmt) and caar stmt neq t do << r := append(r, mkfratelseif caar stmt); indentratlevel(+1); st := seqtogp cdar stmt; if listp st and car st eq 'cond and length st=2 then st := mkstmtgp(0, list st); r := append(r, ratstmt st); indentratlevel(-1) >>; if stmt then << r := append(r, mkfratelse()); indentratlevel(+1); st := seqtogp cdar stmt; if listp st and car st eq 'cond and length st=2 then st := mkstmtgp(0, list st); r := append(r, ratstmt st); indentratlevel(-1) >>; return r end$ procedure ratliteral stmt; mkfratliteral cdr stmt$ procedure ratread stmt; mkfratread cadr stmt$ procedure ratrepeat stmt; begin scalar r, stmtlst, logexp; stmt := reverse cdr stmt; logexp := car stmt; stmtlst := reverse cdr stmt; r := mkfratrepeat(); indentratlevel(+1); r := append(r, foreach st in stmtlst conc ratstmt st); indentratlevel(-1); return append(r, mkfratuntil logexp) end$ procedure ratreturn stmt; if cdr stmt then mkfratreturn cadr stmt else mkfratreturn nil$ procedure ratstmtgp stmtgp; begin scalar r; if car stmtgp eq 'progn then stmtgp := cdr stmtgp else stmtgp := cddr stmtgp; r := mkfratbegingp(); indentratlevel(+1); r := append(r, for each stmt in stmtgp conc ratstmt stmt); indentratlevel(-1); return append(r, mkfratendgp()) end$ procedure ratstmtnum label; begin scalar stmtnum; stmtnum := get(label, '!*stmtnum!*) or put(label, '!*stmtnum!*, genstmtnum()); return mkfratcontinue stmtnum end$ procedure ratstop stmt; mkfratstop()$ procedure ratwhile stmt; begin scalar r, logexp, stmtlst; logexp := cadr stmt; stmtlst := cddr stmt; r := mkfratwhile logexp; indentratlevel(+1); r := append(r, foreach st in stmtlst conc ratstmt st); indentratlevel(-1); return r end$ procedure ratwrite stmt; mkfratwrite cdr stmt$ %% %% %% RATFOR Code Formatting Functions %% %% %% %% Statement Formatting %% procedure mkfratassign(lhs, rhs); append(append(mkrattab() . ratexp lhs, '!= . ratexp rhs), list mkratterpri())$ procedure mkfratbegingp; list(mkrattab(), '!{, mkratterpri())$ procedure mkfratbreak; list(mkrattab(), 'break, mkratterpri())$ procedure mkfratcall(fname, params); << if params then params := append(append(list '!(, for each p in insertcommas params conc ratexp p), list '!)); append(append(list(mkrattab(), 'call, '! ), ratexp fname), append(params, list mkratterpri())) >>$ procedure mkfratcontinue stmtnum; list(stmtnum, '! , mkrattab(), 'continue, mkratterpri())$ procedure mkfratdec(type, varlist); << type := type or 'dimension; varlist := for each v in insertcommas varlist conc ratexp v; if implicitp type then append(list(mkrattab(), type, '! , '!(), append(varlist, list('!), mkratterpri()))) else append(list(mkrattab(), type, '! ), append(varlist, list mkratterpri())) >>$ procedure mkfratdo(var, lo, hi, incr); << if onep incr then incr := nil else if incr then incr := '!, . ratexp incr; append(append(append(list(mkrattab(), !*do!*, '! ), ratexp var), append('!= . ratexp lo, '!, . ratexp hi)), append(incr, list mkratterpri())) >>$ procedure mkfratelse; list(mkrattab(), 'else, mkratterpri())$ procedure mkfratelseif exp; append(append(list(mkrattab(), 'else, '! , 'if, '! , '!(), ratexp exp), list('!), mkratterpri()))$ procedure mkfratend; list(mkrattab(), 'end, mkratterpri())$ procedure mkfratendgp; list(mkrattab(), '!}, mkratterpri())$ procedure mkfratgo stmtnum; list(mkrattab(), 'goto, '! , stmtnum, mkratterpri())$ procedure mkfratif exp; append(append(list(mkrattab(), 'if, '! , '!(), ratexp exp), list('!), mkratterpri()))$ procedure mkfratliteral args; for each a in args conc if a eq 'tab!* then list mkrattab() else if a eq 'cr!* then list mkratterpri() else if listp a then ratexp a else list stripquotes a$ procedure mkfratread var; append(list(mkrattab(), 'read, '!(!*!,!*!), '! ), append(ratexp var, list mkratterpri()))$ procedure mkfratrepeat; list(mkrattab(), 'repeat, mkratterpri())$ procedure mkfratreturn exp; if exp then append(append(list(mkrattab(), 'return, '!(), ratexp exp), list('!), mkratterpri())) else list(mkrattab(), 'return, mkratterpri())$ procedure mkfratstop; list(mkrattab(), 'stop, mkratterpri())$ procedure mkfratsubprogdec(type, stype, name, params); << if params then params := append('!( . for each p in insertcommas params conc ratexp p, list '!)); if type then type := list(mkrattab(), type, '! , stype, '! ) else type := list(mkrattab(), stype, '! ); append(append(type, ratexp name), append(params,list mkratterpri())) >>$ procedure mkfratuntil logexp; append(list(mkrattab(), 'until, '! , '!(), append(ratexp logexp, list('!), mkratterpri())))$ procedure mkfratwhile exp; append(append(list(mkrattab(), 'while, '! , '!(), ratexp exp), list('!), mkratterpri()))$ procedure mkfratwrite arglist; append(append(list(mkrattab(), 'write, '!(!*!,!*!), '! ), for each arg in insertcommas arglist conc ratexp arg), list mkratterpri())$ %% Indentation Control %% procedure mkrattab; list('rattab, ratcurrind!*)$ procedure indentratlevel n; ratcurrind!* := ratcurrind!* + n * tablen!*$ procedure mkratterpri; list 'ratterpri$ endmodule; module lspc; %% GENTRAN LISP-to-C Translation Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: CCode symbolic$ global '(!*gendecs)$ switch gendecs$ % User-Accessible Global Variables % global '(ccurrind!* tablen!*)$ share 'ccurrind!*, 'tablen!*$ ccurrind!* := 0$ global '(!*do!* !*for!*)$ %% %% %% LISP-to-C Translation Functions %% %% %% %% Control Function %% procedure ccode forms; for each f in forms conc if atom f then cexp f else if lispstmtp f or lispstmtgpp f then if !*gendecs then begin scalar r; r := append(cdecs symtabget('!*main!*, '!*decs!*), cstmt f); symtabrem('!*main!*, '!*decs!*); return r end else cstmt f else if lispdefp f then cproc f else cexp f$ %% Procedure Translation %% procedure cproc deff; begin scalar type, name, params, paramtypes, vartypes, body, r; name := cadr deff; if onep length (body := cdddr deff) and lispstmtgpp car body then << body := cdar body; if null car body then body := cdr body >>; if (type := symtabget(name, name)) then << type := cadr type; symtabrem(name, name) >>; params := symtabget(name, '!*params!*) or caddr deff; symtabrem(name, '!*params!*); for each dec in symtabget(name, '!*decs!*) do if car dec memq params then paramtypes := append(paramtypes, list dec) else vartypes := append(vartypes, list dec); r := append( append( mkfcprocdec(type, name, params), cdecs paramtypes ), mkfcbegingp() ); indentclevel(+1); if !*gendecs then r := append(r, cdecs vartypes); r := append(r, for each s in body conc cstmt s); indentclevel(-1); r := append(r, mkfcendgp()); if !*gendecs then << symtabrem(name, nil); symtabrem(name, '!*decs!*) >>; return r end$ %% Generation of Declarations %% procedure cdecs decs; for each tl in formtypelists decs conc mkfcdec(car tl, cdr tl)$ %% Expression Translation %% procedure cexp exp; cexp1(exp, 0)$ procedure cexp1(exp, wtin); if atom exp then list cname exp else if onep length exp then append(cname exp, insertparens(())) else if car exp eq 'expt then 'power . insertparens append(cexp1(cadr exp, 0), '!, . cexp1(caddr exp, 0)) else if optype car exp then begin scalar wt, op, res; wt := cprecedence car exp; op := cop car exp; exp := cdr exp; if onep length exp then res := op . cexp1(car exp, wt) else << res := cexp1(car exp, wt); if op eq '!+ then while exp := cdr exp do << if atom car exp or caar exp neq 'minus then res := append(res, list op); res := append(res, cexp1(car exp, wt)) >> else while exp := cdr exp do res := append(append(res, list op), cexp1(car exp, wt)) >>; if wtin > wt then res := insertparens res; return res end else if car exp eq 'literal then cliteral exp else if arrayeltp exp then cname car exp . foreach s in cdr exp conc insertbrackets cexp1(s, 0) else begin scalar op, res; op := cname car exp; exp := cdr exp; res := cexp1(car exp, 0); while exp := cdr exp do res := append(append(res, list '!,), cexp1(car exp, 0)); return op . insertparens res end$ procedure cop op; get(op, '!*cop!*) or op$ put('or, '!*cop!*, '!|!|)$ put('and, '!*cop!*, '!&!&)$ put('not, '!*cop!*, '!! )$ put('equal, '!*cop!*, '!=!=)$ put('neq, '!*cop!*, '!!!=)$ put('greaterp, '!*cop!*, '> )$ put('geq, '!*cop!*, '!>!=)$ put('lessp, '!*cop!*, '< )$ put('leq, '!*cop!*, '!<!=)$ put('plus, '!*cop!*, '!+ )$ put('times, '!*cop!*, '* )$ put('quotient, '!*cop!*, '/ )$ put('minus, '!*cop!*, '!- )$ procedure cname a; if stringp a then stringtoatom a % convert a to atom containing "'s else get(a, '!*cname!*) or a$ put(t, '!*cname!*, 1)$ put(nil, '!*cname!*, 0)$ procedure cprecedence op; get(op, '!*cprecedence!*) or 8$ put('or, '!*cprecedence!*, 1)$ put('and, '!*cprecedence!*, 2)$ put('equal, '!*cprecedence!*, 3)$ put('neq, '!*cprecedence!*, 3)$ put('greaterp, '!*cprecedence!*, 4)$ put('geq, '!*cprecedence!*, 4)$ put('lessp, '!*cprecedence!*, 4)$ put('leq, '!*cprecedence!*, 4)$ put('plus, '!*cprecedence!*, 5)$ put('times, '!*cprecedence!*, 6)$ put('quotient, '!*cprecedence!*, 6)$ put('not, '!*cprecedence!*, 7)$ put('minus, '!*cprecedence!*, 7)$ %% Statement Translation %% procedure cstmt stmt; if null stmt then nil else if lisplabelp stmt then clabel stmt else if car stmt eq 'literal then cliteral stmt else if lispassignp stmt then cassign stmt else if lispcondp stmt then cif stmt else if lispbreakp stmt then cbreak stmt else if lispgop stmt then cgoto stmt else if lispreturnp stmt then creturn stmt else if lispstopp stmt then cexit stmt else if lisprepeatp stmt then crepeat stmt else if lispwhilep stmt then cwhile stmt else if lispforp stmt then cfor stmt else if lispstmtgpp stmt then cstmtgp stmt else if lispdefp stmt then cproc stmt else cexpstmt stmt$ procedure cassign stmt; mkfcassign(cadr stmt, caddr stmt)$ procedure cbreak stmt; mkfcbreak()$ procedure cexit stmt; mkfcexit()$ procedure cexpstmt exp; append(mkctab() . cexp exp, list('!;, mkcterpri()))$ procedure cfor stmt; begin scalar r, var, loexp, stepexp, hiexp, stmtlst; var := cadr stmt; stmt := cddr stmt; loexp := caar stmt; stepexp := cadar stmt; hiexp := caddar stmt; stmtlst := cddr stmt; r := mkfcfor(var, loexp, list('leq, var, hiexp), var, list('plus, var, stepexp)); indentclevel(+1); r := append(r, foreach st in stmtlst conc cstmt st); indentclevel(-1); return r end$ procedure cgoto stmt; mkfcgo cadr stmt$ procedure cif stmt; begin scalar r, st; r := mkfcif caadr stmt; indentclevel(+1); st := seqtogp cdadr stmt; if listp st and car st eq 'cond and length st=2 then st := mkstmtgp(0, list st); r := append(r, cstmt st); indentclevel(-1); stmt := cdr stmt; while (stmt := cdr stmt) and caar stmt neq t do << r := append(r, mkfcelseif caar stmt); indentclevel(+1); st := seqtogp cdar stmt; if listp st and car st eq 'cond and length st=2 then st := mkstmtgp(0, list st); r := append(r, cstmt st); indentclevel(-1) >>; if stmt then << r := append(r, mkfcelse()); indentclevel(+1); st := seqtogp cdar stmt; if listp st and car st eq 'cond and length st=2 then st := mkstmtgp(0, list st); r := append(r, cstmt st); indentclevel(-1) >>; return r end$ procedure clabel label; mkfclabel label$ procedure cliteral stmt; mkfcliteral cdr stmt$ procedure crepeat stmt; begin scalar r, stmtlst, logexp; stmt := reverse cdr stmt; logexp := car stmt; stmtlst := reverse cdr stmt; r := mkfcdo(); indentclevel(+1); r := append(r, foreach st in stmtlst conc cstmt st); indentclevel(-1); return append(r, mkfcdowhile list('not, logexp)) end$ procedure creturn stmt; if cdr stmt then mkfcreturn cadr stmt else mkfcreturn nil$ procedure cstmtgp stmtgp; begin scalar r; if car stmtgp eq 'progn then stmtgp := cdr stmtgp else stmtgp :=cddr stmtgp; r := mkfcbegingp(); indentclevel(+1); r := append(r, for each stmt in stmtgp conc cstmt stmt); indentclevel(-1); return append(r, mkfcendgp()) end$ procedure cwhile stmt; begin scalar r, logexp, stmtlst; logexp := cadr stmt; stmtlst := cddr stmt; r := mkfcwhile logexp; indentclevel(+1); r := append(r, foreach st in stmtlst conc cstmt st); indentclevel(-1); return r end$ %% %% %% C Code Formatting Functions %% %% %% %% Statement Formatting %% procedure mkfcassign(lhs, rhs); begin scalar st; if length rhs = 3 and lhs member rhs then begin scalar op, exp1, exp2; op := car rhs; exp1 := cadr rhs; exp2 := caddr rhs; if op = 'plus then if onep exp1 or onep exp2 then st := ('!+!+ . cexp lhs) else if exp1 member '(-1 (minus 1)) or exp2 member '(-1 (minus 1)) then st := ('!-!- . cexp lhs) else if listp exp1 and car exp1 = 'minus then st := append(cexp lhs, '!-!= . cexp cadr exp1) else if listp exp2 and car exp2 = 'minus then st := append(cexp lhs, '!-!= . cexp cadr exp2) else if exp1 = lhs then st := append(cexp lhs, '!+!= . cexp exp2) else st := append(cexp lhs, '!+!= . cexp exp1) else if op = 'difference and onep exp2 then st := ('!-!- . cexp lhs) else if op = 'difference and exp1 = lhs then st := append(cexp lhs, '!-!= . cexp exp2) else if op = 'times and exp1 = lhs then st := append(cexp lhs, '!*!= . cexp exp2) else if op = 'times then st := append(cexp lhs, '!*!= . cexp exp1) else if op = 'quotient and exp1 = lhs then st := append(cexp lhs, '!/!= . cexp exp2) else st := append(cexp lhs, '!= . cexp rhs) end else st := append(cexp lhs, '!= . cexp rhs); return append(mkctab() . st, list('!;, mkcterpri())) end$ procedure mkfcbegingp; list(mkctab(), '!{, mkcterpri())$ procedure mkfcbreak; list(mkctab(), 'break, '!;, mkcterpri())$ procedure mkfcdec(type, varlist); << varlist := for each v in varlist collect if atom v then v else car v . for each dim in cdr v collect add1 dim; append(mkctab() . type . '! . for each v in insertcommas varlist conc cexp v, list('!;, mkcterpri())) >>$ procedure mkfcdo; list(mkctab(), !*do!*, mkcterpri())$ procedure mkfcdowhile exp; append(append(list(mkctab(), 'while, '! , '!(), cexp exp), list('!), '!;, mkcterpri()))$ procedure mkfcelse; list(mkctab(), 'else, mkcterpri())$ procedure mkfcelseif exp; append(append(list(mkctab(), 'else, '! , 'if, '! , '!(), cexp exp), list('!), mkcterpri()))$ procedure mkfcendgp; list(mkctab(), '!}, mkcterpri())$ procedure mkfcexit; list(mkctab(), 'exit, '!(, 0, '!), '!;, mkcterpri())$ procedure mkfcfor(var1, lo, cond, var2, nextexp); << if var1 then var1 := append(cexp var1, '!= . cexp lo); if cond then cond := cexp cond; if var2 then << var2 := cdr mkfcassign(var2, nextexp); var2 := reverse cddr reverse var2 >>; append(append(append(list(mkctab(), !*for!*, '! , '!(), var1), '!; . cond), append('!; . var2, list('!), mkcterpri()))) >>$ procedure mkfcgo label; list(mkctab(), 'goto, '! , label, '!;, mkcterpri())$ procedure mkfcif exp; append(append(list(mkctab(), 'if, '! , '!(), cexp exp), list('!), mkcterpri()))$ procedure mkfclabel label; list(label, '!:, mkcterpri())$ procedure mkfcliteral args; for each a in args conc if a eq 'tab!* then list mkctab() else if a eq 'cr!* then list mkcterpri() else if listp a then cexp a else list stripquotes a$ procedure mkfcprocdec(type, name, params); << params := append('!( . for each p in insertcommas params conc cexp p, list '!)); if type then append(mkctab() . type . '! . cexp name, append(params,list mkcterpri())) else append(mkctab() . cexp name, append(params, list mkcterpri())) >>$ procedure mkfcreturn exp; if exp then append(append(list(mkctab(), 'return, '!(), cexp exp), list('!), '!;, mkcterpri())) else list(mkctab(), 'return, '!;, mkcterpri())$ procedure mkfcwhile exp; append(append(list(mkctab(), 'while, '! , '!(), cexp exp), list('!), mkcterpri()))$ %% Indentation Control %% procedure mkctab; list('ctab, ccurrind!*)$ procedure indentclevel n; ccurrind!* := ccurrind!* + n * tablen!*$ procedure mkcterpri; list 'cterpri$ %% %% %% Misc. Functions %% %% %% procedure insertbrackets exp; '![ . append(exp, list '!])$ endmodule; module goutput; % GENTRAN Code Formatting & Printing and Error Handler %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Points: FormatC, FormatFort, FormatRat, GentranErr symbolic$ % User-Accessible Global Variable % global '(clinelen!* fortlinelen!* minclinelen!* minfortlinelen!* minratlinelen!* ratlinelen!*)$ share 'clinelen!*, 'fortlinelen!*, 'minclinelen!*, 'minfortlinelen!*, 'minratlinelen!*, 'ratlinelen!*$ clinelen!* := 80$ fortlinelen!* := 72$ minclinelen!* := 40$ minfortlinelen!* := 40$ minratlinelen!* := 40$ ratlinelen!* := 80$ % GENTRAN Global Variables % global '(!*ccurrind!* !*errchan!* !*fortcurrind!* !*outchanl!* !*posn!* !*ratcurrind!* !*stdin!* !*stdout!* !$eol!$)$ !*ccurrind!* := 0$ %current level of indentation for C code !*errchan!* := nil$ %error channel number !*fortcurrind!* := 6$ %current level of indentation for FORTRAN code !*posn!* := 0$ %current position on output line !*ratcurrind!* := 0$ %current level of indentation for RATFOR code %% %% %% Code Formatting & Printing Functions %% %% %% %% FORTRAN Code Formatting & Printing Functions %% procedure formatfort lst; begin scalar linelen; linelen := linelength 300; !*posn!* := 0; for each elt in lst do if listp elt then eval elt else << if !*posn!* + length explode2 elt > fortlinelen!* then fortcontline(); pprin2 elt >>; linelength linelen end$ procedure fortcontline; << fortterpri(); pprin2 " ."; forttab !*fortcurrind!*; pprin2 " " >>$ procedure fortterpri; pterpri()$ procedure forttab n; << !*fortcurrind!* := max(min0(n, fortlinelen!* - minfortlinelen!*),6); if (n := !*fortcurrind!* - !*posn!*) > 0 then pprin2 nspaces n >>$ %% RATFOR Code Formatting & Printing Functions %% procedure formatrat lst; begin scalar linelen; linelen := linelength 300; !*posn!* := 0; for each elt in lst do if listp elt then eval elt else << if !*posn!* + length explode2 elt > ratlinelen!* then ratcontline(); pprin2 elt >>; linelength linelen end$ procedure ratcontline; << ratterpri(); rattab !*ratcurrind!*; pprin2 " " >>$ procedure ratterpri; pterpri()$ procedure rattab n; << !*ratcurrind!* := min0(n, ratlinelen!* - minratlinelen!*); if (n := !*ratcurrind!* - !*posn!*) > 0 then pprin2 nspaces n >>$ %% C Code Formatting & Printing Functions %% procedure formatc lst; begin scalar linelen; linelen := linelength 300; !*posn!* := 0; for each elt in lst do if listp elt then eval elt else << if !*posn!* + length explode2 elt > clinelen!* then ccontline(); pprin2 elt >>; linelength linelen end$ procedure ccontline; << cterpri(); ctab !*ccurrind!*; pprin2 " " >>$ procedure cterpri; pterpri()$ procedure ctab n; << !*ccurrind!* := min0(n, clinelen!* - minclinelen!*); if (n := !*ccurrind!* - !*posn!*) > 0 then pprin2 nspaces n >>$ %% %% %% General Printing Functions %% %% %% procedure pprin2 arg; begin scalar ch; ch := wrs nil; for each c in !*outchanl!* do << wrs c; prin2 arg >>; !*posn!* := !*posn!* + length explode2 arg; wrs ch end$ procedure pterpri; begin scalar ch; ch := wrs nil; for each c in !*outchanl!* do << wrs c; terpri() >>; !*posn!* := 0; wrs ch end$ %% %% %% Error Handler %% %% %% %% Error & Warning Message Printing Routine %% procedure gentranerr(msgtype, exp, msg1, msg2); begin scalar holdich, holdoch, resp, emsg; holdich := rds !*errchan!*; holdoch := wrs !*errchan!*; terpri(); if exp then prettyprint exp; if msgtype eq 'e then << rds cdr !*stdin!*; wrs cdr !*stdout!*; rederr msg1 >>; prin2 "*** "; prin2t msg1; if msg2 then resp := yesp msg2; wrs holdoch; rds holdich; if not resp then error1() end$ %% %% %% Misc. Functions %% %% %% procedure min0(n1, n2); max(min(n1, n2), 0)$ procedure nspaces n; % Note n is assumed > 0 here. begin scalar s; for i := 1:n do s := ('!! . '! . s); return intern compress s end$ endmodule; end; |
Added r33/groebner.red version [e3cb8b7cfc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module consel; %/*Constructors and selectors for a distributed polynomial form*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ %/*A distributive polynomial has the following informal syntax: % % <dipoly> ::= dipzero % | <exponent vector> . <base coefficient> . <dipoly>*/ %define dipzero = 'nil; fluid '(dipzero); %/*Until we understand how to define something to nil*/ smacro procedure dipzero!? u; null u; smacro procedure diplbc p; % /* Distributive polynomial leading base coefficient. % p is a distributive polynomial. diplbc(p) returns % the leading base coefficient of p. */ cadr p; smacro procedure dipmoncomp (a,e,p); % /* Distributive polynomial monomial composition. a is a base % coefficient, e is an exponent vector and p is a % distributive polynomial. dipmoncomp(a,e,p) returns a dis- % tributive polynomial with p as monomial reductum, e as % exponent vector of the leading monomial and a as leading % base coefficient. */ e . a . p; smacro procedure dipevlmon p; % /* Distributive polynomial exponent vector leading monomial. % p is a distributive polynomial. dipevlmon(p) returns the % exponent vector of the leading monomial of p. */ car p; smacro procedure dipfmon (a,e); % /* Distributive polynomial from monomial. a is a base coefficient % and e is an exponent vector. dipfmon(a,e) returns a % distributive polynomial with e as exponent vector and % a as base coefficient. */ e . a . dipzero; smacro procedure dipnov p; % /* Distributive polynomial number of variables. p is a distributive % polynomial. dipnov(p) returns a digit, the number of variables % of the distributive polynomial p. */ length car p; smacro procedure dipmred p; % /* Distributive polynomial reductum. p is a distributive polynomial % dipmred(p) returns the reductum of the distributive polynomial p, % a distributive polynomial. */ cddr p; endmodule; module bcoeff; % Computation of base coefficients. %/*Definitions of base coefficient operations for distributive % polynomial package. We assume that only field elements are used, but % no check is made for this. In this module, a standard quotient % coefficient is assumed*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ global '(!*nat); expr procedure bcless!? (a1,a2); % /* Base coefficient less. a1 and a2 are base coefficients. % bcless!?(a1,a2) returns a boolean expression, true if % a1 is less than a2 else false. */ minusf numr addsq(a1,negsq a2); smacro procedure bcminus!? u; % /* Boolean function. Returns true if u is a negative base coeff*/ minusf numr u; smacro procedure bczero!? u; % /* Returns a boolean expression, true if the base coefficient u is % zero*/ null numr u; expr procedure bccomp (a1,a2); % /* Base coefficient compare a1 and a2 are base coefficients. % bccomp(a1,a2) compares the base coefficients a1 and a2 and returns % a digit 1 if a1 greater than a2, a digit 0 if a1 equals a2 else a % digit -1. */ (if bczero!? sl then 0 else if bcminus!? sl then -1 else 1) where sl = bcdif(a1, a2); expr procedure bcfi a; % /* Base coefficient from integer. a is an integer. bcfi(a) returns % the base coefficient a. */ mkbc(a,1); expr procedure bclcmd(u,v); % Base coefficient least common multiple of denominators. % u and v are two base coefficients. bclcmd(u,v) calculates the % least common multiple of the denominator of u and the % denominator of v and returns a base coefficient of the form % 1/lcm(denom u,denom v). if bczero!? u then mkbc(1,denr v) else if bczero!? v then mkbc(1,denr u) else mkbc(1,multf(quotf(denr u,gcdf(denr u,denr v)),denr v)); expr procedure bclcmdprod(u,v); % Base coefficient least common multiple denominator product. % u is a basecoefficient of the form 1/integer. v is a base % coefficient. bclcmdprod(u,v) calculates (denom u/denom v)*nom v/1 % and returns a base coefficient. mkbc(multf(quotf(denr u,denr v),numr v),1); expr procedure bcquod(u,v); % Base coefficient quotient. u and v are base coefficients. % bcquod(u,v) calculates u/v and returns a base coefficient. bcprod(u,bcinv v); expr procedure bcone!? u; % /* Base coefficient one. u is a base coefficient. % bcone!?(u) returns a boolean expression, true if the % base coefficient u is equal 1. */ denr u = 1 and numr u = 1; expr procedure bcinv u; % /* Base coefficient inverse. u is a base coefficient. % bcinv(u) calculates 1/u and returns a base coefficient. */ invsq u; expr procedure bcneg u; % /* Base coefficient negative. u is a base coefficient. % bcneg(u) returns the negative of the base coefficient % u, a base coefficient. */ negsq u; expr procedure bcprod (u,v); % /* Base coefficient product. u and v are base coefficients. % bcprod(u,v) calculates u*v and returns a base coefficient. multsq(u,v); expr procedure mkbc(u,v); % /* Convert u and v into u/v in lowest terms*/ if v = 1 then u ./ v else if v<0 then mkbc(negf u,negf v) else quotf(u,m) ./ quotf(v,m) where m = gcdf(u,v); expr procedure bcquot (u,v); % /* Base coefficient quotient. u and v are base coefficients. % bcquot(u,v) calculates u/v and returns a base coefficient. */ quotsq(u,v); expr procedure bcsum (u,v); % /* Base coefficient sum. u and v are base coefficients. % bcsum(u,v) calculates u+v and returns a base coefficient. */ addsq(u,v); expr procedure bcdif(u,v); % /* Base coefficient difference. u and v are base coefficients. % bcdif(u,v) calculates u-v and returns a base coefficient. */ bcsum(u,bcneg v); expr procedure bcpow(u,n); % /*Returns the base coefficient u raised to the nth power, where % n is an integer*/ exptsq(u,n); expr procedure a2bc u; % /*Converts the algebraic (kernel) u into a base coefficient. simp!* u; expr procedure bc2a u; % /* Returns the prefix equivalent of the base coefficient u*/ prepsq u; expr procedure bcprin u; % /* Prints a base coefficient in infix form*/ begin scalar nat; nat := !*nat; !*nat := nil; sqprint u; !*nat := nat end; endmodule; module expvec; % /*Specific support for distributive polynomial exponent vectors*/ % /* Authors: R. Gebauer, A. C. Hearn, H. Kredel */ % We assume here that an exponent vector is a list of integers. This % version uses small integer arithmetic on the individual exponents % and assumes that a compiled function can be dynamically redefined*/ fluid '(dipsortmode!* dipvars!*); expr procedure evperm (e1,n); % /* Exponent vector permutation. e1 is an exponent vector, n is a % index list , a list of digits. evperm(e1,n) returns a list e1 % permuted in respect to n. */ if null n then nil else evnth(e1, car n) . evperm(e1, cdr n); expr procedure evcons (e1,e2); % /* Exponent vector construct. e1 and e2 are exponents. evcons(e1,e2) % constructs an exponent vector. */ e1 . e2; expr procedure evnth (e1,n); % /* Exponent vector n-th element. e1 is an exponent vector, n is a % digit. evnth(e1,n) returns the n-th element of e1, an exponent. */ if n = 1 then evfirst e1 else evnth(evred e1, n - 1); expr procedure evred e1; % /* Exponent vector reductum. e1 is an exponent vector. evred(e1) % returns the reductum of the exponent vector e1. */ cdr e1; expr procedure evfirst e1; % /* Exponent vector first. e1 is an exponent vector. evfirst(e1) % returns the first element of the exponent vector e1, an exponent. */ car e1; expr procedure evsum0(n,p); % exponent vector sum version 0. n is the length of dipvars!*. % p is a distributive polynomial. if dipzero!? p then evzero1 n else evsum(dipevlmon p, evsum0(n,dipmred p)); expr procedure evzero1 n; % Returns the exponent vector power representation % of length n for a zero power. begin scalar x; for i:=1: n do << x := 0 . x >>; return x end; expr procedure indexcpl(ev,n); % returns a list of indixes of non zero exponents. if null ev then ev else ( if car ev = 0 then indexcpl(cdr ev,n + 1) else ( n . indexcpl(cdr ev,n + 1)) ); expr procedure evzer1!? e; % returns a boolean expression. true if e is null else false. null e; expr procedure evzero!? e; % /* Returns a boolean expression. True if all exponents are zero*/ null e or car e = 0 and evzero!? cdr e; expr procedure evzero; % /* Returns the exponent vector representation for a zero power*/ % for i := 1:length dipvars!* collect 0; begin scalar x; for i := 1:length dipvars!* do <<x := 0 . x>>; return x end; expr procedure mkexpvec u; % /* Returns an exponent vector with a 1 in the u place*/ if not(u member dipvars!*) then typerr(u,"dipoly variable") else for each x in dipvars!* collect if x eq u then 1 else 0; expr procedure evcompless!?(e1,e2); % /* Exponent vector compare less. e1, e2 are exponent vectors % in some order. Evcompless? is a boolean function which returns % true if e1 is ordered less than e2. This function is assigned a % value by the ordering mechanism, so is dummy for now*/ apply(get(dipsortmode!*,'evcompless!?),list(e1,e2)); expr procedure evlexcompless!?(e1,e2); % /* Exponent vector lexicographical compare less. e1, e2 are exponent % vectors in lexicographical order. Evlexcompless?(e1,e2) is a % boolean function which returns true if e1 is ordered less than e2*/ if null e1 then nil else if car e1 = car e2 then evlexcompless!?(cdr e1,cdr e2) else car e1 #> car e2; expr procedure evcomp (e1,e2); % /* Exponent vector compare. e1, e2 are exponent vectors in some % order. Evcomp(e1,e2) returns the digit 0 if exponent vector e1 is % equal exponent vector e2, the digit 1 if e1 is greater than e2, % else the digit -1. This function is assigned a value by the % ordering mechanism, so is dummy for now*/ apply(get(dipsortmode!*,'evcomp),list(e1,e2)); expr procedure evilcompless!?(e1,e2); % /* Exponent vector inverse lexicographical compare less. e1, e2 are % exponent vectors in lexicographical order. Evilcompless?(e1,e2) is % a boolean function which returns true if e1 is ordered less than e2*/ if null e1 then nil else if car e1 = car e2 then evilcompless!?(cdr e1,cdr e2) else car e1 #< car e2; expr procedure evlexcomp(e1,e2); % /* Exponent vector lexicographical compare. e1, e2 are exponent % vectors in lexicographical order. Evlexcomp(e1,e2) returns the % digit 0 if exponent vector e1 is equal exponent vector e2, 1 if e1 % is greater than e2, else the digit -1. */ if null e1 then 0 else if car e1 = car e2 then evlexcomp(cdr e1,cdr e2) else if car e1 #< car e2 then 1 else -1; expr procedure evilcomp (e1,e2); % /* Exponent vector inverse lexicographical compare. The % exponent vectors e1 and e2 are in inverse lexicographical % ordering. evilcomp(e1,e2) returns the digit 0 if exponent % vector e1 is equal exponent vector e2, the digit 1 if e1 is % greater than e2, else the digit -1. */ if null e1 then 0 else if car e1 = car e2 then evilcomp(cdr e1,cdr e2) else if car e1 #> car e2 then 1 else -1; expr procedure evitdcompless!?(e1,e2); % /* Exponent vector inverse total degree compare less. % The exponent vectors e1 and e2 are in inverse total degree % ordering. evitdcompless!?(e1,e2) is a boolean function that % returns true if exponent vector e1 is ordered less than e2*/ if null e1 then nil else if car e1 = car e2 then evitdcompless!?(cdr e1, cdr e2) else (if te1 = te2 then car e1 #< car e2 else te1 #< te2) where te1 = evtdeg e1, te2 = evtdeg e2; expr procedure evtdcompless!?(e1,e2); % /*Exponent vector total degree compare less.*/ if null e1 then nil else if car e1 = car e2 then evtdcompless!?(cdr e1,cdr e2) else (if te1 = te2 then car e1 #> car e2 else te1 #< te2) where te1 = evtdeg e1, te2 = evtdeg e2; expr procedure evitdcomp (e1,e2); % /* Exponent vector inverse total degree compare. % The exponent vectors e1 and e2 are in inverse total degree % ordering. evitdcomp(e1,e2) returns the digit 0 if exponent % vector e1 is equal exponent vector e2, the digit 1 if e1 is % greater than e2, else the digit -1. */ if null e1 then 0 else if car e1 = car e2 then evitdcomp(cdr e1, cdr e2) else (if te1 = te2 then if car e1 #> car e2 then 1 else -1 else if te1 #> te2 then 1 else -1) where te1 = evtdeg e1, te2 = evtdeg e2; expr procedure evtdcomp (e1,e2); % /* ... */ if null e1 then 0 else if car e1 = car e2 then evtdcomp(cdr e1,cdr e2) else (if te1 = te2 then if car e1 #< car e2 then 1 else -1 else if te1 #> te2 then 1 else -1) where te1 = evtdeg e1, te2 = evtdeg e2; expr procedure evtdeg e1; % /* Exponent vector total degree. e1 is an exponent vector. % evtdeg(e1) calculates the total degree of the exponent % e1 and returns an integer. */ (<<while e1 do <<x := car e1 #+ x; e1 := cdr e1>>; x>>) where x = 0; expr procedure evlcm (e1,e2); % /* Exponent vector least common multiple. e1 and e2 are % exponent vectors. evlcm(e1,e2) computes the least common % multiple of the exponent vectors e1 and e2, and returns % an exponent vector. */ % for each lpart in e1 each rpart in e2 collect % if lpart #> rpart then lpart else rpart; begin scalar x; while e1 do <<x := (if car e1 #> car e2 then car e1 else car e2) . x; e1 := cdr e1; e2 := cdr e2>>; return reversip x end; expr procedure evmtest!? (e1,e2); % /* Exponent vector multiple test. e1 and e2 are compatible exponent % vectors. evmtest!?(e1,e2) returns a boolean expression. % True if exponent vector e1 is a multiple of exponent % vector e2, else false. */ null e1 or not(car e1 #< car e2) and evmtest!?(cdr e1,cdr e2); expr procedure evsum (e1,e2); % /* Exponent vector sum. e1 and e2 are exponent vectors. % evsum(e1,e2) calculates the sum of the exponent vectors. % e1 and e2 componentwise and returns an exponent vector. */ % for each lpart in e1 each rpart in e2 collect lpart #+ rpart; begin scalar x; while e1 do <<x := (car e1 #+ car e2) . x; e1 := cdr e1; e2 := cdr e2>>; return reversip x end; expr procedure evdif (e1,e2); % /* Exponent vector difference. e1 and e2 are exponent % vectors. evdif(e1,e2) calculates the difference of the % exponent vectors e1 and e2 componentwise and returns an % exponent vector. */ % for each lpart in e1 each rpart in e2 collect lpart #- rpart; begin scalar x; while e1 do <<x := (car e1 #- car e2) . x; e1 := cdr e1; e2 := cdr e2>>; return reversip x end; expr procedure intevprod(n,e); % /* Multiplies each element of the exponent vector u by the integer n*/ for each x in e collect n #* x; expr procedure expvec2a e; % /* Returns list of prefix equivalents of exponent vector e*/ expvec2a1(e,dipvars!*); expr procedure expvec2a1(u,v); % /* Sub function of expvec2a */ if null u then nil else if car u = 0 then expvec2a1(cdr u,cdr v) else if car u = 1 then car v . expvec2a1(cdr u,cdr v) else list('expt,car v,car u) . expvec2a1(cdr u,cdr v); expr procedure dipevlpri(e,v); % /* Print exponent vector e in infix form. V is a boolean variable % which is true if an element in a product has preceded this one*/ dipevlpri1(e,dipvars!*,v); expr procedure dipevlpri1(e,u,v); % /* Sub function of dipevlpri */ if null e then nil else if car e = 0 then dipevlpri1(cdr e,cdr u,v) else <<if v then dipprin2 "*"; dipprin2 car u; if car e #> 1 then <<dipprin2 "**"; dipprin2 car e>>; dipevlpri1(cdr e,cdr u,t)>>; remprop('torder,'stat); expr procedure torder u; % algebraic mode interface to dipsortingmode. dipsortingmode car u; put('torder,'stat,'rlis); expr procedure dipsortingmode u; % /* Sets the exponent vector sorting mode. Returns the previous mode*/ if not idp u or not flagp(u,'dipsortmode) then typerr(u,"term ordering mode") else begin scalar x; x := dipsortmode!*; dipsortmode!* := u; return x end; flag('(lex invlex totaldegree invtotaldegree),'dipsortmode); put('lex,'evcompless!?,'evlexcompless!?); put('lex,'evcomp,'evlexcomp); put('invlex,'evcompless!?,'evilcompless!?); put('invlex,'evcomp,'evilcomp); put('invtotaldegree,'evcompless!?,'evitdcompless!?); put('invtotaldegree,'evcomp,'evitdcomp); put('totaldegree,'evcompless!?,'evtdcompless!?); put('totaldegree,'evcomp,'evtdcomp); dipsortingmode 'invlex; % /*Default value*/ endmodule; module dipoly; % /*Distributive polnomial algorithms*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ fluid '(dipvars!* dipzero); fexpr procedure polyin p; a2dip car p; expr procedure dipconst!? p; not dipzero!? p and dipzero!? dipmred p and evzero!? dipevlmon p; expr procedure dfcprint pl; % h polynomial factor list of distributive polynomials print. for each p in pl do dfcprintin p; expr procedure dfcprintin p; % factor with exponent print. ( if cdr p neq 1 then << prin2 " ( "; dipprint1(p1,nil); prin2 " )** "; prin2 cdr p; terprit 2 >> else << prin2 " "; dipprint p1>> ) where p1:= dipmonic a2dip prepf car p; expr procedure dfcprin p; % print content, factors and exponents of factorized polynomial p. << terpri(); prin2 " content of factorized polynomials = "; prin2 car p; terprit 2; dfcprint cdr p >>; expr procedure diplcm p; % Distributive polynomial least common multiple of denomiators. % p is a distributive rational polynomial. diplcm(p) calculates % the least common multiple of the denominators and returns a % base coefficient of the form 1/lcm(denom bc1,.....,denom bci). if dipzero!? p then mkbc(1,1) else bclcmd(diplbc p, diplcm dipmred p); expr procedure diprectoint(p,u); % Distributive polynomial conversion rational to integral. % p is a distributive rational polynomial, u is a base coefficient % ( 1/lcm denom p ). diprectoint(p,u) returns a primitive % associate pseudo integral ( denominators are 1 ) distributive % polynomial. if bczero!? u then dipzero else if bcone!? u then p else diprectoint1(p,u); expr procedure diprectoint1(p,u); % Distributive polynomial conversion rational to integral internall 1. % diprectoint1 is used in diprectoint. if dipzero!? p then dipzero else dipmoncomp(bclcmdprod(u,diplbc p),dipevlmon p, diprectoint1(dipmred p,u)); expr procedure dipresul(p1,p2); % test for fast downwards calculation % p1 and p2 are two bivariate distributive polynomials. % dipresul(p1,p2) returns the resultant of p1 and p2 with respect % respect to the first variable of the variable list (car dipvars!*). begin scalar q1,q2,q,ct; q1:=dip2a diprectoint(p1,diplcm p1); q2:=dip2a diprectoint(p2,diplcm p2); ct := time(); q:= a2dip prepsq simpresultant list(q1,q2,car dipvars!*); ct := time() - ct; prin2 " resultant : "; dipprint dipmonic q; terpri(); prin2 " time resultant : "; prin2 ct; terpri(); end; expr procedure dipbcprod (p,a); % /* Distributive polynomial base coefficient product. % p is a distributive polynomial, a is a base coefficient. % dipbcprod(p,a) computes p*a, a distributive polynomial. */ if bczero!? a then dipzero else if bcone!? a then p else dipbcprodin(p,a); expr procedure dipbcprodin (p,a); % /* Distributive polynomial base coefficient product internal. % p is a distributive polynomial, a is a base coefficient, % where a is not equal 0 and not equal 1. % dipbcprodin(p,a) computes p*a, a distributive polynomial. */ if dipzero!? p then dipzero else dipmoncomp(bcprod(a, diplbc p), dipevlmon p, dipbcprodin(dipmred p, a)); expr procedure dipdif (p1,p2); % /* Distributive polynomial difference. p1 and p2 are distributive % polynomials. dipdif(p1,p2) calculates the difference of the % two distributive polynomials p1 and p2, a distributive polynomial*/ if dipzero!? p1 then dipneg p2 else if dipzero!? p2 then p1 else ( if sl = 1 then dipmoncomp(diplbc p1, ep1, dipdif(dipmred p1, p2) ) else if sl = -1 then dipmoncomp(bcneg diplbc p2, ep2, dipdif(p1,dipmred p2)) else ( if bczero!? al then dipdif(dipmred p1, dipmred p2) else dipmoncomp(al, ep1, dipdif(dipmred p1, dipmred p2) ) ) where al = bcdif(diplbc p1, diplbc p2) ) where sl = evcomp(ep1, ep2) where ep1 = dipevlmon p1, ep2 = dipevlmon p2; expr procedure diplength p; % /* Distributive polynomial length. p is a distributive % polynomial. diplength(p) returns the number of terms % of the distributive polynomial p, a digit.*/ if dipzero!? p then 0 else 1 + diplength dipmred p; expr procedure diplistsum pl; % /* Distributive polynomial list sum. pl is a list of distributive % polynomials. diplistsum(pl) calculates the sum of all polynomials % and returns a list of one distributive polynomial. */ if null pl or null cdr pl then pl else diplistsum(dipsum(car pl, cadr pl) . diplistsum cddr pl); expr procedure diplmerge (pl1,pl2); % /* Distributive polynomial list merge. pl1 and pl2 are lists % of distributive polynomials where pl1 and pl2 are in non % decreasing order. diplmerge(pl1,pl2) returns the merged % distributive polynomial list of pl1 and pl2. */ if null pl1 then pl2 else if null pl2 then pl1 else ( if sl >= 0 then cpl1 . diplmerge(cdr pl1, pl2) else cpl2 . diplmerge(cdr pl2, pl1) ) where sl = evcomp(ep1, ep2) where ep1 = dipevlmon cpl1, ep2 = dipevlmon cpl2 where cpl1 = car pl1, cpl2 = car pl2; expr procedure diplsort pl; % /* Distributive polynomial list sort. pl is a list of % distributive polynomials. diplsort(pl) returns the % sorted distributive polynomial list of pl. sort(pl, function dipevlcomp); expr procedure dipevlcomp (p1,p2); % /* Distributive polynomial exponent vector leading monomial % compare. p1 and p2 are distributive polynomials. % dipevlcomp(p1,p2) returns a boolean expression true if the % distributive polynomial p1 is smaller or equal the distributive % polynomial p2 else false. */ not evcompless!?(dipevlmon p1, dipevlmon p2); expr procedure dipmonic p; % /* Distributive polynomial monic. p is a distributive % polynomial. dipmonic(p) computes p/lbc(p) if p is % not equal dipzero and returns a distributive % polynomial, else dipmonic(p) returns dipzero. */ if dipzero!? p then p else dipbcprod(p, bcinv diplbc p); expr procedure dipneg p; % /* Distributive polynomial negative. p is a distributive % polynomial. dipneg(p) returns the negative of the distributive % polynomial p, a distributive polynomial. */ if dipzero!? p then p else dipmoncomp ( bcneg diplbc p, dipevlmon p, dipneg dipmred p ); expr procedure dipone!? p; % /* Distributive polynomial one. p is a distributive polynomial. % dipone!?(p) returns a boolean value. If p is the distributive % polynomial one then true else false. */ not dipzero!? p and dipzero!? dipmred p and evzero!? dipevlmon p and bcone!? diplbc p; expr procedure dippairsort pl; % /* Distributive polynomial list pair merge sort. pl is a list % of distributive polynomials. dippairsort(pl) returns the % list of merged and in non decreasing order sorted % distributive polynomials. */ if null pl or null cdr pl then pl else diplmerge(diplmerge( car(pl) . nil, cadr(pl) . nil ), dippairsort cddr pl); expr procedure dipprod (p1,p2); % /* Distributive polynomial product. p1 and p2 are distributive % polynomials. dipprod(p1,p2) calculates the product of the % two distributive polynomials p1 and p2, a distributive polynomial*/ if diplength p1 <= diplength p2 then dipprodin(p1, p2) else dipprodin(p2, p1); expr procedure dipprodin (p1,p2); % /* Distributive polynomial product internal. p1 and p2 are distrib % polynomials. dipprod(p1,p2) calculates the product of the % two distributive polynomials p1 and p2, a distributive polynomial*/ if dipzero!? p1 or dipzero!? p2 then dipzero else ( dipmoncomp(bcprod(bp1, diplbc p2), evsum(ep1, dipevlmon p2), dipsum(dipprodin(dipfmon(bp1, ep1), dipmred p2), dipprodin(dipmred p1, p2) ) ) ) where bp1 = diplbc p1, ep1 = dipevlmon p1; expr procedure dipprodls (p1,p2); % /* Distributive polynomial product. p1 and p2 are distributive % polynomials. dipprod(p1,p2) calculates the product of the % two distributive polynomials p1 and p2, a distributive polynomial % using distributive polynomials list sum (diplistsum). */ if dipzero!? p1 or dipzero!? p2 then dipzero else car diplistsum if diplength p1 <= diplength p2 then dipprodlsin(p1, p2) else dipprodlsin(p2, p1); expr procedure dipprodlsin (p1,p2); % /* Distributive polynomial product. p1 and p2 are distributive % polynomials. dipprod(p1,p2) calculates the product of the % two distributive polynomials p1 and p2, a distributive polynomial % using distributive polynomials list sum (diplistsum). */ if dipzero!? p1 or dipzero!? p2 then nil else ( dipmoncomp(bcprod(bp1, diplbc p2), evsum(ep1, dipevlmon p2), car dipprodlsin(dipfmon(bp1, ep1), dipmred p2)) . dipprodlsin(dipmred p1, p2) ) where bp1 = diplbc p1, ep1 = dipevlmon p1; expr procedure dipsum (p1,p2); % /* Distributive polynomial sum. p1 and p2 are distributive % polynomials. dipsum(p1,p2) calculates the sum of the % two distributive polynomials p1 and p2, a distributive polynomial*/ if dipzero!? p1 then p2 else if dipzero!? p2 then p1 else ( if sl = 1 then dipmoncomp(diplbc p1, ep1, dipsum(dipmred p1, p2) ) else if sl = -1 then dipmoncomp(diplbc p2, ep2, dipsum(p1,dipmred p2)) else ( if bczero!? al then dipsum(dipmred p1, dipmred p2) else dipmoncomp(al, ep1, dipsum(dipmred p1, dipmred p2) ) ) where al = bcsum(diplbc p1, diplbc p2) ) where sl = evcomp(ep1, ep2) where ep1 = dipevlmon p1, ep2 = dipevlmon p2; endmodule; module dipvars; %/* Determine distributive polynomial variables in a prefix form*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ expr procedure dipvars u; % /* Returns list of variables in prefix form u*/ dipvars1(u,nil); expr procedure dipvars1(u,v); if atom u then if constantp u or u memq v then v else u . v else if idp car u and get(car u,'dipfn) then dipvarslist(cdr u,v) else if u memq v then v else u . v; expr procedure dipvarslist(u,v); if null u then v else dipvarslist(cdr u,union(dipvars car u,v)); endmodule; module a2dip; %/*Convert an algebraic (prefix) form to distributive polynomial*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ fluid '(dipvars!* dipzero); expr procedure a2dip u; % /*Converts the algebraic (prefix) form u to a distributive poly. % We assume that all variables used have been previously % defined in dipvars!*, but a check is also made for this*/ if atom u then a2dipatom u else if not atom car u or not idp car u then typerr(car u,"dipoly operator") else (if x then apply(x,list for each y in cdr u collect a2dip y) else a2dipatom u) where x = get(car u,'dipfn); expr procedure a2dipatom u; % /*Converts the atom (or kernel) u into a distributive polynomial*/ if u=0 then dipzero else if numberp u or not(u member dipvars!*) then dipfmon(a2bc u,evzero()) else dipfmon(a2bc 1,mkexpvec u); expr procedure dipfnsum u; % /*U is a list of dip expressions. Result is the distributive poly % representation for the sum*/ (<<for each y in cdr u do x := dipsum(x,y); x>>) where x = car u; put('plus,'dipfn,'dipfnsum); put('plus2,'dipfn,'dipfnsum); expr procedure dipfnprod u; % /*U is a list of dip expressions. Result is the distributive poly % representation for the product*/ % /*Maybe we should check for a zero*/ (<<for each y in cdr u do x := dipprod(x,y); x>>) where x = car u; put('times,'dipfn,'dipfnprod); put('times2,'dipfn,'dipfnprod); expr procedure dipfndif u; % /*U is a list of two dip expressions. Result is the distributive % polynomial representation for the difference*/ dipsum(car u,dipneg cadr u); put('difference,'dipfn,'dipfndif); expr procedure dipfnpow u; % /*U is a pair of dip expressions. Result is the distributive poly % representation for the first raised to the second power*/ (if not fixp n or n<0 then typerr(n,"distributive polynomial exponent") else if n=0 then if dipzero!? v then rederr "0**0 invalid" else w else if dipzero!? v or n=1 then v else if dipzero!? dipmred v then dipfmon(bcpow(diplbc v,n),intevprod(n,dipevlmon v)) else <<while n>0 do <<if not evenp n then w := dipprod(w,v); n := n/2; if n>0 then v := dipprod(v,v)>>; w>>) where n := dip2a cadr u, v := car u, w := dipfmon(a2bc 1,evzero()); put('expt,'dipfn,'dipfnpow); expr procedure dipfnneg u; % /*U is a list of one dip expression. Result is the distributive % polynomial representation for the negative*/ (if dipzero!? v then v else dipmoncomp(bcneg diplbc v,dipevlmon v,dipmred v)) where v = car u; put('minus,'dipfn,'dipfnneg); expr procedure dipfnquot u; % /*U is a list of two dip expressions. Result is the distributive % polynomial representation for the quotient*/ if dipzero!? cadr u or not dipzero!? dipmred cadr u or not evzero!? dipevlmon cadr u then typerr(dip2a cadr u,"distributive polynomial denominator") else dipfnquot1(car u,diplbc cadr u); expr procedure dipfnquot1(u,v); if dipzero!? u then u else dipmoncomp(bcquot(diplbc u,v), dipevlmon u, dipfnquot1(dipmred u,v)); put('quotient,'dipfn,'dipfnquot); endmodule; module dip2a; %/* Functions for converting distributive forms into prefix forms*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ expr procedure dip2a u; % /* Returns prefix equivalent of distributive polynomial u*/ if dipzero!? u then 0 else dipreplus dip2a1 u; expr procedure dip2a1 u; if dipzero!? u then nil else ((if bcminus!? x then list('minus,dipretimes(bc2a bcneg x . y)) else dipretimes(bc2a x . y)) where x = diplbc u, y = expvec2a dipevlmon u) . dip2a1 dipmred u; expr procedure dipreplus u; if atom u then u else if null cdr u then car u else 'plus . u; expr procedure dipretimes u; % /* U is a list of prefix expressions the first of which is a number. % Result is prefix representation for their product*/ if car u = 1 then if cdr u then dipretimes cdr u else 1 else if null cdr u then car u else 'times . u; endmodule; module dipprint; %/* printing routines for distributive polynomials*/ %/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/ fluid '(dipvars!*); expr procedure diplprint u; % /* Prints a list of distributive polynomials using dipprint*/ for each v in u do dipprint v; expr procedure dipprint u; % /* Prints a distributive polynomial in infix form*/ <<terpri(); dipprint1(u,nil); terpri(); terpri()>>; expr procedure dipprint1(u,v); % /* Prints a distributive polynomial in infix form. % U is a distributive form. V is a flag which is true if a term % has preceded current form*/ if dipzero!? u then if null v then dipprin2 0 else nil else begin scalar bool,w; w := diplbc u; if bcminus!? w then <<bool := t; w := bcneg w>>; if bool then dipprin2 " - " else if v then dipprin2 " + "; (if not bcone!? w or evzero!? x then <<bcprin w; dipevlpri(x,t)>> else dipevlpri(x,nil)) where x = dipevlmon u; dipprint1(dipmred u,t) end; expr procedure dipprin2 u; % /* Prints u, preceding by two EOL's if we have reached column 70*/ <<if posn()>69 then <<terpri(); terpri()>>; prin2 u>>; endmodule; module grinterf; % Interface of Groebner package to REDUCE. % /*Authors: R. Gebauer, A. C. Hearn, M. Moeller. fluid '(dipvars!*); expr procedure groebnereval u; begin integer n; n := length u; if n=1 then return groebner(reval car u,nil) else if n neq 2 then rederr "GROEBNER called with wrong number of arguments" else return groebner(reval car u,reval cadr u) end; put('groebner,'psopfn,'groebnereval); expr procedure greduce u; % /* Polynomial reduction modulo a Groebner basis driver. u is an % expression and v a list of expressions. Greduce calculates the % polynomial u reduced wrt the list of expressions v reduced to a % groebner basis modulo using the optional third argument as the % order of variables. begin integer n; scalar dipvars!*,v; n := length u; v := for each j in getrlist reval cadr u collect if eqexpr j then !*eqn2a j else j; if n=2 then dipvars!* := for each j in gvarlis v collect !*a2k j else if n=3 then dipvars!* := getrlist caddr u else rederr "GREDUCE called with wrong number of arguments"; v := groebner2 for each j in v collect a2dip j; if cdr v then errach list("Groebner",u) else if null cdar v and dip2a caar v = 1 then rederr "Inconsistent Basis"; return dip2a dipnorform(car v,a2dip reval car u) end; put('greduce,'psopfn,'greduce); expr procedure preduce(u,v); % /* Polynomial reduction driver. u is an expression and v a list of % expressions. Preduce calculates the polynomial u reduced wrt the list % of expressions v. */ begin scalar dipvars!*; v := for each j in getrlist reval v collect if eqexpr j then !*eqn2a j else j; dipvars!* := for each j in gvarlis v collect !*a2k j; return dip2a dipnorform(for each j in v collect a2dip j, a2dip reval u) end; flag('(preduce),'opfn); endmodule; module groebner; % Basic Groebner base code using Buchberger algorithm. % /*Authors: R. Gebauer, A. C. Hearn, M. Moeller. fluid '(!*groebopt !*groebfac !*hopt !*trgroeb !*trgroebs !*trgroeb0 !*trgroeb1 dipvars!* dipzero); switch groebopt,groebfac,hopt,trgroeb,trgroebs,trgroeb0,trgroeb1; % /* option ' groebopt' "optimizes" the given input */ % /* polynomial set ( variable */ % /* ordering ) */ % /* option ' trgroeb' prints intermediate */ % /* results on the output file */ % /* option ' trgroeb1' prints internal representation */ % /* of critical pair list d */ % /* option ' trgroeb0' factorizes the S - polynom */ % /* the S - polynom will not be */ % /* replaced by a factor */ % /* option ' trgroebs ' prints S - polynomials */ % /* on the output file */ % /* option ' hopt ' the H- polynomials are */ % /* optimised using resultant */ % /* and factorisation method */ % /* option ' groebfac ' the H - polynomials are */ % /* factorized. If a H - polynom */ % /* could be factorized, new sub- */ % /* problems are generated and */ % /* option ' fac ' is set to off */ % /* NOTE: this option is not complete */ % /* at the moment and has been suppressed */ % expr procedure bas p; diplprint car groebner(p,dipvars!*); expr procedure groebner(u,v); % /* Buchberger algorithm system driver. u is a list of expressions % and v a list of variables or NIL in which case the variables in u % are used. Groebner(p) calculates the Groebner basis of the % expressions wrt the variables. */ begin scalar dipvars!*,w; w := for each j in getrlist u collect if eqexpr j then !*eqn2a j else j; if null w then rederr "Empty list in Groebner" else if null cdr w then return 'list . w; if null v then v := gvarlis w else v := getrlist v; dipvars!* := for each j in v collect !*a2k j; w := groebner2 for each j in w collect a2dip j; if cdr w then errach list("Groebner",u,dipvars!*); return 'list . for each j in car w collect dip2a j end; expr procedure gvarlis u; % Finds variables (kernels) in the list of expressions u. gvarlis1(u,nil); expr procedure gvarlis1(u,v); if null u then v else union(gvar1(car u,v),gvarlis1(cdr u,v)); expr procedure gvar1(u,v); if null u or numberp u then v else if atom u then if u member v then v else u . v else if car u memq '(plus times expt difference minus) then gvarlis1(cdr u,v) else if car u eq 'quotient then gvar1(cadr u,v) else if u member v then v else u . v; expr procedure groebner2 p; begin scalar tim,spac,spac1,p1; tim := time(); % terprit 3; spac := gctime(); p1:= dipgbase p; spac1 := gctime() - spac; % prin2 " garbage collection time for test "; % prin2 spac1; % prin2 "( not yet available )"; if !*trgroeb then <<prin2 "Computing time for test "; prin2(time() - tim - spac1); % prin2(time() - tim ); prin2t " milliseconds ">>; return p1 end; expr procedure dipindexpol(pl,n); % Distributive polynomial index list. pl is a list of distributive % polynomials; n is an index, an integer. dipindexpol(pl,n) % returns a list of distributive polynomials in the form % ( (n,p1) (n+1,p2) ..... (n+k,pk) ). if null pl then pl else list(n,car pl) . dipindexpol(cdr pl, n + 1); expr procedure dipindexpolspec pl; % Distributive polynomial special list. pl is a list produced % by dipindexpol. dipindexpolspec pl constructs a list of lists % of polynomials in the form ( (p1,.....,pl) (p2,.....,pl).... % ..(pl-1,,pl) (pl) ). for each pl0 on pl collect ( for each pl1 in pl0 collect pl1 ); expr procedure dipcpairlistopt pl; % Distributive critical pair list optimise. pl is a special list % ( constructed by dipcpairlist ) of elements used in the % Groebner calculation. dipcpairlistopt(pl) returns a list which % is optimised using Buchberger criterion 4. if pl then ( if buchcrit4(caddr x, cadddr x, cadr x) then x . dipcpairlistopt cdr pl else dipcpairlistopt cdr pl ) where x = car pl else nil; expr procedure dipcpairlistop(d,d0); % Distributive polynomial critical pair list optimise. % dipcpairlistop(d,d0) returns an optimised critical pair % starting list using the new criteria's. begin scalar x; while d do << x:= dipcpairlistopt1(cadar d,d0,d0); d0:= x; d:= cdr d>>; return x end; expr procedure dipcpairlistopt1(h,d,d0); % Distributive polynomial critical pair list optimise version 1. % dipcpairlistopt1(h,d,d0) returns an optimised critical pair % list. if null d then d0 else ( if evmtest!?(cadar d,ev1) then dipcpairlistopt1(h, cdr d,x) else dipcpairlistopt1(h,cdr d,d0) ) where x= dipcpairlistopt1in(ev1,cadar d,car d,d0) where ev1 = dipevlmon h; expr procedure dipcpairlistopt1in(ev1,ev2,id1,d); % Distributive polynomial critical pair list optimise version 1. % internall. dipcpairlistopt1in is used in dipcpairlistopt1. if ev2 neq evlcm(ev1,dipevlmon caddr id1) and ev2 neq evlcm(ev1,dipevlmon cadddr id1) then dipcpairlistopt1in1(id1,d) else d; expr procedure dipcpairlistopt1in1(d1,d); % Distributive polynomial critical pair list optimise version 1 % internall version 1. dipcpairlistopt1in1 is used in % dipcpairlistopt1in. if null d then nil else if d1 eq car d then dipcpairlistopt1in1(d1,cdr d) else car d . dipcpairlistopt1in1(d1,cdr d); expr procedure dipindexpolrec pl; % Distributive index polynom list reconstruct. pl is a list of % polynomials used in the Groebner calculation. dipindexpolrec(pl) % returns a list of distributive polynomials. for each p in pl collect cadr p; expr procedure dipcplist pl; % Distributive polynomial critical pair list construct. % dipcplist returns a list of elements where an element has the % structure ( (ipi,ipj) lcm(epi,epj) pi pj ). % where ipi is the index of polynomial i, epi is the headterm of % the polynomial pi. for each p in pl conc ( dipcplistopt2(nil, dipcplistin(ep, pi1, reverse cdr p)) ) where ep = dipevlmon cadr pi1 where pi1 = car p; expr procedure dipcplistin(ep,p1,pl); % Distributive polynomial critical pair list construct internall. % dipcplistin is used in dipcplist. if null pl then pl else ( list(list(car p1,car p2), evlcm(ep,dipevlmon cadr p2), cadr p1, cadr p2) . dipcplistin(ep, p1, cdr pl) ) where p2 = car pl; expr procedure dipcplistadd(ind,p,pl); % Distributive polynomial critical pair list add. % dipcplistadd returns a new critical pair list where all % combinations of p with pl are added. if null pl then pl else ( list(list(car ps,ind),evlcm(dipevlmon p1, dipevlmon p),p1,p) . dipcplistadd(ind,p,cdr pl) ) where p1 = cadr ps where ps = car pl; expr procedure dipcplistopt2in(p1,pl); % Distributive polynomial critical pair list optimise version 2 % internall use. dipcplistopt2in(pl1,pl) is used in % dipcplistopt2. if null pl then dipzero else ( if evmtest!?(cadr p1, cadr p) then dipcplistopt2in1(p1,p) else dipcplistopt2in(p1,cdr pl) ) where p = car pl; expr procedure dipcplistopt2in1(p1,p2); % Distributive polynomial critical pair list optimise version 2 % internall use version 1. dipcplistopt2in1(pl1,pl) is used in % dipcplistopt2in. if cadr p1 = cadr p2 then ( if evilcompless!?(reverse car p1, reverse car p2) then p1 else p2 ) else p2; expr procedure dipindexpoloptin(p1,pl); % Distributive index polynomial list optimise internall use. % dipindexpoloptin is used in dipindexpolopt. if null pl then dipzero else ( if evmtest!?(dipevlmon cadr p1, dipevlmon cadr p) then dipindexpoloptin1(p1,p) else dipindexpoloptin(p1,cdr pl) ) where p = car pl; expr procedure dipindexpoloptin1(p1,p2); % Distributive index polynomial list optimise internall version 1. % dipindexpoloptin1 is used in dipindexpoloptin. if dipevlmon cadr p1 = dipevlmon cadr p2 then ( if car p1 < car p2 then p1 else p2 ) else p2; expr procedure dipcplistopt2(pl1,pl2); % Distributive polynomial critical pair list optimise version 2. % dipcplistopt2(pl1,pl2) returns the optimised critical pair list. if null pl2 then pl1 else ( if dipzero!? dipcplistopt2in(p,pl1) and dipzero!? dipcplistopt2in(p,pl0) then dipcplistopt2(cons(p,pl1),pl0) else dipcplistopt2(pl1,pl0) ) where p = car pl2, pl0 = cdr pl2; expr procedure dipindexpolopt(pl1,pl2); % Distributive index polynomial list optimise. pl1 and pl2 % are lists of polynomials used in the Groebner calculation. % dipindexpolopt(pl1,pl2) returns an optimised list of polynomials. if null pl2 then pl1 else ( if dipzero!? dipindexpoloptin(p,pl1) and dipzero!? dipindexpoloptin(p,pl0) then dipindexpolopt(cons(p,pl1),pl0) else dipindexpolopt(pl1,pl0) ) where p = car pl2, pl0 = cdr pl2; expr procedure dipcplistsort pl; % Distributive polynomial critical pair list sort. pl is a % special list for Groebner calculation. dipcplistsort(pl) % returns the sorted list pl; begin scalar tree; if null pl then return nil; tree := list(car pl,nil); while pairp(pl:= cdr pl) do dipcplistsortadd(car pl,tree); return tree2list(tree,nil) end; smacro procedure dipcplistevlcomp(p1,p2); % Distributive polynomial critical pair list exponent vector % compare. p1 and p2 are elements of the critical pair list. % dipcplistevlcomp(p1,p2) returns a boolean expression, true % if exponent vector of p1 is smaller or equal exponent vector % of p2 else false. evcompless!?(cadr p1, cadr p2); expr procedure dipcplistsortadd(item,node); % Distributive polynomial critical pair list sort addition. % add item to a node, using dipcplistevlcomp as an order % predicate. if dipcplistevlcomp(item, car node) then if cadr node then dipcplistsortadd(item, cadr node) else rplaca(cdr node,list(item,nil)) else if cddr node then dipcplistsortadd(item,cddr node) else rplacd(cdr node,list(item,nil)); expr procedure dipcplistmerge(pl1,pl2); % Distributive polynomial critical pair list merge. pl1 and pl2 % are critical pair lists used in the Groebner calculation. % dipcplistmerge(pl1,pl2) returns the merged list. if null pl1 then pl2 else if null pl2 then pl1 else ( if sl then cpl1 . dipcplistmerge(cdr pl1,pl2) else cpl2 . dipcplistmerge(pl1,cdr pl2) ) where sl = evcompless!?(cadr cpl1, cadr cpl2) where cpl1 = car pl1, cpl2 = car pl2; expr procedure buchcrit4(p1,p2,e); % Buchberger criterion 4. p1 and p2 are distributive % polynomials. e is the least common multiple of % the leading exponent vectors of the distributive % polynomials p1 and p2. buchcrit4(p1,p2,e) returns a % boolean expression. True if the reduction of the % distributive polynomials p1 and p2 is necessary % else false. e neq evsum( dipevlmon p1, dipevlmon p2); expr procedure dipgbase pl; % /* Distributive polynomial Groebner base. pl is a list of distributiv % polynomials. dipgbase(pl) calculates the Groebner base of the list % of distributive polynomials pl and returns a list of distributive % polynomials. */ if null pl then nil else if null cdr pl then list pl else if !*groebopt then dipgbasein dipvordopt pl else dipgbasein pl; expr procedure gbprint pl; % Groebner basis list of distributive polynomials print. for each p in pl do dipprint dipmonic p; expr procedure rescheck!?(a,h1,vl); length h1 = a and car h1 = vl - 1; expr procedure rescheck1!?(a,h1,vl); length h1 = a and car h1 = vl - 2 and cadr h1 = vl - 1; expr procedure newhpol(p1,p2,x); begin scalar q1,q2,q; q1:=dip2a diprectoint(p1,diplcm p1); q2:=dip2a diprectoint(p2,diplcm p2); q:=a2dip prepsq simpresultant list(q1,q2,x); return q; end; expr procedure sqpol p1; begin scalar q1,q; q1:=dip2a diprectoint(p1,diplcm p1); q:=a2dip caar sqfrf q1; return q; end; expr procedure dipnorfor (pl,p); % /* Distributive polynom normalform. pl is a list of distributive % polynomials, p is a distributive polynomial. dipnorfor(pl,p) % calculates a distributive polynomial such that the powerproduct % of the distributive % polynomial p is reducible to this modulo the distributive % polynomial list pl and is in normalform with respect to the % distributive polynomial p and returns a distributive polynomial. */ if dipzero!? p or null pl then p else ( if dipzero!? q then p else ( if dipzero!? rq then dipnorfor(pl,dipmred p) else dipnorfor(pl, dipdif(dipmred p, dipprod(rq, dipfmon(bcquot(diplbc p, diplbc q), evdif(ep, dipevlmon q) ) ) ) ) ) where rq = dipmred q ) where q = dipnorformsel(ep, pl) where ep = dipevlmon p; expr procedure dipmingbase pl; % Distributive polynomial minimal ordered Groebner base. pl is a % list of distributive polynomials. dipmingbase(pl) calculates % the minimal normed and ordered Groebner base of the distributive % polyomials pl and returns a list of distributive polyomials. if null cdr pl then pl else dipmingbasein2(nil,dipmingbasein1(nil,pl) ); expr procedure dipgbasein ql; % /* Distributive polynomial Groebner base. pl is a list of distributiv % polynomials. dipgbase(pl) calculates the Groebner base of the list % of distributive polynomials pl and returns a list of distributive % polynomials. */ begin scalar ql0,u,ql1,w,d,ql22,lql1,ql11,lv,h1h0,d1,d0,p1, sp0,n,dl,p2,ct1,sp,h,ct11,h1,h10,hs1,h1h1,h0,hs2; u := 1; w := 1; n := 1; ql0 := nil; ql1:= dipindexpol(ql,1); d:= dipcplistsort dipcpairlistopt dipcplist dipindexpolspec ql1; ql22 := ql; lql1:= length ql1; ql11:=dipindexpolopt(nil, ql1); d:=dipcpairlistop(ql11,d); if !*hopt then << lv:=length dipvars!*; h1h0:=nil>>; d1:=list list(lql1,ql1,ql11,ql22,d); if !*trgroeb1 then << prin2 " list d1 = "; prin2 d1; terpri(); prin2 length d1; terpri() >>; while not null d1 do << d0:= car d1; d1:= cdr d1; lql1:= car d0; ql1:= cadr d0; ql11:= caddr d0; ql22:= cadddr d0; d:= cadddr cdr d0; while not null d do << dl:= car d; d := cdr d; p1:= caddr dl; p2:= cadddr dl; if !*trgroeb then << ct1 := time() >>; sp := dipspolynom(p1,p2); if !*trgroebs then << prin2t "S-polynom:"; dipprint sp; terpri() >>; if !*trgroeb0 then << sp0:= dip2a diprectoint(sp,diplcm sp); sp0:= factorf !*q2f simp sp0; dfcprin sp0; terprit 2 >>; h := dipnorform(ql22, sp); if !*trgroeb then << ct11 := time() - ct1 >>; if dipzero!? h then << if !*trgroeb then << terprit 2; printb 57; terpri(); prin2 " / reduction of polynom "; prin2 caar dl; prin2 " and "; prin2 cadar dl; prin2 " leads to 0 "; prin2 " ( "; prin2 ct11; prin2 " ms )"; terpri(); printb 57; terprit 2 >> >>; if not dipzero!? h then if dipconst!? h then << ql11:= list list(lql1,dipmonic h); d:=nil >> else << h1 := dipmonic h; lql1:= lql1 + 1; if !*trgroeb then << prin2 "h-polynom "; prin2 lql1; prin2 " pair"; prin2 " ( "; prin2 caar dl; prin2 ","; prin2 cadar dl; prin2t " ) :"; dipprint h1; terpri(); prin2 " computing time for h-polynom "; prin2 ct11; terprit 3 >>; % The following option has been suppressed since it is not % complete. if nil and !*groebfac and u = 1 then << h10:= h1; h1:= dip2a diprectoint(h1,diplcm h1); h1:= factorf !*q2f simp h1; hs1:= reverse diplsort makdiplist cdr h1; if !*trgroeb then << prin2 "h-polynom factorized: "; terpri(); dfcprin h1; terpri() >>; h1:= dipmonic car hs1; hs1:= reverse cdr hs1; if not dipzero!? (dipdif(h1,h10)) then << u:= 0 >>; if !*trgroeb then << prin2 " new h-polynom "; terprit 3; dipprint h1; terprit 2 >> >>; if !*hopt and w = 1 then << h1h1:= indexcpl(evsum0(lv,h1),1); if !*trgroeb then << prin2 " index: "; prin2 h1h1; terpri(); prin2 " index: "; prin2 h1h0; terprit 3 >>; if h1h1 = h1h0 and rescheck!?(2,h1h0,lv) then << hs2:= reverse diplsort newhpo(h1,h0,cadr reverse dipvars!*); w:= 0>>; if h1h1 = h1h0 and rescheck1!?(2,h1h0,lv) then << hs2:= reverse diplsort newhpo(h1,h0,caddr reverse dipvars!*); w:= 0 >>; if null hs2 then << w:= 1 >> >>; if u = 0 and not null hs1 then << d0:= maklistd1(hs1,lql1,ql1,ql11,ql22,d); u:= 2; d1:=nconc(d0,d1) >>; %%%%%%% u:= 1; d1:=nconc(d0,d1) >>; d:= dipcpairlistopt1(h1,d,d); if !*trgroeb then << terpri(); prin2 "Restpairs: "; prin2t length d; terpri() >>; d:= dipcplistmerge(dipcplistsort dipcpairlistopt dipcplistopt2(nil,dipcplistadd(lql1,h1,ql11)),d); if !*hopt and w = 1 then << h1h0:=indexcpl(evsum0(lv,h1),1); h0:= h1 >>; ql11:= nconc(list list(lql1,h1),ql11); ql22:= nconc(list(h1),ql22); ql11:= dipindexpolopt(nil,ql11); if !*trgroeb1 then << prin2 " *** d = "; prin2 d; terpri(); prin2t " ql11 "; prin2 ql11; terpri() >>; if w = 0 then << h1:= dipmonic car hs2; hs2:= reverse cdr hs2; lql1:= lql1 + 1; if not null hs2 then << d0:= maklistd1(hs2,lql1,ql1,ql11,ql22,d); w:= 2; d1:= nconc(d0,d1) >>; d:= dipcpairlistopt1(h1,d,d); d:= dipcplistmerge(dipcplistsort dipcpairlistopt dipcplistopt2(nil,dipcplistadd(lql1,h1,ql11)),d); ql11:= nconc(list list(lql1,h1),ql11); ql22:= nconc(list(h1),ql22); ql11:= dipindexpolopt(nil,ql11); if !*trgroeb1 then << prin2 " *** d = "; prin2 d; terpri(); prin2t " ql11 "; prin2 ql11; terpri() >> >> >> >>; ql11:=dipindexpolrec ql11; if !*trgroeb then << prin2t " calculation now in final reduction "; terpri(); ct1 := time() >>; ql:=dipmingbase diplsort ql11; if !*trgroeb then << ct11 := time() - ct1; prin2 " computing time for final calculation "; prin2 ct11; prin2 " milliseconds "; terprit 3; prin2 " Number of Groebner Basis Polynomials := "; prin2t length ql; terprit 2; if n = 1 and null d1 then << prin2t " The Groebner Basis Polynomials "; terpri() >> else << prin2 " The Groebner Basis Polynomials ( Factor "; prin2 n; prin2t " )"; terpri(); n:= n + 1 >>; gbprint ql; if not null d1 then << prin2 " Calculation for Factor "; prin2t n; terprit 4 >> >>; ql0:= ql . ql0 >>; return ql0 end; expr procedure makdiplist pl; % Make list of distributive polynomials from list of polynomials pl. for each p in pl collect a2dip prepf car p; expr procedure terprit n; % print blank lines. for i:=1:n do << terpri() >>; expr procedure printb n; % print special sign ( - ). for i:=1:n do << prin2 "-" >>; expr procedure newhpo(h1,h0,x); % new h-polynom calculation. newhpo(h1,h2,x) calculates % the resultant of the two distributive polynomials h1 and h0 % with respect to x. begin scalar ct00,hh,hh1,hs2; if !*trgroeb then << ct00:= time() >>; hh:= dipmonic newhpol(h1,h0,x); if !*trgroeb then << prin2 " resultant "; terprit 2; dipprint hh; terprit 4 >>; hs2:= nil; if not dipzero!? hh then << hh1:= dip2a diprectoint(hh,diplcm hh); hh1:= factorf !*q2f simp hh1; if !*trgroeb then << prin2 " resultant factorized: "; terprit 2; dfcprin hh1; terprit 2; ct00:= time() - ct00; prin2 " special time for h: "; prin2 ct00; terpri() >>; hs2:= makdiplist cdr hh1 >>; return hs2 end; expr procedure maklistd1(x1,x2,x3,x4,x5,x6); % make list d1. save part time problems. begin scalar x,h1; while x1 do << h1:= car x1; x1:= cdr x1; x:= list(x2,x3, (dipindexpolopt(nil,nconc(list list(x2,h1),x4))), (nconc(list h1,x5)), (dipcplistmerge(dipcplistsort dipcpairlistopt dipcplistopt2(nil,dipcplistadd(x2,h1,x4)), dipcpairlistopt1(h1,x6,x6)))) . x >>; return x end; expr procedure dipmingbasein1 (pl1,pl2); % /* Distributive polynomial minimal ordered Groebner base internal1. % pl1 and pl2 are lists of distributive polynomials. % dipmingbasein1(pl1,pl2) is used in dipmingbase and returns a list % of distributive polynomials. */ if null pl2 then pl1 else ( if dipzero!? dipnorformsel(ep, pl1) and dipzero!? dipnorformsel(ep,cpl2) then dipmingbasein1( cons(p, pl1), cpl2) else dipmingbasein1( pl1, cpl2) ) where ep = dipevlmon p, cpl2 = cdr pl2 where p = car pl2; expr procedure dipmingbasein2 (pl1,pl2); % /* Distributive polynomial minimal ordered Groebner base internal2. % pl1 and pl2 are lists of distributive polynomials. % dipmingbasein2(pl1,pl2) is used in dipmingbase and returns a list % of distributive polynomials. */ if null pl2 then pl1 else ( dipmingbasein2(dipnorform(pl1,dipnorform(rp, p)) . pl1, rp) ) where p = car pl2, rp = cdr pl2; expr procedure dipnorform (pl,p); % /* Distributive polynom normalform. pl is a list of distributive % polynomials, p is a distributive polynomial. dipnorform(pl,p) % calculates a distributive polynomial such that the distributive % polynomial p is reducible to this modulo the distributive % polynomial list pl and is in normalform with respect to the % distributive polynomial p and returns a distributive polynomial. */ if dipzero!? p or null pl then p else ( if dipzero!? q then dipmoncomp(diplbc p, ep, dipnorform(pl, dipmred p) ) else ( if dipzero!? rq then dipnorform(pl, dipmred p) else dipnorform(pl, dipdif(dipmred p, dipprod(rq, dipfmon(bcquot(diplbc p, diplbc q), evdif(ep, dipevlmon q) ) ) ) ) ) where rq = dipmred q ) where q = dipnorformsel(ep, pl) where ep = dipevlmon p; expr procedure dipnorformsel (ep,pl); % /* Distributive polynom normalform select. ep is an exponent vector % of a distributive polynomial. pl is a list of distributive % polynomials. dipnorformsel(ep,pl) returns a distributive % polynomial of pl where ep is a multiple of the leading % exponent vector else dipzero. */ if null pl then dipzero else ( if evmtest!?(ep, dipevlmon q) then q else dipnorformsel(ep, cdr pl) ) where q = car pl; expr procedure dipspolynom (p1,p2); % /* Distributive polynom S polynom. p1 and p2 are distributive % polynomials. dipspolynom(p1,p2) calculates the S polynom of the % distributive polynomials p1 and p2 and returns a distributive % polynomial. */ if dipzero!? p1 or dipzero!? p2 then dipzero else ( if dipzero!? rp1 and dipzero!? rp2 then rp1 else ( if dipzero!? rp1 then dipprod(rp2, dipfmon(bcneg diplbc p1, evdif(ep, ep2) ) ) else if dipzero!? rp2 then dipprod(rp1, dipfmon(diplbc p2, evdif(ep, ep1) ) ) else dipdif( dipprod(rp2, dipfmon(diplbc p1, evdif(ep, ep2) ) ), dipprod(rp1, dipfmon(diplbc p2, evdif(ep, ep1) ) ) ) ) where ep = evlcm(ep1, ep2) where ep1 = dipevlmon p1, ep2 = dipevlmon p2 ) where rp1 = dipmred p1, rp2 = dipmred p2; expr procedure delqip1(u,v); if pairp cdr v then if u eq cadr v then rplacd(v,cddr v) else delqip1(u,cdr v); expr procedure delqip(u,v); % /*Destructive delete of first occurrence of u in v*/ if not pairp v then v else if u eq car v then cdr v else <<delqip1(u,v); v>>; endmodule; module dipopt; % /* Authors: R. Gebauer, A. C. Hearn, H. Kredel */ fluid '(!*trbas dipvars!*); %define ezero = 'nil; fluid '(dipzero ezero); %/*Until we understand how to define something to nil*/ expr procedure dipoptmat1 (el,dpl); % /* Distributive optimisation matrix subfunction 1. el is an % exponent vector, dpl is a degree matix. dipoptmat1(el,dpl) % returns the addition of el to dpl. */ if null el then dpl else dipsum ( dipfmon (bcfi 1, evcons(evfirst el, ezero)), car dpl) . dipoptmat1(evred el, cdr dpl); expr procedure dipoptmat2 (p,pl); % /* Distributive optimisation matrix subfunction 2. p is a % distributive polynomial, pl is a list of distributive % polynomials. dipoptmat1 is used. */ if dipzero!? p then pl else dipoptmat2(dipmred p, dipoptmat1(dipevlmon p, pl)); expr procedure dipoptmat3 (p,pl); % /* Distributive optimisation matrix subfunction 3. p is a % distributive polynomial, pl is a list of distributive % polynomials. dipoptmat2 is used. */ if null p then pl else dipoptmat3(cdr p, dipoptmat2(car p, pl)); expr procedure dipoptmat pl; % /* Distributive optimisation matrix. pl is a list of distributive % polynomials. dipoptmat(pl) returns the optimisation matrix % ( a degree matrix ) of pl, a list of univariate distributive % polynomials. */ if null pl then nil else dipoptmat3(pl, for each x in dipvars!* collect dipzero); expr procedure dipless!? (p1,p2); % /* Distributive polynomial less. p1 and p2 are distributive % polynomials. dipless!?(p1,p2) returns a boolean expression, % true if p1 is less than p2 else false. */ if dipzero!? p1 and dipzero!? p2 then nil else if not dipzero!? p1 then if not dipzero!? p2 then ( if sl < 0 then t else if sl > 0 then nil else ( if bl < 0 then t else if bl > 0 then nil else dipless!?(dipmred p1, dipmred p2) ) where bl = bccomp(diplbc p1, diplbc p2) ) where sl = evcomp(dipevlmon p1, dipevlmon p2) else t else nil; expr procedure pvdema pl; % /* Permutation vector degree matrix. pl is a list of univariate % polynomials in distributive representation. pvdema(pl) returns % a list ( indexlist ) where the elements are digits.*/ pvdema2 sort(pvdema1(pl, 1), 'pvdema3); expr procedure pvdema1(pl,n); % /* Permutation vector degree matrix subfunction 1. pl is a list % of univariate distributive polynomials, n is a digit. % pvdema1 changes the internal structure ( add index for each % polynomial ) and is used in pvdema. */ if null pl then pl else list(car pl, n) . pvdema1(cdr pl, n + 1); expr procedure pvdema2(pl); % /* Permutation vector degree matrix subfunction 2. pl is a list of % univariate distributive polynomials. pvdema2(pl) changes the % internal structure ( delete index for each polynomial ) and % is used in pvdema. */ if null pl then pl else nconc(cdar pl, pvdema2(cdr pl)); expr procedure pvdema3 (p1,p2); % /* Permutation vector degree matrix subfunction 3. p1 and p2 are % distributive univariate polynomials. pvdema3(p1,p2) returns % a boolean expression, true if the distributive polynomial p1 % is less than the distributive polynomial p2 else false. */ dipless!?(car p1, car p2); expr procedure listperm (v,n); % /* List permutation. v is a list ( any kind ) and n is an indexlist. % listperm(v,n) permutates v in respect to n and returns a % permutated list v. */ if null n then nil else nth(v, car n) . listperm(v, cdr n); expr procedure dipreorder (p,n); % /* Distributive polynomial reorder. p is a distributive polynomial, % n is an indexlist. dipreorder(p,n) reorders the exponent vectors % of each term of p in respect to the indexlist n and returns a % distributive polynomial. */ if dipzero!? p then nil else dipsum(dipfmon(diplbc p, evperm(dipevlmon p, n)), dipreorder(dipmred p, n)); expr procedure diplreorder (pl,n); % /* Distributive polynomial list reorder. pl is a list of distributive % polynomials and n is an indexlist. diplreorder(pl,n) reorders the % exponent vectors of each term of each polynomial in the list pl in % respect to the indexlist n and returns a list of distributive % polynomials.*/ for each x in pl collect dipreorder(x, n); expr procedure dipvordopt pl; % /* Distributive polynomial variable ordering optimisation. % pl is a list of distributive polynomials. dipvordopt(pl) % calculates the " optimal representation " and returns a list % of distributive polynomials. % NOTE: dipvordopt can change the global variable list dipvars!* */ begin scalar n,olddipvars,pl1; n := pvdema diopmatin pl; if !*trbas then << prin2t " The new index list :"; terprit 2; prin2t n; terprit 2 >>; olddipvars := dipvars!*; dipvars!* := listperm(dipvars!*, n); if !*trbas then << prin2t " The new variable list :"; terprit 2; prin2t dipvars!*; terprit 2 >>; pl1 := diplreorder(pl, n); if !*trbas then << prin2t " The new polynomial list :"; terprit 2; diplprint pl1; terprit 2 >>; % dipvars!* := olddipvars; return pl1 end; expr procedure diopmatin pl; % print univariate polynomials. begin scalar n1; << if !*trbas then << prin2t " The variable list :"; terprit 2; prin2t dipvars!*; terprit 2; prin2t " The univariate polynomials in each variable :"; terprit 2 >>; n1:=dipoptmat pl; if !*trbas then << dioprin(n1,dipvars!*) >> >>; return n1 end; expr procedure dioprin(pl,d); % print variables. begin scalar dipvars!*; for each x in pair(pl,d) do << dipvars!* := list cdr x; dipprint car x >> end; endmodule; end; |
Added r33/hephys.red version [f907b260f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module hephys; % Support for high energy physics calculations. % Author: Anthony C. Hearn. % Generalizations for n dimensional vector and gamma algebra by % Gastmans, Van Proeyen and Verbaeten, University of Leuven, Belgium. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*sub2 ndims!*); global '(defindices!* indices!* mul!* ncmp!* ndim!*); defindices!* := nil; % Deferred indices in N dim calculations. indices!* := nil; % List of indices in High Energy Physics % tensor expressions. ndim!* := 4; % Number of dimensions in gamma algebra. % *********************** SOME DECLARATIONS ************************* deflist ('((cons simpdot)),'simpfn); put('vector,'stat,'rlis); % put('vector,'formfn,'formvector); %symbolic procedure formvector(u,vars,mode); % if mode eq 'algebraic % then list('vector1,'list . formlis(cdr u,vars,'algebraic)) % else u; symbolic procedure vector u; vector1 u; symbolic procedure vector1 u; for each x in u do begin scalar y; if not idp x or (y := getrtype x) and y neq 'vector then typerr(list(y,x),"high energy vector") else put(x,'rtype,'vector) end; put('vector,'fn,'vecfn); put('vector,'evfn,'veval); put('g,'simpfn,'simpgamma); flagop nospur; flag ('(g),'noncom); symbolic procedure index u; begin vector1 u; rmsubs(); indices!* := union(indices!*,u) end; symbolic procedure remind u; begin indices!* := setdiff(indices!*,u) end; symbolic procedure mass u; if null car u then rederr "No arguments to MASS" else <<for each x in u do put(cadr x,'rtype,'vector); for each x in u do put(cadr x,'mass,caddr x)>>; symbolic procedure getmas u; (lambda x; if x then x else rederr list(u,"has no mass")) get!*(u,'mass); symbolic procedure vecdim u; begin ndim!* := car u end; symbolic procedure mshell u; begin scalar x,z; a: if null u then return let0 z; x := getmas car u; z := list('equal,list('cons,car u,car u),list('expt,x,2)) . z; u := cdr u; go to a end; rlistat '(vecdim index mass mshell remind vector); % ******** FUNCTIONS FOR SIMPLIFYING HIGH ENERGY EXPRESSIONS ********* symbolic procedure veval(u,v); begin scalar z; u := nssimp(u,'vector); a: if null u then return replus z else if null cdar u then rederr "Missing vector" else if cddar u then msgpri("Redundant vector in",cdar u,nil,nil,t); z := aconc!*(z,retimes(prepsq caar u . cdar u)); u := cdr u; go to a end; symbolic procedure vmult u; begin scalar z; z := list list(1 . 1); a: if null u then return z; z := vmult1(nssimp(car u,'vector),z); if null z then return; u := cdr u; go to a end; symbolic procedure vmult1(u,v); begin scalar z; if null v then return; a: if null u then return z else if cddar u then msgpri("Redundant vector in",cdar u,nil,nil,t); z := nconc!*(z,mapcar(v,function (lambda j; multsq(car j,caar u) . append(cdr j,cdar u)))); u := cdr u; go to a end; symbolic procedure simpdot u; mkvarg(u,function dotord); symbolic procedure dotord u; <<if xnp(u,indices!*) and not ('isimpq memq mul!*) then mul!* := aconc!*(mul!*,'isimpq) else nil; if 'a memq u then rederr "A represents only gamma5 in vector expressions" else mksq('cons . ord2(car u,carx(cdr u,'dot)),1)>>; symbolic procedure mkvarg(u,v); begin scalar z; u := vmult u; z := nil ./ 1; a: if null u then return z; z := addsq(multsq(apply1(v,cdar u),caar u),z); u := cdr u; go to a end; symbolic procedure spur u; <<rmsubs(); map(u,function (lambda j; <<remflag(list car j,'nospur); remflag(list car j,'reduce)>>))>>; rlistat '(spur); symbolic procedure simpgamma u; if null u or null cdr u then rederr "Missing arguments for G operator" else begin scalar z; if not ('isimpq memq mul!*) then mul!*:= aconc!*(mul!*,'isimpq); ncmp!* := t; z := nil ./ 1; for each j in vmult cdr u do z := addsq(multsq(!*k2q('g . car u . cdr j),car j),z); return z end; symbolic procedure simpeps u; mkvarg(u,function epsord); symbolic procedure epsord u; if repeats u then nil ./ 1 else mkepsq u; symbolic procedure mkepsk u; % U is of the form (v1 v2 v3 v4). % Value is <sign flag> . <kernel for EPS(v1,v2,v3,v4)>. begin scalar x; if xnp(u,indices!*) and not 'isimpq memq mul!* then mul!* := aconc!*(mul!*,'isimpq); x := ordn u; u := permp(x,u); return u . ('eps . x) end; symbolic procedure mkepsq u; (lambda x; (lambda y; if null car x then negsq y else y) mksq(cdr x,1)) mkepsk u; % ** FUNCTIONS FOR SIMPLIFYING VECTOR AND GAMMA MATRIX EXPRESSIONS ** symbolic smacro procedure mkg(u,l); % Value is the standard form for G(L,U). !*p2f('g . l . u to 1); symbolic smacro procedure mka l; % Value is the standard form for G(L,A). !*p2f(list('g,l,'a) to 1); symbolic smacro procedure mkgamf(u,l); mksf('g . (l . u)); symbolic procedure mkg1(u,l); if not flagp(l,'nospur) then mkg(u,l) else mkgamf(u,l); symbolic smacro procedure mkpf(u,v); multpf(u,v); symbolic procedure mkf(u,v); multf(u,v); symbolic procedure multd!*(u,v); if u=1 then v else multd(u,v); % onep symbolic smacro procedure addfs(u,v); addf(u,v); symbolic smacro procedure multfs(u,v); % U and V are pseudo standard forms. % Value is pseudo standard form for U*V. multf(u,v); symbolic procedure isimpq u; begin scalar ndims!*; ndims!* := simp ndim!*; if denr ndims!* neq 1 then <<!*sub2 := t; ndims!* := multpf(mksp(list('recip,denr ndims!*),1), numr ndims!*)>> else ndims!* := numr ndims!*; a: u := isimp1(numr u,indices!*,nil,nil,nil) ./ denr u; if defindices!* then <<indices!* := union(defindices!*,indices!*); defindices!* := nil; go to a>> else if null !*sub2 then return u else return resimp u end; symbolic procedure isimp1(u,i,v,w,x); if null u then nil else if domainp u then if x then multd(u,spur0(car x,i,v,w,cdr x)) else if v then rederr("Unmatched index" . i) else if w then multfs(emult w,isimp1(u,i,v,nil,x)) else u else addfs(isimp2(car u,i,v,w,x),isimp1(cdr u,i,v,w,x)); symbolic procedure isimp2(u,i,v,w,x); begin scalar z; if atom (z := caar u) then go to a else if car z eq 'cons and xnp(cdr z,i) then return dotsum(u,i,v,w,x) else if car z eq 'g then go to b else if car z eq 'eps then return esum(u,i,v,w,x); a: return mkpf(car u,isimp1(cdr u,i,v,w,x)); b: z := gadd(appn(cddr z,cdar u),x,cadr z); return isimp1(multd!*(nb car z,cdr u),i,v,w,cdr z) end; symbolic procedure nb u; if u then 1 else -1; symbolic smacro procedure mkdot(u,v); % Returns a standard form for U . V. mksf('cons . ord2(u,v)); symbolic procedure dotsum(u,i,v,w,x); begin scalar i1,n,u1,u2,v1,y,z,z1; n := cdar u; if not (car (u1 := cdaar u) member i) then u1 := reverse u1; u2 := cadr u1; u1 := car u1; v1 := cdr u; if n=2 then go to h else if n neq 1 then typerr(n,"index power"); a: if u1 member i then go to a1 else if null (z := mkdot(u1,u2)) then return nil else return mkf(z,isimp1(v1,i1,v,w,x)); a1: i1 := delete(u1,i); if u1 eq u2 then return multf(ndims!*,isimp1(v1,i1,v,w,x)) else if not (z := bassoc(u1,v)) then go to c else if u2 member i then go to d; if u1 eq car z then u1 := cdr z else u1 := car z; go to e; c: if z := memlis(u1,x) then return isimp1(v1, i1, v, w, subst(u2,u1,z) . delete(z,x)) else if z := memlis(u1,w) then return esum((('eps . subst(u2,u1,z)) . 1) . v1, i1, v, delete(z,w), x) else if u2 member i and null y then go to g; return isimp1(v1,i,(u1 . u2) . v,w,x); d: z1 := u1; u1 := u2; if z1 eq car z then u2 := cdr z else u2 := car z; e: i := i1; v := delete(z,v); go to a; g: y := t; z := u1; u1 := u2; u2 := z; go to a1; h: if u1 eq u2 then rederr "2 invalid as repeated index power"; i := i1 := delete(u1,i); u1 := u2; go to a end; symbolic procedure mksf u; % U is a kernel. % Value is a (possibly substituted) standard form for U. begin scalar x; x := mksq(u,1); if cdr x=1 then return car x; !*sub2 := t; return !*p2f(u to 1) end; % ********* FUNCTIONS FOR SIMPLIFYING DIRAC GAMMA MATRICES ********** symbolic procedure gadd(u,v,l); begin scalar w,x; integer n; n := 0; % Number of gamma5 interchanges. if not (x := atsoc(l,v)) then go to a; v := delete(x,v); w := cddr x; % List being built. x := cadr x; % True if gamma5 remains. a: if null u then return (evenp n . (l . x . w) . v) else if car u eq 'a then go to c else w := car u . w; b: u := cdr u; go to a; c: if ndims!* neq 4 then rederr "Gamma5 not allowed unless vecdim is 4"; x := not x; n := length w + n; go to b end; % ***** FUNCTIONS FOR COMPUTING TRACES OF DIRAC GAMMA MATRICES ******* symbolic procedure spur0(u,i,v1,v2,v3); begin scalar l,w,i1,kahp,n,z; l := car u; n := 1; z := cadr u; u := reverse cddr u; if z then u := 'a . u; % Gamma5 remains. if null u then go to end1 else if null flagp(l,'nospur) then if car u eq 'a and (length u<5 or hevenp u) or not car u eq 'a and not hevenp u then return nil else if null i then <<w := reverse u; go to end1>>; a: if null u then go to end1 else if car u member i then if car u member cdr u then <<if car u eq cadr u then <<i := delete(car u,i); u := cddr u; n := multf(n,ndims!*); go to a>>; kahp := t; i1 := car u . i1; go to a1>> else if car u member i1 then go to a1 else if z := bassoc(car u,v1) then <<v1 := delete(z,v1); i := delete(car w,i); u := other(car u,z) . cdr u; go to a>> else if z := memlis(car u,v2) then return if flagp(l,'nospur) and null v1 and null v3 and null cdr v2 then mkf(mkgamf(append(reverse w,u),l), multfs(n,mkepsf z)) else multd!*(n, isimp1(spur0( l . (nil . append(reverse u,w)),nil,nil,delete(z,v2),v3), i,v1,list z,nil)) else if z := memlis(car u,v3) then if ndims!*=4 then return spur0i(u,delete(car u,i),v1,v2, delete(z,v3),l,n,w,z) else <<indices!* := delete(car u,indices!*); i := delete(car u,i); if not car u memq defindices!* then defindices!* := car u . defindices!*; go to a1>> else rederr list("Unmatched index",car u); a1: w := car u . w; u := cdr u; go to a; end1: if kahp then if ndims!*=4 then <<z := multfs(n,kahane(reverse w,i1,l)); return isimp1(z,setdiff(i,i1),v1,v2,v3)>> else z := spurdim(w,i,l,nil,1) else z := spurr(w,l,nil,1); return if null z then nil else if get('eps,'klist) and not flagp(l,'nospur) then isimp1(multfs(n,z),i,v1,v2,v3) else multfs(z,isimp1(n,i,v1,v2,v3)) end; symbolic procedure spur0i(u,i,v1,v2,v3,l,n,w,z); begin scalar kahp,i1; if flagp(l,'nospur) and flagp(car z,'nospur) then rederr "NOSPUR on more than one line not implemented" else if flagp(car z,'nospur) then kahp := car z; z := cdr z; i1 := car z; z := reverse cdr z; if i1 then z := 'a . z; i1 := nil; <<while null (car u eq car z) do <<i1 := car z . i1; z := cdr z>>; z := cdr z; u := cdr u; if flagp(l,'nospur) then <<w := w . (u . (i1 . z)); i1 := car w; z := cadr w; u := caddr w; w := cdddr w>>; w := reverse w; if null ((null u or not eqcar(w,'a)) and (u := append(u,w))) then <<if not hevenp u then n := - n; u := 'a . append(u,cdr w)>>; if kahp then l := kahp; z := mkf(mkg(reverse i1,l), multf(brace(u,l,i),multfs(n,mkg1(z,l)))); z := isimp1(z,i,v1,v2,v3); if null z or (z := quotf(z,2)) then return z else errach list('spur0,n,i,v1,v2,v3)>> end; symbolic procedure spurdim(u,i,l,v,n); begin scalar w,x,y,z,z1; integer m; a: if null u then return if null v then n else if flagp(l,'nospur) then multfs(n,mkgamf(v,l)) else multfs(n,sprgen v) else if not(car u memq cdr u) then <<v := car u . v; u := cdr u; go to a>>; x := car u; y := cdr u; w := y; m := 1; b: if x memq i then go to d else if not x eq car w then go to c else if null(w := mkdot(x,x)) then return z; if x memq i then w := ndims!*; return addfs(mkf(w,spurdim(delete(x,y),i,l,v,n)),z); c: z1 := mkdot(x,car w); if car w memq i then z := addfs(spurdim(subst(x,car w,remove(y,m)), i,l,v,2*n),z) else if z1 then z := addfs(mkf(z1,spurdim(remove(y,m),i,l,v,2*n)),z); w := cdr w; n := -n; m := m+1; go to b; d: while not(x eq car w) do <<z:= addfs(spurdim(subst(car w,x,remove(y,m)),i,l,v,2*n),z); w := cdr w; n := -n; m := m+1>>; return addfs(mkf(ndims!*,spurdim(delete(x,y),i,l,v,n)),z) end; symbolic procedure appn(u,n); if n=1 then u else append(u,appn(u,n-1)); symbolic procedure other(u,v); if u eq car v then cdr v else car v; symbolic procedure kahane(u,i,l); % The Kahane algorithm for Dirac matrix string reduction. % Ref: Kahane, J., Journ. Math. Phys. 9 (1968) 1732-1738. begin scalar p,r,v,w,x,y,z; integer k,m; k := 0; mark: if eqcar(u,'a) then go to a1; a: p := not p; % Vector parity. if null u then go to d else if car u member i then go to c; a1: w := aconc!*(w,car u); b: u := cdr u; go to a; c: y := car u . p; z := (x . (y . w)) . z; x := y; w := nil; k := k+1; go to b; d: z := (nil . (x . w)) . z; % Beware ... end of string has opposite convention. pass2: m := 1; l1: if null z then go to l9; u := caar z; x := cadar z; w := cddar z; z := cdr z; m := m+1; if null u then go to l2 else if (car u eq car x) and exc(x,cdr u) then go to l7; w := reverse w; r := t; l2: p := not exc(x,r); x := car x; y := nil; l3: if null z then rederr("Unmatched index" . if y then if not atom cadar y then cadar y else if not atom caar y then caar y else nil else nil) else if (x eq car (i := cadar z)) and not exc(i,p) then go to l5 else if (x eq car (i := caar z)) and exc(i,p) then go to l4; y := car z . y; z := cdr z; go to l3; l4: x := cadar z; w := appr(cddar z,w); r := t; go to l6; l5: x := caar z; w := append(cddar z,w); r := nil; l6: z := appr(y,cdr z); if null x then go to l8 else if not eqcar(u,car x) then go to l2; l7: if w and cdr u then w := aconc!*(cdr w,car w); v := multfs(brace(w,l,nil),v); % v := ('brace . l . w) . v; go to l1; l8: v := mkg(w,l); % v := list('g . l . w); z := reverse z; k := k/2; go to l1; l9: u := 2**k; if not evenp(k-m) then u := - u; return multd!*(u,v) % return 'times . u . v; end; symbolic procedure appr(u,v); if null u then v else appr(cdr u,car u . v); symbolic procedure exc(u,v); if null cdr u then v else not v; symbolic procedure brace(u,l,i); if null u then 2 else if xnp(i,u) or flagp(l,'nospur) then addf(mkg1(u,l),mkg1(reverse u,l)) else if car u eq 'a then if hevenp u then addfs(mkg(u,l), negf mkg('a . reverse cdr u,l)) else mkf(mka l,spr2(cdr u,l,2,nil)) else if hevenp u then spr2(u,l,2,nil) else spr1(u,l,2,nil); symbolic procedure spr1(u,l,n,b); if null u then nil else if null cdr u then multd!*(n,mkg1(u,l)) else begin scalar m,x,z; x := u; m := 1; a: if null x then return z; z:= addfs(mkf(mkg1(list car x,l), if null b then spurr(remove(u,m),l,nil,n) else spr1(remove(u,m),l,n,nil)), z); x := cdr x; n := - n; m := m+1; go to a end; symbolic procedure spr2(u,l,n,b); if null cddr u and null b then multd!*(n,mkdot(car u,cadr u)) else (lambda x; if b then addfs(spr1(u,l,n,b),x) else x) addfs(spurr(u,l,nil,n), mkf(mka l,spurr(append(u,list 'a),l,nil,n))); symbolic procedure hevenp u; null u or not hevenp cdr u; symbolic procedure bassoc(u,v); if null v then nil else if u eq caar v or u eq cdar v then car v else bassoc(u,cdr v); symbolic procedure memlis(u,v); if null v then nil else if u member car v then car v else memlis(u,cdr v); symbolic procedure spurr(u,l,v,n); begin scalar w,x,y,z,z1; integer m; a: if null u then go to b else if car u member cdr u then go to g; v := car u . v; u := cdr u; go to a; b: return if null v then n else if flagp(l,'nospur) then multd!*(n,mkgamf(v,l)) else multd!*(n,sprgen v); g: x := car u; y := cdr u; w := y; m := 1; h: if not x eq car w then go to h1 else if null(w:= mkdot(x,x)) then return z else return addfs(mkf(w,spurr(delete(x,y),l,v,n)),z); h1: z1 := mkdot(x,car w); if z1 then z:= addfs(mkf(z1,spurr(remove(y,m),l,v,2*n)),z); w := cdr w; n := - n; m := m+1; go to h end; symbolic procedure sprgen v; begin scalar x,y,z; if not (car v eq 'a) then return sprgen1(v,t) else if null (x := comb(v := cdr v,4)) then return nil else if null cdr x then go to e; c: if null x then return multpf('i to 1,z); y := mkepsf car x; if asign(car x,v,1)=-1 then y := negf y; z := addf(multf(y,sprgen1(setdiff(v,car x),t)),z); d: x := cdr x; go to c; e: z := mkepsf car x; go to d end; symbolic procedure asign(u,v,n); if null u then n else asign(cdr u,v,asign1(car u,v,-1)*n); symbolic procedure asign1(u,v,n); if u eq car v then n else asign1(u,cdr v,-n); symbolic procedure sprgen1(u,b); if null u then nil else if null cddr u then (lambda x; if b then x else negf x) mkdot(car u,cadr u) else begin scalar w,x,y,z; x := car u; u := cdr u; y := u; a: if null u then return z else if null(w:= mkdot(x,car u)) then go to c; z := addf(multf(w,sprgen1(delete(car u,y),b)),z); c: b := not b; u := cdr u; go to a end; % ****************** FUNCTIONS FOR EPSILON ALGEBRA ****************** put('eps,'simpfn,'simpeps); symbolic procedure mkepsf u; (lambda x; (lambda y; if null car x then negf y else y) mksf cdr x) mkepsk u; symbolic procedure esum(u,i,v,w,x); begin scalar y,z,z1; z := car u; u := cdr u; if cdr z neq 1 then u := multf(exptf(mkepsf cdar z,cdr z-1),u); z := cdar z; a: if repeats z then return; b: if null z then return isimp1(u,i,v,reverse y . w,x) else if not (car z member i) then go to d else if not (z1 := bassoc(car z,v)) then go to c; v := delete(z1,v); i := delete(car z,i); z := append(reverse y,other(car z,z1) . cdr z); y := nil; go to a; c: if z1 := memlis(car z,w) then go to c1 else return isimp1(u,i,v,append(reverse y,z) . w,x); c1: z := append(reverse y,z); y := xn(i,xn(z,z1)); return isimp1(multfs(emult1(z1,z,y),u), setdiff(i,y), v, delete(z1,w), x); d: y := car z . y; z := cdr z; go to b end; symbolic procedure emult u; if null cdr u then mkepsf car u else if null cddr u then emult1(car u,cadr u,nil) else multfs(emult1(car u,cadr u,nil),emult cddr u); symbolic procedure emult1(u,v,i); (lambda (x,y); (lambda (m,n); if m=4 then 24*n else if m=3 then multd(6*n,mkdot(car x,car y)) else multd!*(n*(if m = 0 then 1 else m), car detq maplist(x, function (lambda k; maplist(y, function (lambda j; mkdot(car k,car j) . 1)))))) (length i, (lambda j; nb if permp(u,append(i,x)) then not j else j) permp(v,append(i,y)))) (setdiff(u,i),setdiff(v,i)); endmodule; end; |
Added r33/int.red version [f57c141c52].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 | module int!-intro; % General support for REDUCE integrator. % Authors: A. C. Norman and P. M. A. Moore. % Modified by: J. Davenport, J. P. Fitch, A. C. Hearn. % Note that at one point, INT had been flagged SIMP0FN. However, that % lead to problems when the arguments of INT contained pattern % variables. fluid '(!*conscount !*noextend !*pvar gaussiani); global '(btrlevel frlis!* gensymcount initl!*); !*conscount:=10000; % default maximum number of conses in certain % operations. !*pvar:='!_a; btrlevel := 5; %default to a reasonably full backtrace. % The next smacro is needed at this point to define gaussiani. symbolic smacro procedure !*kk2f u; !*p2f mksp(u,1); gaussiani := !*kk2f '(sqrt -1); gensymcount := 0; initl!* := append('(!*noextend), initl!*); flag('(interr),'transfer); %For the compiler; flag ('(atan dilog erf expint expt log tan),'transcendental); comment Kludge to define derivative of an integral and integral of a derivative; frlis!* := union('(!=x !=y),frlis!*); put('df,'opmtch,'(((int !=y !=x) !=x) (nil . t) (evl!* !=y) nil) . get('df,'opmtch)); put('int,'opmtch,'(((df !=y !=x) !=x) (nil . t) (evl!* !=y) nil) . get('int,'opmtch)); put('evl!*,'opmtch,'(((!=x) (nil . t) !=x nil))); put('evl!*,'simpfn,'simpiden); %Various functions used throughout the integrator. smacro procedure !*kk2q a; ((mksp(a,1) .* 1) .+ nil) ./ 1; symbolic smacro procedure divsf(u,v); sqrt2top(u ./ v); symbolic procedure flatten u; if null u then nil else if atom u then list u else if atom car u then car u . flatten cdr u else nconc(flatten car u,flatten cdr u); symbolic procedure int!-gensym1 u; << gensymcount:=gensymcount+1; compress append(explode u,explode gensymcount) >>; symbolic smacro procedure maninp(u,v,w); interr "MANINP called -- not implemented"; symbolic procedure mknill n; if n=0 then nil else nil . mknill(n-1); % Various selectors written as macros. smacro procedure argof u; % Argument of a unary function. cadr u; smacro procedure firstsubs u; % The first substitution in a substitution list. car u; smacro procedure lsubs u; car u; smacro procedure rsubs u; cdr u; smacro procedure lfirstsubs u; caar u; smacro procedure rfirstsubs u; cdar u; put('nthroot,'simpfn,'simpiden); % The binary n-th root operator nthroot(x,2)=sqrt(x) % no simplification is used here. % Hope is that pbuild introduces it, and simplog removes it. % Selectors for the taylor series structure. % Format is: %function.((first.last computed so far) . assoc list of computed terms). % ***store-hack-1***: % remove this macro if more store is available. smacro procedure tayshorten u;nil; smacro procedure taylordefn u; car u; symbolic smacro procedure taylorfunction u; caar u; smacro procedure taylornumbers u; cadr u; smacro procedure taylorfirst u; caadr u; smacro procedure taylorlast u; cdadr u; smacro procedure taylorlist u; cddr u; smacro procedure taylormake(fn,nums,alist); fn.(nums.alist); endmodule; module contents; % Authors: Mary Ann Moore and Arthur C. Norman fluid '(clogflag content indexlist sqfr varlist zlist); exports contents,contentsmv,dfnumr,difflogs,factorlistlist,multsqfree, multup,sqfree,sqmerge; imports int!-fac,fquotf,gcdf,interr,!*multf,partialdiff,quotf,ordop, addf,negf,domainp,difff,mksp,negsq,invsq,addsq,!*multsq,diffsq; comment we assume no power substitution is necessary in this module; symbolic procedure contents(p,v); % Find the contents of the polynomial p wrt variable v; % Note that v may not be the main variable of p; if domainp(p) then p else if v=mvar p then contentsmv(p,v,nil) else if ordop(v,mvar p) then p else contentsmv(makemainvar(p,v),v,nil); symbolic procedure contentsmv(p,v,sofar); % Find contents of polynomial P; % V is main variable of P; % SOFAR is partial result; if sofar=1 then 1 else if domainp p then gcdf(p,sofar) else if not v=mvar p then gcdf(p,sofar) else contentsmv(red p,v,gcdf(lc p,sofar)); symbolic procedure makemainvar(p,v); % Bring v up to be the main variable in polynomial p; % Note that the reconstructed p must be used with care since; % it does not conform to the normal reduce ordering rules; if domainp p then p else if v=mvar p then p else mergeadd(mulcoeffsby(makemainvar(lc p,v),lpow p,v), makemainvar(red p,v),v); symbolic procedure mulcoeffsby(p,pow,v); % Multiply each coefficient in p by the standard power pow; if null p then nil else if domainp p or not v=mvar p then ((pow .* p) .+ nil) else (lpow p .* ((pow .* lc p) .+ nil)) .+ mulcoeffsby(red p,pow,v); symbolic procedure mergeadd(a,b,v); % Add polynomials a and b given that they have same main variable v; if domainp a or not v=mvar a then if domainp b or not v=mvar b then addf(a,b) else lt b .+ mergeadd(a,red b,v) else if domainp b or not v=mvar b then lt a .+ mergeadd(red a,b,v) else (lambda xc; if xc=0 then (lpow a .* addf(lc a,lc b)) .+ mergeadd(red a,red b,v) else if xc>0 then lt a .+ mergeadd(red a,b,v) else lt b .+ mergeadd(a,red b,v)) (tdeg lt a-tdeg lt b); symbolic procedure sqfree(p,vl); if (null vl) or (domainp p) then <<content:=p; nil>> else begin scalar w,v,dp,gg,pg,dpg,p1,w1; w:=contents(p,car vl); % content of p ; p:=quotf(p,w); % make p primitive; w:=sqfree(w,cdr vl); % process content by recursion; if p=1 then return w; v:=car vl; % pick out variable from list; while not (p=1) do << dp:=partialdiff(p,v); gg:=gcdf(p,dp); pg:=quotf(p,gg); dpg:=negf partialdiff(pg,v); p1:=gcdf(pg,addf(quotf(dp,gg),dpg)); w1:=p1.w1; p:=gg>>; return sqmerge(reverse w1,w,t) end; symbolic procedure sqmerge(w1,w,simplew1); % w and w1 are lists of factors of each power. if simplew1 is true % then w1 contains only single factors for each power. ; if null w1 then w else if null w then if car w1=1 then nil.sqmerge(cdr w1,w,simplew1) else (if simplew1 then list car w1 else car w1). sqmerge(cdr w1,w,simplew1) else if car w1=1 then (car w).sqmerge(cdr w1,cdr w,simplew1) else append(if simplew1 then list car w1 else car w1,car w). sqmerge(cdr w1,cdr w,simplew1); symbolic procedure multup l; % l is a list of s.f.'s. result is s.f. for product of elements of l; begin scalar res; res:=1; while not null l do << res:=multf(res,car l); l:=cdr l >>; return res end; symbolic procedure diflist(l,cl,x,rl); % Differentiates l (list of s.f.'s) wrt x to produce the sum of % terms for the derivative of numr of 1st part of answer. cl is % coefficient list (s.f.'s) & rl is list of derivatives we have % dealt with so far. Result is s.q.; if null l then nil ./ 1 else begin scalar temp; temp:=!*multf(multup rl,multup cdr l); temp:=!*multsq(difff(car l,x),!*f2q temp); temp:=!*multsq(temp,(car cl) ./ 1); return addsq(temp,diflist(cdr l,cdr cl,x,(car l).rl)) end; symbolic procedure multsqfree w; % W is list of sqfree factors. result is product of each LIST IN W % to give one polynomial for each sqfree power; if null w then nil else (multup car w).multsqfree cdr w; symbolic procedure l2lsf l; % L is a list of kernels. result is a list of same members as s.f.'s; if null l then nil else ((mksp(car l,1) .* 1) .+ nil).l2lsf cdr l; symbolic procedure dfnumr(x,dl); % Gives the derivative of the numr of the 1st part of answer. % dl is list of any exponential or 1+tan**2 that occur in integrand % denr. these are divided out from result before handing it back. % result is s.q., ready for printing. begin scalar temp1,temp2,coeflist,qlist,count; if not null sqfr then << count:=0; qlist:=cdr sqfr; coeflist:=nil; while not null qlist do << count:=count+1; coeflist:=count.coeflist; qlist:=cdr qlist >>; coeflist:=reverse coeflist >>; temp1:=!*multsq(diflist(l2lsf zlist,l2lsf indexlist,x,nil), !*f2q multup sqfr); if not null sqfr and not null cdr sqfr then << temp2:=!*multsq(diflist(cdr sqfr,coeflist,x,nil), !*f2q multup l2lsf zlist); temp2:=!*multsq(temp2,(car sqfr) ./ 1) >> else temp2:=nil ./ 1; temp1:=addsq(temp1,negsq temp2); temp2:=cdr temp1; temp1:=car temp1; qlist:=nil; while not null dl do << if not car dl member qlist then qlist:=(car dl).qlist; dl:=cdr dl >>; while not null qlist do << temp1:=quotf(temp1,car qlist); qlist:=cdr qlist >>; return temp1 ./ temp2 end; symbolic procedure difflogs(ll,denm1,x); % LL is list of log terms (with coeffts), den is common denominator % over which they are to be put. Result is s.q. for derivative of all % these wrt x. if null ll then nil ./ 1 else begin scalar temp,qu,cvar,logoratan,arg; logoratan:=caar ll; cvar:=cadar ll; arg:=cddar ll; temp:=!*multsq(cvar ./ 1,diffsq(arg,x)); if logoratan='iden then qu:=1 ./ 1 else if logoratan='log then qu:=arg else if logoratan='atan then qu:=addsq(1 ./ 1,!*multsq(arg,arg)) else interr "Logoratan=? in difflogs"; %Note call to special division routine; qu:=fquotf(!*multf(!*multf(denm1,numr temp), denr qu),numr qu); %*MUST* GO EXACTLY; temp:=!*multsq(!*invsq (denr temp ./ 1),qu); %result of fquotf is a s.q; return !*addsq(temp,difflogs(cdr ll,denm1,x)) end; symbolic procedure factorlistlist (w,clogflag); % W is list of lists of sqfree factors in s.f. result is list of log % terms required for integral answer. the arguments for each log fn % are in s.q.; begin scalar res,x,y; while not null w do << x:=car w; while not null x do << y:=facbypp(car x,varlist); while not null y do << res:=append(int!-fac car y,res); y:=cdr y >>; x:=cdr x >>; w:=cdr w >>; return res end; symbolic procedure facbypp(p,vl); % Use contents/primitive parts to try to factor p. if null vl then list p else begin scalar princilap!-part,co; co:=contents(p,car vl); vl:=cdr vl; if co=1 then return facbypp(p,vl); %this var no help. princilap!-part:=quotf(p,co); %primitive part. if princilap!-part=1 then return facbypp(p,vl); %again no help; return nconc(facbypp(princilap!-part,vl),facbypp(co,vl)) end; endmodule; module csolve; % routines to do with the C constants. % Author: John P. Fitch. fluid '(ccount cmap cmatrix cval loglist neweqn); global '(!*trint); exports backsubst4cs,createcmap,findpivot,printspreadc,printvecsq, spreadc,subst4eliminateds; imports nth,interr,!*multf,printsf,printsq,quotf,putv,negf,invsq, negsq,addsq,multsq,mksp,addf,domainp,pnth; symbolic procedure findpivot cvec; % Finds first non-zero element in CVEC and returns its cell number. % If no such element exists, result is nil. begin scalar i,x; i:=1; x:=getv(cvec,i); while i<ccount and null x do << i:=i+1; x:=getv(cvec,i) >>; if null x then return nil; return i end; symbolic procedure subst4eliminatedcs(neweqn,substorder,ceqns); % Substitutes into NEWEQN for all the C's that have been eliminated so % far. These are given by CEQNS. SUBSTORDER gives the order of % substitution as well as the constant multipliers. Result is the % transformed NEWEQN. if null substorder then neweqn else begin scalar nxt,row,cvar,temp; row:=car ceqns; nxt:=car substorder; if null (cvar:=getv(neweqn,nxt)) then return subst4eliminatedcs(neweqn,cdr substorder,cdr ceqns); nxt:=getv(row,nxt); for i:=0 : ccount do << temp:=!*multf(nxt,getv(neweqn,i)); temp:=addf(temp,negf !*multf(cvar,getv(row,i))); putv(neweqn,i,temp) >>; return subst4eliminatedcs(neweqn,cdr substorder,cdr ceqns) end; symbolic procedure backsubst4cs(cs2subst,cs2solve,cmatrix); % Solves the C-eqns and sets vector CVAL to the C-constant values % CMATRIX is a list of matrix rows for C-eqns after Gaussian % elimination has been performed. CS2SOLVE is a list of the remaining % C's to evaluate and CS2SUBST are the C's we have evaluated already. if null cmatrix then nil else begin scalar eqnn,cvar,already,substlist,temp,temp2; eqnn:=car cmatrix; cvar:=car cs2solve; already:=nil ./ 1; % The S.Q. nil. substlist:=cs2subst; % Now substitute for previously evaluated c's: while not null substlist do << temp:=car substlist; if not null getv(eqnn,temp) then already:=addsq(already,multsq(getv(eqnn,temp) ./ 1, getv(cval,temp))); substlist:=cdr substlist >>; % Now solve for the c given by cvar (any remaining c's assumed zero). temp:=negsq addsq(getv(eqnn,0) ./ 1,already); if not null (temp2:=quotf(numr temp,getv(eqnn,cvar))) then temp:=temp2 ./ denr temp else temp:=multsq(temp,invsq(getv(eqnn,cvar) ./ 1)); if not null numr temp then putv(cval,cvar, resimp rootextractsq subs2q temp); backsubst4cs(reversewoc(cvar . reversewoc cs2subst), cdr cs2solve,cdr cmatrix) end; %********************************************************************** % Routines to deal with linear equations for the constants C. %********************************************************************** symbolic procedure createcmap; %Sets LOGLIST to list of things of form (LOG C-constant f), where f is % function linear in one of the z-variables and C-constant is in S.F. % When creating these C-constant names, the CMAP is also set up and % returned as the result. begin scalar i,l,c; l:=loglist; i:=1; while not null l do << c:=(int!-gensym1('c) . i) . c; i:=i+1; rplacd(car l,((mksp(caar c,1) .* 1) .+ nil) . cdar l); l:=cdr l >>; if !*trint then printc ("Constants Map" . c); return c end; symbolic procedure spreadc(eqnn,cvec1,w); % Sets a vector 'cvec1' to coefficients of c<i> in eqnn. if domainp eqnn then putv(cvec1,0,addf(getv(cvec1,0), !*multf(eqnn,w))) else begin scalar mv,t1,t2; spreadc(red eqnn,cvec1,w); mv:=mvar eqnn; t1:=assoc(mv,cmap); %tests if it is a c var. if not null t1 then return << t1:=cdr t1; %loc in vector for this c. if not (tdeg lt eqnn=1) then interr "Not linear in c eqn"; t2:=addf(getv(cvec1,t1),!*multf(w,lc eqnn)); putv(cvec1,t1,t2) >>; t1:=((lpow eqnn) .* 1) .+ nil; %this main var as sf. spreadc(lc eqnn,cvec1,!*multf(w,t1)) end; symbolic procedure printspreadc cvec1; begin for i:=0 : ccount do << prin2 i; printc ":"; printsf(getv(cvec1,i)) >>; printc "End of printspreadc output" end; %symbolic procedure printvecsq cvec; %% Print contents of cvec which contains s.q.'s (not s.f.'s). %% Starts from cell 1 not 0 as above routine (printspreadc). % begin % for i:=1 : ccount do << % prin2 i; % printc ":"; % if null getv(cvec,i) then printc "0" % else printsq(getv(cvec,i)) >>; % printc "End of printvecsq output" % end; endmodule; module cuberoot; % Cube roots of standard forms. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(cuberootflag); exports cuberootdf; imports contentsmv,gcdf,!*multf,nrootn,partialdiff,printdf,quotf,vp2, mksp,mk!*sq,domainp; symbolic procedure cuberootsq a; cuberootf numr a ./ cuberootf denr a; symbolic procedure cuberootf p; begin scalar ip,qp; if null p then return nil; ip:=cuberootf1 p; qp:=cdr ip; ip:=car ip; %respectable and nasty parts of the cuberoot. if numberp qp and onep qp then return ip; %exact root found. qp:=list('expt,prepf qp,'(quotient 1 3)); cuberootflag:=t; %symbolic cube-root introduced. qp:=(mksp(qp,1).* 1) .+ nil; return !*multf(ip,qp) end; symbolic procedure cuberootf1 p; % Returns a . b with p=a**2*b. % Does this need power reduction? if domainp p then nrootn(p,3) else begin scalar co,ppp,g,pg; co:=contentsmv(p,mvar p,nil); %contents of p. ppp:=quotf(p,co); %primitive part. % now consider ppp=p1*p2**2*p3**3*p4**4*... co:=cuberootf1(co); %process contents via recursion. g:=gcdf(ppp,partialdiff(ppp,mvar ppp)); % g=p2*p3**2*p4**3*... if not domainp g then << pg:=quotf(ppp,g); %pg=p1*p2*p3*p4*... g:=gcdf(g,partialdiff(g,mvar g)); % g=g3*g4**2*g5**3*... g:=gcdf(g,pg)>>; %a triple factor of ppp. if domainp g then pg:=1 . ppp else << pg:=quotf(ppp,!*multf(g,!*multf(g,g))); %what's left. pg:=cuberootf1 pg; %split that up. rplaca(pg,!*multf(car pg,g))>>; %put in the thing found here. rplaca(pg,!*multf(car pg,car co)); rplacd(pg,!*multf(cdr pg,cdr co)); return pg end; endmodule; module idepend; % Routines for considering dependency among variables. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(taylorvariable); exports dependspl,dependsp,involvesq,involvsf; imports taylorp,domainp; symbolic procedure dependsp(x,v); if null v then t else if depends(x,v) then x else if atom x then if x eq v then x else nil else if car x = '!*sq then involvesq(cadr x,v) else if taylorp x then if v eq taylorvariable then taylorvariable else nil else begin scalar w; if x=v then return v; % Check if a prefix form expression depends on the variable v. % Note this assumes the form x is in normal prefix notation; w := x; % preserve the dependency; x := cdr x; % ready to recursively check arguments; scan: if null x then return nil; % no dependency found; if dependsp(car x,v) then return w; x:=cdr x; go to scan end; symbolic procedure involvesq(sq,term); involvesf(numr sq,term) or involvesf(denr sq,term); symbolic procedure involvesf(sf,term); if domainp sf or null sf then nil else dependsp(mvar sf,term) or involvesf(lc sf,term) or involvesf(red sf,term); symbolic procedure dependspl(dep!-list,var); % True if any member of deplist (a list of prefix forms) depends on % var. dep!-list and (dependsp(car dep!-list,var) or dependspl(cdr dep!-list,var)); symbolic procedure taylorp exxpr; % Sees if a random entity is a taylor expression. not atom exxpr and not atom car exxpr and flagp(taylorfunction exxpr,'taylor); endmodule; module df2q; % Conversion from distributive to standard forms. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(indexlist zlist); exports df2q; imports addf,gcdf,mksp,!*multf,quotf; comment We assume that results already have reduced powers, so that no power substitution is necessary; symbolic procedure df2q p; % Converts distributed form P to standard quotient; begin scalar n,d,gg,w; if null p then return nil ./ 1; d:=denr lc p; w:=red p; while not null w do << gg:=gcdf(d,denr lc w); %get denominator of answer... d:=!*multf(d,quotf(denr lc w,gg)); %..as lcm of denoms in input w:=red w >>; n:=nil; %place to build numerator of answer while not null p do << n:=addf(n,!*multf(xl2f(lpow p,zlist,indexlist), !*multf(numr lc p,quotf(d,denr lc p)))); p:=red p >>; return n ./ d end; symbolic procedure xl2f(l,z,il); % L is an exponent list from a D.F., Z is the Z-list, % IL is the list of indices. % Value is L converted to standard form. ; if null z then 1 else if car l=0 then xl2f(cdr l,cdr z,cdr il) else if not atom car l then begin scalar temp; if caar l=0 then temp:= car il else temp:=list('plus,car il,caar l); temp:=mksp(list('expt,car z,temp),1); return !*multf(((temp .* 1) .+ nil), xl2f(cdr l,cdr z,cdr il)) end % else if minusp car l then ; % multsq(invsq (((mksp(car z,-car l) .* 1) .+ nil)), ; % xl2f(cdr l,cdr z,cdr il)) ; else !*multf((mksp(car z,car l) .* 1) .+ nil, xl2f(cdr l,cdr z,cdr il)); endmodule; module distrib; % Routines for manipulating distributed forms. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(indexlist sqrtlist zlist); exports dfprintform,multbyarbpowers,negdf,quotdfconst,sub1ind,vp1, vp2,plusdf,multdf,multdfconst,orddf; imports interr,addsq,negsq,exptsq,simp,domainp,mk!*sq,addf, multsq,invsq,minusp,mksp,sub1; %*********************************************************************** % NOTE: The expressions lt,red,lc,lpow have been used on distributed % forms as the latter's structure is sufficiently similar to % s.f.'s. However lc df is a s.q. not a s.f. and lpow df is a % list of the exponents of the variables. This also makes % lt df different. Red df is d.f. as expected. %**********************************************************************; symbolic procedure plusdf(u,v); % U and V are D.F.'s. Value is D.F. for U+V; if null u then v else if null v then u else if lpow u=lpow v then (lambda(x,y); if null numr x then y else (lpow u .* x) .+ y) (!*addsq(lc u,lc v),plusdf(red u,red v)) else if orddf(lpow u,lpow v) then lt u .+ plusdf(red u,v) else (lt v) .+ plusdf(u,red v); symbolic procedure orddf(u,v); % U and V are the LPOW of a D.F. - i.e. the list of exponents ; % Value is true if LPOW U '>' LPOW V and false otherwise ; if null u then if null v then interr "Orddf = case" else interr "Orddf v longer than u" else if null v then interr "Orddf u longer than v" else if exptcompare(car u,car v) then t else if exptcompare(car v,car u) then nil else orddf(cdr u,cdr v); symbolic procedure exptcompare(x,y); if atom x then if atom y then x>y else nil else if atom y then t else car x > car y; symbolic procedure negdf u; if null u then nil else (lpow u .* negsq lc u) .+ negdf red u; symbolic procedure multdf(u,v); % U and V are D.F.'s. Value is D.F. for U*V; % reduces squares of square-roots as it goes; if null u or null v then nil else begin scalar y; %use (a+b)*(c+d) = (a*c) + a*(c+d) + b*(c+d); y:=multerm(lt u,lt v); %leading terms; y:=plusdf(y,multdf(red u,v)); y:=plusdf(y,multdf((lt u) .+ nil,red v)); return y end; symbolic procedure multerm(u,v); %multiply two terms to give a D.F.; begin scalar coef; coef:=!*multsq(cdr u,cdr v); %coefficient part; return multdfconst(coef,mulpower(car u,car v)) end; symbolic procedure mulpower(u,v); % u and v are exponent lists. multiply corresponding forms; begin scalar r,s; r:=addexptsdf(u,v); if not null sqrtlist then s:=reduceroots(r,zlist); r:=(r .* (1 ./ 1)) .+ nil; if not (s=nil) then r:=multdf(r,s); return r end; symbolic procedure reduceroots(r,zl); begin scalar s; while not null r do << if eqcar(car zl,'sqrt) then s:=tryreduction(r,car zl,s); r:=cdr r; zl:=cdr zl >>; return s end; symbolic procedure tryreduction(r,var,s); begin scalar x; x:=car r; %current exponent if not atom x then << r:=x; x:=car r >>; %numeric part if (x=0) or (x=1) then return s; %no reduction possible x:=divide(x,2); rplaca(r,cdr x); %reduce exponent as redorded x:=car x; var:=simp cadr var; %sqrt arg as a s q var:=!*exptsq(var,x); x:=multdfconst(1 ./ denr var,f2df numr var); %distribute if s=nil then s:=x else s:=multdf(s,x); return s end; symbolic procedure addexptsdf(x,y); % X and Y are LPOW's of D.F. Value is list of sum of exponents; if null x then if null y then nil else interr "X too long" else if null y then interr "Y too long" else exptplus(car x,car y).addexptsdf(cdr x,cdr y); symbolic procedure exptplus(x,y); if atom x then if atom y then x+y else list (x+car y) else if atom y then list (car x +y) else interr "Bad exponent sum"; symbolic procedure multdfconst(x,u); % X is S.Q. not involving Z variables of D.F. U. Value is D.F.; % for X*U; if (null u) or (null numr x) then nil else lpow u .* !*multsq(x,lc u) .+ multdfconst(x,red u); %symbolic procedure quotdfconst(x,u); % multdfconst(!*invsq x,u); symbolic procedure f2df p; % P is standard form. Value is P in D.F.; if domainp p then dfconst(p ./ 1) else if mvar p member zlist then plusdf(multdf(vp2df(mvar p,tdeg lt p,zlist),f2df lc p), f2df red p) else plusdf(multdfconst(((lpow p .* 1) .+ nil) ./ 1,f2df lc p), f2df red p); symbolic procedure vp1(var,degg,z); % Takes VAR and finds it in Z (=list), raises it to power DEGG and puts % the result in exponent list form for use in a distributed form. if null z then interr "Var not in z-list after all" else if var=car z then degg.vp2 cdr z else 0 . vp1(var,degg,cdr z); symbolic procedure vp2 z; % Makes exponent list of zeroes. if null z then nil else 0 . vp2 cdr z; symbolic procedure vp2df(var,exprn,z); % Makes VAR**EXPRN into exponent list and then converts the resulting % power into a distributed form. % Special care with square-roots. if eqcar(var,'sqrt) and (exprn>1) then mulpower(vp1(var,exprn,z),vp2 z) else (vp1(var,exprn,z) .* (1 ./ 1)) .+ nil; symbolic procedure dfconst q; % Makes a distributed form from standard quotient constant Q; if numr q=nil then nil else ((vp2 zlist) .* q) .+ nil; %df2q moved to a section of its own. symbolic procedure df2printform p; %Convert to a standard form good enough for printing. if null p then nil else begin scalar mv,co; mv:=xl2q(lpow p,zlist,indexlist); if mv=(1 ./ 1) then << co:=lc p; if denr co=1 then return addf(numr co, df2printform red p); co:=mksp(mk!*sq co,1); return (co .* 1) .+ df2printform red p >>; co:=lc p; if not (denr co=1) then mv:=!*multsq(mv,1 ./ denr co); mv:=mksp(mk!*sq mv,1) .* numr co; return mv .+ df2printform red p end; symbolic procedure xl2q(l,z,il); % L is an exponent list from a D.F.,Z is the Z-list, IL is the list of % indices. Value is L converted to standard quotient. ; if null z then 1 ./ 1 else if car l=0 then xl2q(cdr l,cdr z,cdr il) else if not atom car l then begin scalar temp; if caar l=0 then temp:= car il else temp:=list('plus,car il,caar l); temp:=mksp(list('expt,car z,temp),1); return !*multsq(((temp .* 1) .+ nil) ./ 1, xl2q(cdr l,cdr z,cdr il)) end else if minusp car l then !*multsq(!*invsq(((mksp(car z,-car l) .* 1) .+ nil) ./ 1), xl2q(cdr l,cdr z,cdr il)) else !*multsq(((mksp(car z,car l) .* 1) .+ nil) ./ 1, xl2q(cdr l,cdr z,cdr il)); %symbolic procedure sub1ind power; % if atom power then power-1 % else list sub1 car power; symbolic procedure multbyarbpowers u; % Multiplies the ordinary D.F., U, by arbitrary powers % of the z-variables; % i-1 j-1 k-1 % i.e. x z z ... so result is D.F. with the exponent list % 1 2 %appropriately altered to contain list elements instead of numeric ones. if null u then nil else ((addarbexptsdf lpow u) .* lc u) .+ multbyarbpowers red u; symbolic procedure addarbexptsdf x; % Adds the arbitrary powers to powers in exponent list, X, to produce % new exponent list. e.g. 3 -> (2) to represent x**3 now becoming : % 3 i-1 i+2 ; % x * x = x . ; if null x then nil else list exptplus(car x,-1) . addarbexptsdf cdr x; endmodule; module divide; % Exact division of standard forms to give a S Q. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(residue sqrtlist zlist); global '(!*trdiv !*trint); exports fquotf,testdivdf,dfquotdf; imports df2q,f2df,gcdf,interr,multdf,negdf,plusdf,printdf,printsf, quotf,multsq,invsq,negsq; % Intended for dividing out known factors as produced by the % integration program. horrible and slow, i expect!! symbolic procedure dfquotdf(a,b); begin scalar residue; if (!*trint or !*trdiv) then << printc "Dfquotdf called on "; printdf a; printdf b>>; a:=dfquotdf1(a,b); if (!*trint or !*trdiv) then << printc "Quotient given as "; printdf a >>; if not null residue then begin scalar gres,w; if !*trint or !*trdiv then << printc "Residue in dfquotdf ="; printdf residue; printc "Which should be zero"; w:=residue; gres:=numr lc w; w:=red w; while not null w do << gres:=gcdf(gres,numr lc w); w:=red w >>; printc "I.e. the following vanishes"; printsf gres>>; interr "Non-exact division due to a log term" end; return a end; symbolic procedure fquotf(a,b); % Input: a and b standard quotients with (a/b) an exact % division with respect to the variables in zlist, % but not necessarily obviously so. the 'non-obvious' problems % will be because of (e.g.) square-root symbols in b % output: standard quotient for (a/b) % (prints message if remainder is not 'clearly' zero. % A must not be zero. begin scalar t1; if null a then interr "A=0 in fquotf"; t1:=quotf(a,b); %try it the easy way if not null t1 then return t1 ./ 1; %ok return df2q dfquotdf(f2df a,f2df b) end; symbolic procedure dfquotdf1(a,b); begin scalar q; if null b then interr "Attempt to divide by zero"; q:=sqrtlist; %remove sqrts from denominator, maybe. while not null q do begin scalar conj; conj:=conjsqrt(b,car q); %conjugate wrt given sqrt if not (b=conj) then << a:=multdf(a,conj); b:=multdf(b,conj) >>; q:=cdr q end; q:=dfquotdf2(a,b); residue:=reversewoc residue; return q end; symbolic procedure dfquotdf2(a,b); % As above but a and b are distributed forms, as is the result. if null a then nil else begin scalar xd,lcd; xd:=xpdiff(lpow a,lpow b); if xd='failed then << xd:=lt a; a:=red a; residue:=xd .+ residue; return dfquotdf2(a,b) >>; lcd:= !*multsq(lc a,!*invsq lc b); if null numr lcd then return dfquotdf2(red a,b); % Should not be necessary; lcd := xd .* lcd; xd:=plusdf(a,multdf(negdf (lcd .+ nil),b)); if xd and (lpow xd = lpow a % Again, should not be necessary; or xpdiff(lpow xd,lpow b) = 'failed) then <<if !*trint or !*trdiv then <<printc "Dfquotdf trouble:"; printdf xd>>; xd := rootextractdf xd; if !*trint or !*trdiv then printdf xd>>; return lcd .+ dfquotdf2(xd,b) end; symbolic procedure rootextractdf u; if null u then nil else begin scalar v; v := resimp rootextractsq lc u; return if null numr v then rootextractdf red u else (lpow u .* v) .+ rootextractdf red u end; symbolic procedure rootextractsq u; if null numr u then u else rootextractf numr u ./ rootextractf denr u; symbolic procedure rootextractf v; if domainp v then v else begin scalar u,r,c,x,p; u := mvar v; p := ldeg v; r := rootextractf red v; c := rootextractf lc v; if null c then return r else if atom u then return (lpow v .* c) .+ r else if car u eq 'sqrt or car u eq 'expt and eqcar(caddr u,'quotient) and car cdaddr u = 1 and numberp cadr cdaddr u then <<p := divide(p,if car u eq 'sqrt then 2 else cadr cdaddr u); if car p = 0 then return if null c then r else (lpow v .* c) .+ r else if numberp cadr u then <<c := multd(cadr u ** car p,c); p := cdr p>> else <<x := simpexpt list(cadr u,car p); if denr x = 1 then <<c := multf(numr x,c); p := cdr p>>>>>>; return if p=0 then addf(c,r) else if null c then r else ((u to p) .* c) .+ r end; % The following hack makes sure that the results of differentiation % gets passed through ROOTEXTRACT % a) This should not be done this way, since the effect is global % b) Should this be done via TIDYSQRT? put('df,'simpfn,'simpdf!*); symbolic procedure simpdf!* u; begin scalar v,v1; v:=simpdf u; v1:=rootextractsq v; if not(v1=v) then return resimp v1 else return v end; symbolic procedure xpdiff(a,b); %Result is list a-b, or 'failed' if a member of this would be negative. if null a then if null b then nil else interr "B too long in xpdiff" else if null b then interr "A too long in xpdiff" else if car b>car a then 'failed else (lambda r; if r='failed then 'failed else (car a-car b) . r) (xpdiff(cdr a,cdr b)); symbolic procedure conjsqrt(b,var); % Subst(var=-var,b). if null b then nil else conjterm(lpow b,lc b,var) .+ conjsqrt(red b,var); symbolic procedure conjterm(xl,coef,var); % Ditto but working on a term. if involvesp(xl,var,zlist) then xl .* negsq coef else xl .* coef; symbolic procedure involvesp(xl,var,zl); % Check if exponent list has non-zero power for variable. if null xl then interr "Var not found in involvesp" else if car zl=var then (not zerop car xl) else involvesp(cdr xl,var,cdr zl); endmodule; module driver; % Driving routines for integration program. % Author: Mary Ann Moore and Arthur C. Norman. % Modifications by: John P. Fitch. fluid '(!*backtrace !*exp !*gcd !*keepsqrts !*mcd !*nolnr !*purerisch !*rationalize !*sqrt !*structure !*uncached basic!-listofnewsqrts basic!-listofallsqrts expression gaussiani intvar listofnewsqrts listofallsqrts loglist sqrt!-intvar sqrt!-places!-alist variable varlist xlogs zlist); global '(!*algint !*failhard !*trint); exports integratesq,simpint,purge,simpint1; imports algebraiccase,algfnpl,findzvars,getvariables,interr,printsq, transcendentalcase,varsinlist,kernp,simpcar,prepsq,mksq,simp, opmtch,formlnr; switch algint,nolnr,trint; % Form is int(expr,var,x1,x2,...); % meaning is integrate expr wrt var, given that the result may % contain logs of x1,x2,... % x1, etc are intended for use when the system has to be helped % in the case that expr is algebraic. % Extended arguments x1, x2, etc., are not currently supported. symbolic procedure simpint u; % Simplifies an integral. First two components of U are the integrand % and integration variable respectively. Optional succeeding components % are log forms for the final integral; begin scalar ans,expression,variable,loglist,w, !*purerisch,intvar,listofnewsqrts,listofallsqrts, sqrtfn,sqrt!-intvar,sqrt!-places!-alist, basic!-listofallsqrts,basic!-listofnewsqrts; if atom u or null cdr u then rederr "Not enough arguments for INT"; variable := !*a2k cadr u; w := cddr u; if w then rederr "Too many arguments to INT"; listofnewsqrts:= list mvar gaussiani; % Initialize for SIMPSQRT. listofallsqrts:= list (argof mvar gaussiani . gaussiani); sqrtfn := get('sqrt,'simpfn); put('sqrt,'simpfn,'proper!-simpsqrt); % We need explicit settings of several switches during integral % evaluation. In addition, the current code cannot handle domains % like floating point, so we suppress it while the integral is % calculated. UNCACHED is turned on since integrator does its own % caching. begin scalar dmode!*,!*exp,!*gcd,!*keepsqrts,!*mcd,!*sqrt, !*rationalize,!*structure,!*uncached; !*keepsqrts := !*sqrt := t; !*exp := !*gcd := !*mcd := !*structure := !*uncached := t; dmode!* := nil; if !*algint then <<intvar:=variable; % until fix JHD code % Start a clean slate (in terms of SQRTSAVE) for this integral sqrt!-intvar:=!*q2f simpsqrti variable; if (red sqrt!-intvar) or (lc sqrt!-intvar neq 1) or (ldeg sqrt!-intvar neq 1) then interr "Sqrt(x) not properly formed" else sqrt!-intvar:=mvar sqrt!-intvar; basic!-listofallsqrts:=listofallsqrts; basic!-listofnewsqrts:=listofnewsqrts; sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts, list(variable . variable))>>; expression := int!-simp car u; % loglist := for each x in w collect int!-simp x; ans := errorset('(integratesq expression variable loglist), !*backtrace,!*backtrace); end; if errorp ans then return <<put('sqrt,'simpfn,sqrtfn); if !*failhard then error1(); simpint1(expression . variable . w)>> else ans := car ans; expression := sqrtchk numr ans ./ sqrtchk denr ans; % We now need to check that all simplifications have been done % but we have to make sure INT is not resimplified. put('int,'simpfn,'simpiden); ans := errorset('(resimp expression),t,!*backtrace); put('int,'simpfn,'simpint); put('sqrt,'simpfn,sqrtfn); return if errorp ans then error1() else car ans end; symbolic procedure sqrtchk u; % U is a standard form. Result is another standard form with square % roots replaced by half powers. if domainp u then u else if not eqcar(mvar u,'sqrt) then addf(multpf(lpow u,sqrtchk lc u),sqrtchk red u) else addf(multpf(mksp(list('expt,cadr mvar u,'(quotient 1 2)), ldeg u), sqrtchk lc u), sqrtchk red u); symbolic procedure int!-simp u; %converts U to canonical form, including the resimplification of % *sq forms; subs2 resimp simp!* u; put('int,'simpfn,'simpint); symbolic procedure integratesq(integrand,var,xlogs); begin scalar varlist,zlist; if !*trint then << printc "Integrand is..."; printsq integrand >>; varlist:=getvariables integrand; varlist:=varsinlist(xlogs,varlist); %in case more exist in xlogs zlist:=findzvars(varlist,list var,var,nil); %important kernels %the next section causes problems with nested exponentials or logs; begin scalar oldzlist; while oldzlist neq zlist do << oldzlist:=zlist; foreach zz in oldzlist do zlist:=findzvars(distexp(pseudodiff(zz,var)),zlist,var,t)>> end; if !*trint then << printc "with 'new' functions :"; print zlist >>; if !*purerisch and not allowedfns zlist then return simpint1 (integrand . var.nil); % If it is not suitable for Risch; varlist:=purge(zlist,varlist); % Now zlist is list of things that depend on x, and varlist is list % of constant kernels in integrand; if !*algint and cdr zlist and algfnpl(zlist,var) then return algebraiccase(integrand,zlist,varlist) else return transcendentalcase(integrand,var,xlogs,zlist,varlist) end; symbolic procedure distexp(l); if null l then nil else if atom car l then car l . distexp cdr l else if (caar l = 'expt) and (cadar l = 'e) then begin scalar ll; ll:=caddr car l; if eqcar(ll,'plus) then << ll:=foreach x in cdr ll collect list('expt,'e,x); return ('times . ll) . distexp cdr l >> else return car l . distexp cdr l end else distexp car l . distexp cdr l; symbolic procedure pseudodiff(a,var); if atom a then nil else if car a memq '(atan equal log plus quotient sqrt times) then begin scalar aa,bb; foreach zz in cdr a do << bb:=pseudodiff(zz,var); if aa then aa:=bb . aa else bb >>; return aa end else if car a eq 'expt then if depends(cadr a,var) then prepsq simp list('log,cadr a) . cadr a . caddr a . append(pseudodiff(cadr a,var),pseudodiff(caddr a,var)) else caddr a . pseudodiff(caddr a,var) else list prepsq simpdf(list(a,var)); symbolic procedure simpint1 u; begin scalar v,!*sqrt; u := 'int . prepsq car u . cdr u; if (v := formlnr u) neq u then if !*nolnr then <<v:= simp subst('int!*,'int,v); return remakesf numr v ./ remakesf denr v>> else <<!*nolnr:= nil . !*nolnr; u:=errorset(list('simp,mkquote v), !*backtrace,!*backtrace); if pairp u then v:=car u; !*nolnr:= cdr !*nolnr; return v>>; return if (v := opmtch u) then simp v else if !*failhard then rederr "FAILHARD switch set" else mksq(u,1) end; mkop 'int!*; put('int!*,'simpfn,'simpint!*); symbolic procedure simpint!* u; begin scalar x; return if (x := opmtch('int . u)) then simp x else simpiden('int!* . u) end; symbolic procedure remakesf u; %remakes standard form U, substituting operator INT for INT!*; if domainp u then u else addf(multpf(if eqcar(mvar u,'int!*) then mksp('int . cdr mvar u,ldeg u) else lpow u,remakesf lc u), remakesf red u); symbolic procedure allowedfns u; if null u then t else if atom car u or flagp(caar u,'transcendental) then allowedfns cdr u else nil; symbolic procedure purge(a,b); if null a then b else if null b then nil else purge(cdr a,delete(car a,b)); endmodule; module d3d4; % Splitting of cubics and quartics. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(knowndiscrimsign zlist); global '(!*trint); exports cubic,quartic; imports covecdf,cuberootf,nth,forceazero,makepolydf,multdf,multdfconst, !*multf,negdf,plusdf,printdf,printsf,quadratic,sqrtf,vp1,vp2,addf, negf; symbolic procedure cubic(pol,var,res); %Split the univariate (wrt z-vars) cubic pol, at least if a %change of origin puts it in the form (x-a)**3-b=0; begin scalar a,b,c,d,v,shift,p; v:=covecdf(pol,var,3); shift:=forceazero(v,3); %make coeff x**2 vanish. %also checks univariate. % if shift='failed then go to prime; a:=getv(v,3); b:=getv(v,2); %=0, I hope!; c:=getv(v,1); d:=getv(v,0); if !*trint then << printc "Cubic has coefficients"; printsf a; printsf b; printsf c; printsf d >>; if not null c then << if !*trint then printc "Cubic too hard to split"; go to exit >>; a:=cuberootf(a); %can't ever fail; d:=cuberootf(d); if !*trint then << printc "Cube roots of a and d are"; printsf a; printsf d>>; %now a*(x+shift)+d is a factor of pol; %create x+shift in p; p:=(vp2 zlist .* shift) .+ nil; p:=(vp1(var,1,zlist) .* (1 ./ 1)) .+ p; %(x+shift); b:=nil; b:=(vp2 zlist .* (d ./ 1)) .+ b; b:=plusdf(b,multdfconst(a ./ 1,p)); b:=makepolydf b; %get rid of denominator. if !*trint then << printc "One factor of the cubic is"; printdf b >>; res:=('log . b) . res; %now form the (quadratic) cofactor; b:=(vp2 zlist .* (!*multf(d,d) ./ 1)) .+ nil; b:=plusdf(b,multdfconst(negf !*multf(a,d) ./ 1,p)); b:=plusdf(b,multdfconst(!*multf(a,a) ./ 1, multdf(p,p))); return quadratic(makepolydf b,var,res); %deal with what is left; prime: if !*trint then printc "The following cubic does not split"; exit: if !*trint then printdf pol; return ('log . pol) . res end; symbolic procedure quartic(pol,var,res); %Splits univariate (wrt z-vars) quartics that can be written %in the form (x-a)**4+b*(x-a)**2+c; begin scalar a,b,c,d,ee,v,shift,p,q,p1,p2,dsc; v:=covecdf(pol,var,4); shift:=forceazero(v,4); %make coeff x**3 vanish; % if shift='failed then go to prime; a:=getv(v,4); b:=getv(v,3); %=0, I hope. c:=getv(v,2); d:=getv(v,1); ee:=getv(v,0); if !*trint then << printc "Quartic has coefficients"; printsf a; printsf b; printsf c; printsf d; printsf ee >>; if d then <<if !*trint then printc "Quartic too hard to split"; go to exit >>; b:=c; c:=ee; %squash up the notation; if knowndiscrimsign eq 'negative then go to complex; dsc := addf(!*multf(b,b),multf(-4,!*multf(a,c))); p2 := minusf c; if not p2 and minusf dsc then go to complex; p1 := null b or minusf b; if not p1 then if p2 then p1 := t else p2 := t; p1 := if p1 then 'positive else 'negative; p2 := if p2 then 'negative else 'positive; a := sqrtf a; dsc := sqrtf dsc; if a eq 'failed or dsc eq 'failed then go to prime; ee := invsq(addf(a,a) ./ 1); d := multsq(addf(b,negf dsc) ./ 1,ee); ee := multsq(addf(b,dsc) ./ 1,ee); if !*trint then <<printc "Quadratic factors will have coefficients"; printsf a; print 0; printsq d; printc "or"; printsq ee>>; p := (vp2 zlist .* shift) .+ nil; p := (vp1(var,1,zlist) .* (1 ./ 1)) .+ p; %(x+shift); q := multdf(p,p); %square of same; q := multdfconst(a ./ 1,q); p := plusdf(q,(vp2 zlist .* d) .+ nil); q := plusdf(q,(vp2 zlist .* ee) .+ nil); if !*trint then <<printc "Allowing for change of origin:"; printdf p; printdf q>>; knowndiscrimsign := p1; res := quadratic(p,var,res); knowndiscrimsign := p2; res := quadratic(q,var,res); go to quarticdone; complex: a:=sqrtf(a); c:=sqrtf(c); if a eq 'failed or c eq 'failed then go to prime; b:=addf(!*multf(2,!*multf(a,c)),negf b); b:=sqrtf b; if b eq 'failed then go to prime; %now a*(x+shift)**2 (+/-) b*(x+shift) + c is a factor. if !*trint then << printc "Quadratic factors will have coefficients"; printsf a; printsf b; printsf c>>; p:=(vp2 zlist .* shift) .+ nil; p:=(vp1(var,1,zlist) .* (1 ./ 1)) .+ p; %(x+shift); q:=multdf(p,p); %square of same; p:=multdfconst(b ./ 1,p); q:=multdfconst(a ./ 1,q); q:=plusdf(q,(vp2 zlist .* (c ./ 1)) .+ nil); if !*trint then << printc "Allowing for change of origin, p (+/-) q with p,q="; printdf p; printdf q>>; %now p+q and p-q are the factors of the quartic; knowndiscrimsign := 'negative; res:=quadratic(plusdf(q,p),var,res); res:=quadratic(plusdf(q,negdf p),var,res); quarticdone: knowndiscrimsign := nil; if !*trint then printc "Quartic done"; return res; prime: if !*trint then printc "The following quartic does not split"; exit: if !*trint then printdf pol; return ('log . pol) . res end; endmodule; module factr; % Crude factorization routine for integrator. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(zlist); global '(!*trint); exports int!-fac,var2df; imports cubic,df2q,f2df,interr,multdf,printdf,quadratic,quartic,unifac, uniform,vp1,vp2,sub1; symbolic procedure int!-fac x; % Input: primitive, square-free polynomial (s.form). %output: % list of 'factors' wrt zlist % each item in this list is either % log . sq % or atan . sq % and these logs and arctans are all that is needed in the % integration of 1/(argument). begin scalar res,pol,dset,var,degree,vars; pol:=f2df x; %convert to distributed form dset:=degreeset(pol); %now extract factors of the form 'x' or 'log(x)' etc; %these correspond to items in dset with a non-zero cdr. begin scalar zl,ds; zl:=zlist; ds:=dset; while not null ds do << if onep cdar ds then << res:=('log . var2df(car zl,1,zlist)) . res; %record in answer. pol:=multdf(var2df(car zl,-1,zlist),pol); %divide out. if !*trint then << printc "Trivial factor found"; printdf cdar res>>; rplaca(ds,sub1 caar ds . cdar ds) >> else if null zerop cdar ds then interr "Repeated trivial factor in arg to factor"; zl:=cdr zl; ds:=cdr ds >>; end; %single term factors all removed now. dset:=mapcar(dset,function car); %get lower bounds. if !*trint then printc ("Upper bounds of remaining factors are now: " . dset); if dset=vp2 zlist then go to finished; %thing left is constant. begin scalar ds,zl; var:=car zlist; degree:=car dset; if not zerop degree then vars:=var . vars; ds:=cdr dset; zl:=cdr zlist; while not null ds do << if not zerop car ds then << vars:=car zl . vars; if zerop degree or degree>car ds then << var:=car zl; degree:=car ds >> >>; zl:=cdr zl; ds:=cdr ds >> end; % Now var is variable that this poly involves to lowest degree. % Degree is the degree of the poly in same variable. if !*trint then printc ("Best var is " . var . "with exponent " . degree); if onep degree then << res:=('log . pol) . res; %certainly irreducible. if !*trint then << printc "The following is certainly irreducible"; printdf pol>>; go to finished >>; if degree=2 then << if !*trint then << printc "Quadratic"; printdf pol>>; res:=quadratic(pol,var,res); go to finished >>; dset:=uniform(pol,var); if not (dset='failed) then << if !*trint then << printc "Univariate polynomial"; printdf pol >>; res:=unifac(dset,var,degree,res); go to finished >>; if not null cdr vars then go to nasty; %only try univariate now. if degree=3 then << if !*trint then << printc "Cubic"; printdf pol>>; res:=cubic(pol,var,res); % if !*overlaymode then excise 'd3d4; go to finished >>; if degree=4 then << if !*trint then << printc "Quartic"; printdf pol>>; res:=quartic(pol,var,res); % if !*overlaymode then excise 'd3d4; go to finished>>; %else abandon hope and hand back some rubbish. nasty: res:=('log . pol) . res; printc "The following polynomial has not been properly factored"; printdf pol; go to finished; finished: %res is a list of d.f. s as required pol:=nil; %convert back to standard forms while not null res do begin scalar type,arg; type:=caar res; arg:=cdar res; arg:=df2q arg; if type='log then rplacd(arg,1); pol:=(type . arg) . pol; res:=cdr res end; return pol end; symbolic procedure var2df(var,n,zlist); ((vp1(var,n,zlist) .* (1 ./ 1)) .+ nil); symbolic procedure degreeset pol; % Finds degree bounds for all vars in distributed form poly. degreesub(dbl lpow pol,red pol); symbolic procedure dbl x; % Converts list of x into list of (x . x). if null x then nil else (car x . car x) . dbl cdr x; symbolic procedure degreesub(cur,pol); % Update degree bounds 'cur' to include info about pol. << while not null pol do << cur:=degreesub1(cur,lpow pol); pol:=red pol >>; cur >>; symbolic procedure degreesub1(cur,nxt); %Merge information from exponent set next into cur. if null cur then nil else degreesub2(car cur,car nxt) . degreesub1(cdr cur,cdr nxt); symbolic procedure degreesub2(two,one); max(car two,one) . min(cdr two,one); endmodule; module ibasics; % Some basic support routines for integrator. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(!*backtrace !*gcd !*sqfree indexlist sqrtflag sqrtlist varlist zlist); global '(!*trint); exports partialdiff,printdf,rationalintegrate,interr; imports df2printform,printsf,varsinsf,addsq,multsq,multd,mksp; symbolic procedure printdf u; % Print distributed form via cheap conversion to reduce structure. begin scalar !*gcd; printsf df2printform u; end; symbolic procedure !*n2sq(u1); if u1=0 then nil . 1 else u1 . 1; symbolic procedure indx(n); if n<2 then (list 1) else(n . indx(isub1 n)); symbolic procedure interr mess; <<(!*trint or !*backtrace) and <<prin2 "***** INTEGRATION PACKAGE ERROR: "; printc mess>>; error1()>>; symbolic procedure rationalintegrate(x,var); begin scalar n,d; n:=numr x; d:=denr x; if not var member varsinsf(d,nil) then return !*multsq(polynomialintegrate(n,var),1 ./ d); rederr "Rational integration not coded yet" end; symbolic procedure polynomialintegrate(x,v); % Integrate standard form. result is standard quotient. if null x then nil ./ 1 else if atom x then ((mksp(v,1) .* 1) .+ nil) ./ 1 else begin scalar r; r:=polynomialintegrate(red x,v); % deal with reductum if v=mvar x then begin scalar degree,newlt; degree:=1+tdeg lt x; newlt:=((mksp(v,degree) .* lc x) .+ nil) ./ 1; % up exponent r:=addsq(!*multsq(newlt,1 ./ degree),r) end else begin scalar newterm; newterm:=(((lpow x) .* 1) .+ nil) ./ 1; newterm:=!*multsq(newterm,polynomialintegrate(lc x,v)); r:=addsq(r,newterm) end; return r end; symbolic procedure partialdiff(p,v); % Partial differentiation of p wrt v - p is s.f. as is result. if domainp p then nil else if v=mvar p then (lambda x; if x=1 then lc p else ((mksp(v,x-1) .* multd(x,lc p)) .+ partialdiff(red p,v))) (tdeg lt p) else (lambda x; if null x then partialdiff(red p,v) else ((lpow p .* x) .+ partialdiff(red p,v))) (partialdiff(lc p,v)); put('pdiff,'simpfn,'simppdiff); symbolic procedure ncdr(l,n); % we can use small integer arithmetic here. if n=0 then l else ncdr(cdr l,isub1 n); symbolic procedure mkilist(old,term); if null old then nil else term.mkilist(cdr old,term); %symbolic procedure addin(lista,first,listb); %if null lista % then nil % else ((first.car listb).car lista).addin(cdr lista,first,cdr listb); symbolic procedure removeduplicates(u); % Purges duplicates from the list passed to it. if null u then nil else if (atom u) then u.nil else if member(car u,cdr u) then removeduplicates cdr u else (car u).removeduplicates cdr u; symbolic procedure jsqfree(sf,var); begin varlist:=getvariables(sf ./ 1); zlist:=findzvars(varlist,list var,var,nil); sqrtlist:=findsqrts varlist; % before the purge sqrtflag:=not null sqrtlist; varlist:=purge(zlist,varlist); if sf eq !*sqfree then return list list sf else return sqfree(sf,zlist) end; symbolic procedure jfactor(sf,var); begin scalar varlist,zlist,indexlist,sqrtlist,sqrtflag; scalar prim,answer,u,v; % scalar var2 prim:=jsqfree(sf,var); indexlist:=createindices zlist; prim:=factorlistlist (prim,t); while prim do << if caar prim eq 'log then << u:=cdar prim; u:=!*multsq(numr u ./ 1,1 ./ cdr stt(numr u,var)); v:=denr u; while not atom v do v:=lc v; if (numberp v) and (0> v) then u:=(negf numr u) ./ (negf denr u); answer:=u.answer >> else if caar prim eq 'atan then << % We can ignore this, since we also get LOG (U**2+1) as another term. >> else interr "Unexpected term in jfactor"; prim:=cdr prim >>; return answer end; symbolic procedure stt(u,x); if domainp u then if u eq nil then ((-1) . nil) else (0 . u) else if mvar u eq x then ldeg u . lc u else if ordop(x,mvar u) then (0 . u) else begin scalar ltlc,ltrest; ltlc:=stt(lc u,x); ltrest:= stt(red u,x); if car ltlc = car ltrest then go to merge; if car ltlc > car ltrest then return car ltlc . !*multf(cdr ltlc,(lpow u .* 1) .+ nil) else return ltrest; merge: return car ltlc.addf(cdr ltrest, !*multf(cdr ltlc,(lpow u .* 1) .+ nil)) end; symbolic procedure gcdinonevar(u,v,x); % Gcd of u and v, regarded as polynnmials in x. if null u then v else if null v then u else begin scalar u1,v1,z,w; u1:=stt(u,x); v1:=stt(v,x); loop: if (car u1) > (car v1) then go to ok; z:=u1;u1:=v1;v1:=z; z:=u;u:=v;v:=z; ok: if car v1 iequal 0 then interr "Coprimeness in gcd"; z:=gcdf(cdr u1,cdr v1); w:=quotf(cdr u1,z); if (car u1) neq (car v1) then w:=!*multf(w,!*p2f mksp(x,(car u1)-(car v1))); u:=addf(!*multf(v,w), !*multf(u,negf quotf(cdr v1,z))); if null u then return v; u1:=stt(u,x); go to loop end; symbolic procedure mapply(funct,l); if null l then rederr "Empty list to mapply" else if null cdr l then car l else apply(funct,list(car l,mapply(funct,cdr l))); symbolic procedure !*lcm!*(u,v); !*multf(u,quotf(v,gcdf(u,v))); symbolic procedure multsql(u,l); % Multiplies (!*multsq) each element of l by u. if null l then nil else !*multsq(u,car l).multsql(u,cdr l); symbolic procedure intersect(x,y); if null x then nil else if member(car x,y) then car(x) . intersect(cdr x,y) else intersect(cdr x,y); symbolic procedure mapvec(v,f); begin scalar n; n:=upbv v; for i:=0:n do apply(f,list getv(v,i)) end; endmodule; module jpatches; % Routines for manipulating sf's with power folding. % Author: James H. Davenport. fluid '(sqrtflag); exports !*addsq,!*multsq,!*invsq,!*multf,squashsqrtsq,!*exptsq,!*exptf; % !*MULTF(A,B) multiplies the polynomials (standard forms) U and V % in much the same way as MULTF(U,V) would, EXCEPT... % (1) !*MULTF inhibits the action of OFF EXP and of non-commutative % multiplications % (2) Within !*MULTF powers of square roots, and powers of % exponential kernels are reduced as if substitution rules % such as FOR ALL X LET SQRT(X)**2=X were being applied; % Note that !*MULTF comes between MULTF and !*Q2F SUBS2F MULTF in its % behaviour, and that it is the responsibility of the user to call it % in sensible places where its services are needed; % similarly for the other functions defined here; %symbolic procedure !*addsq(u,v); %U and V are standard quotients. % %Value is canonical sum of U and V; % if null numr u then v % else if null numr v then u % else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1 % else begin scalar nu,du,nv,dv,x; % x := gcdf(du:=denr u,dv:=denr v); % du:=quotf(du,x); dv:=quotf(dv,x); % nu:=numr u; nv:=numr v; % u:=addf(!*multf(nu,dv),!*multf(nv,du)); % if u=nil then return nil ./ 1; % v:=!*multf(du,denr v); % return !*ff2sq(u,v) % end; %symbolic procedure !*multsq(a,b); % begin % scalar n,d; % n:=!*multf(numr a,numr b); % d:=!*multf(denr a,denr b); % return !*ff2sq(n,d) % end; %symbolic procedure !*ff2sq(a,b); % begin % scalar gg; % if null a then return nil ./ 1; % gg:=gcdf(a,b); % if not (gg=1) then << % a:=quotf(a,gg); % b:=quotf(b,gg) >>; % if minusf b then << % a:=negf a; % b:=negf b >>; % return a ./ b % end; symbolic procedure !*addsq(u,v); %U and V are standard quotients. %Value is canonical sum of U and V; if null numr u then v else if null numr v then u else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1 else begin scalar du,dv,x,y,z; x := gcdf(du:=denr u,dv:=denr v); du:=quotf(du,x); dv:=quotf(dv,x); y:=addf(!*multf(dv,numr u),!*multf(du,numr v)); if null y then return nil ./ 1; z:=!*multf(denr u,dv); if minusf z then <<y := negf y; z := negf z>>; if x=1 then return y ./ z; x := gcdf(y,x); return if x=1 then y ./ z else quotf(y,x) ./ quotf(z,x) end; symbolic procedure !*multsq(u,v); %U and V are standard quotients. Result is the canonical product of %U and V with surd powers suitably reduced. if null numr u or null numr v then nil ./ 1 else if denr u=1 and denr v=1 then !*multf(numr u,numr v) ./ 1 else begin scalar w,x,y; x := gcdf(numr u,denr v); y := gcdf(numr v,denr u); w := !*multf(quotf(numr u,x),quotf(numr v,y)); x := !*multf(quotf(denr u,y),quotf(denr v,x)); if minusf x then <<w := negf w; x := negf x>>; y := gcdf(w,x); % another factor may have been generated. return if y=1 then w ./ x else quotf(w,y) ./ quotf(x,y) end; symbolic procedure !*invsq a; % Note that several examples (e.g., int(1/(x**8+1),x)) give a more % compact result when SQRTFLAG is true if SQRT2TOP is not called. if sqrtflag then sqrt2top invsq a else invsq a; symbolic procedure !*multf(u,v); % U and V are standard forms % Value is SF for U*V; begin scalar x,y; if null u or null v then return nil else if u = 1 then return squashsqrt v else if v = 1 then return squashsqrt u else if domainp u then return multd(u,squashsqrt v) else if domainp v then return multd(v,squashsqrt u); x:=mvar u; y:=mvar v; if x eq y then go to c else if ordop(x,y) then go to b; x:=!*multf(u,lc v); y:=!*multf(u,red v); return if null x then y else if not domainp lc v and mvar u eq mvar lc v and not atom mvar u and car mvar u memq '(expt sqrt) then addf(!*multf(x,!*p2f lpow v),y) % what about noncom? else makeupsf(lpow v,x,y); b: x:=!*multf(lc u,v); y:=!*multf(red u,v); return if null x then y else if not domainp lc u and mvar lc u eq mvar v and not atom mvar v and car mvar v memq '(expt sqrt) then addf(!*multf(!*p2f lpow u,x),y) else makeupsf(lpow u,x,y); c: y:=addf(!*multf(list lt u,red v),!*multf(red u,v)); if eqcar(x,'sqrt) then return addf(squashsqrt y,!*multfsqrt(x, !*multf(lc u,lc v),ldeg u + ldeg v)) else if eqcar(x,'expt) and prefix!-rational!-numberp caddr x then return addf(squashsqrt y,!*multfexpt(x, !*multf(lc u,lc v),ldeg u + ldeg v)); x:=mkspm(x,ldeg u + ldeg v); return if null x or null (u:=!*multf(lc u,lc v)) then y else x .* u .+ y end; symbolic procedure makeupsf(u,x,y); % Makes u .* x .+ y except when u is not a valid lpow (because of % sqrts). if atom car u or cdr u = 1 then u .* x .+ y else if caar u eq 'sqrt then addf(!*multfsqrt(car u,x,cdr u),y) else if <<begin scalar v; v:=car u; if car v neq 'expt then return nil; v:=caddr v; if atom v then return nil; return (car v eq 'quotient and numberp cadr v and numberp caddr v) end >> then addf(!*multfexpt(car u,x,cdr u),y) else u .* x .+ y; symbolic procedure !*multfsqrt(x,u,w); % This code (Due to Norman a& Davenport) squashes SQRT(...)**2. begin scalar v; w:=divide(w,2); v:=!*q2f simp cadr x; u:=!*multf(u,exptf(v,car w)); if not zerop cdr w then u:=!*multf(u,!*p2f mksp(x,1)); return u end; symbolic procedure !*multfexpt(x,u,w); begin scalar expon,v; expon:=caddr x; x:=cadr x; w:=w * cadr expon; expon:=caddr expon; v:=gcdn(w,expon); w:=w/v; v:=expon/v; if not (w > 0) then rederr "Invalid exponent" else if v = 1 then return !*multf(u,exptf(if numberp x then x else if atom x then !*k2f x else !*q2f if car x eq '!*sq then argof x else simp x, w)); expon:=0; while not (w < v) do <<expon:=expon + 1; w:=w-v>>; if expon>0 then u:=!*multf(u,exptf(!*q2f simp x,expon)); if w = 0 then return u; x:=list('expt,x,list('quotient,1,v)); return multf(squashsqrt u,!*p2f mksp(x,w)) end; symbolic procedure prefix!-rational!-numberp u; % Tests for m/n in prefix representation. eqcar(u,'quotient) and numberp cadr u and numberp caddr u; symbolic procedure squashsqrtsq sq; !*multsq(squashsqrt numr sq ./ 1, 1 ./ squashsqrt denr sq); symbolic procedure squashsqrt sf; if (not sqrtflag) or atom sf or atom mvar sf then sf else if car mvar sf eq 'sqrt and ldeg sf > 1 then addf(squashsqrt red sf,!*multfsqrt(mvar sf,lc sf,ldeg sf)) else if car mvar sf eq 'expt and prefix!-rational!-numberp caddr mvar sf and ldeg sf >= caddr caddr mvar sf then addf(squashsqrt red sf,!*multfexpt(mvar sf,lc sf,ldeg sf)) else (lpow sf .* squashsqrt lc sf) .+ squashsqrt red sf; %remd 'simpx1; %symbolic procedure simpx1(u,m,n); % %u,m and n are prefix expressions; % %value is the standard quotient expression for u**(m/n); % begin scalar flg,z; % if null frlis!* or null xn(frlis!*,flatten (m . n)) % then go to a; % exptp!* := t; % return !*k2q list('expt,u,if n=1 then m % else list('quotient,m,n)); % a: if numberp m and fixp m then go to e % else if atom m then go to b % else if car m eq 'minus then go to mns % else if car m eq 'plus then go to pls % else if car m eq 'times and numberp cadr m and fixp cadr m % and numberp n % then go to tms; % b: z := 1; % c: if atom u and not numberp u then flag(list u,'used!*); % u := list('expt,u,if n=1 then m else list('quotient,m,n)); % if not u member exptl!* then exptl!* := u . exptl!*; % d: return mksq(u,if flg then -z else z); %u is already in lowest %% %terms; % e: if numberp n and fixp n then go to int; % z := m; % m := 1; % go to c; % mns: m := cadr m; % if !*mcd then return invsq simpx1(u,m,n); % flg := not flg; % go to a; % pls: z := 1 ./ 1; % pl1: m := cdr m; % if null m then return z; % z := multsq(simpexpt list(u, % list('quotient,if flg then list('minus,car m) % else car m,n)), % z); % go to pl1; % tms: z := gcdn(n,cadr m); % n := n/z; % z := cadr m/z; % m := retimes cddr m; % go to c; % int:z := divide(m,n); % if cdr z<0 then z:= (car z - 1) . (cdr z+n); % if 0 = cdr z % then return simpexpt list(u,car z); % if n = 2 % then return multsq(simpexpt list(u,car z), % simpsqrti u); % return multsq(simpexpt list(u,car z), % mksq(list('expt,u,list('quotient,1,n)),cdr z)) % end; symbolic procedure !*exptsq(a,n); % raise A to the power N using !*MULTSQ; if n=0 then 1 ./ 1 else if n=1 then a else if n<0 then !*exptsq(invsq a,-n) else begin scalar q,r; q:=divide(n,2); r:=cdr q; q:=car q; q:=!*exptsq(!*multsq(a,a),q); if r=0 then return q else return !*multsq(a,q) end; symbolic procedure !*exptf(a,n); % raise A to the power N using !*MULTF; if n=0 then 1 else if n=1 then a else begin scalar q,r; q:=divide(n,2); r:=cdr q; q:=car q; q:=!*exptf(!*multf(a,a),q); if r=0 then return q else return !*multf(a,q) end; endmodule; module hacksqrt; % Routines for manipulation of sqrt expressions. % Author: James H. Davenport. fluid '(nestedsqrts thisplace); exports sqrtsintree,sqrtsinsq,sqrtsinsql,sqrtsinsf,sqrtsign; exports degreenest,sortsqrts; imports mkvect,interr,getv,dependsp,union; symbolic procedure sqrtsintree(u,var,slist); % Adds to slist all the sqrts in the prefix-type tree u. if atom u then slist else if car u eq '!*sq then union(slist,sqrtsinsq(cadr u,var)) else if car u eq 'sqrt then if dependsp(argof u,var) then << slist:=sqrtsintree(argof u,var,slist); % nested square roots if member(u,slist) then slist else u.slist >> else slist else sqrtsintree(car u,var,sqrtsintree(cdr u,var,slist)); symbolic procedure sqrtsinsq(u,var); % Returns list of all sqrts in sq. sqrtsinsf(denr u,sqrtsinsf(numr u,nil,var),var); symbolic procedure sqrtsinsql(u,var); % Returns list of all sqrts in sq list. if null u then nil else sqrtsinsf(denr car u, sqrtsinsf(numr car u,sqrtsinsql(cdr u,var),var),var); symbolic procedure sqrtsinsf(u,slist,var); % Adds to slist all the sqrts in sf. if domainp u or null u then slist else << if eqcar(mvar u,'sqrt) and dependsp(argof mvar u,var) and not member(mvar u,slist) then begin scalar slist2; slist2:=sqrtsintree(argof mvar u,var,nil); if slist2 then << nestedsqrts:=t; slist:=union(slist2,slist) >>; slist:=(mvar u).slist end; sqrtsinsf(lc u,sqrtsinsf(red u,slist,var),var) >>; symbolic procedure easysqrtsign(slist,things); % This procedure builds a list of all substitutions for all possible % combinations of square roots in list. if null slist then things else easysqrtsign(cdr slist, nconc(mapcons(things,(car slist).(car slist)), mapcons(things, list(car slist,'minus,car slist)))); symbolic procedure hardsqrtsign(slist,things); % This procedure fulfils the same role for nested sqrts % ***assumption: the simpler sqrts come further up the list. if null slist then things else begin scalar thisplace,answers,pos,neg; thisplace:=car slist; answers:=mapcar(things,function (lambda u;sublis(u,thisplace).u)); pos:=mapcar(answers,function (lambda u;(thisplace.car u).(cdr u))); % pos is sqrt(f) -> sqrt(innersubst f) neg:=mapcar(answers, function (lambda u;list(thisplace,'minus,car u).(cdr u))); % neg is sqrt(f) -> -sqrt(innersubst f) return hardsqrtsign(cdr slist,nconc(pos,neg)) end; symbolic procedure degreenest(pf,var); % Returns the maximum degree of nesting of var % inside sqrts in the prefix form pf. if atom pf then 0 else if car pf eq 'sqrt then if dependsp(cadr pf,var) then iadd1 degreenest(cadr pf,var) else 0 else if car pf eq 'expt then if dependsp(cadr pf,var) then if eqcar(caddr pf,'quotient) then iadd1 degreenest(cadr pf,var) else degreenest(cadr pf,var) else 0 else degreenestl(cdr pf,var); symbolic procedure degreenestl(u,var); %Returns max degreenest from list of pfs u. if null u then 0 else max(degreenest(car u,var), degreenestl(cdr u,var)); symbolic procedure sortsqrts(u,var); % Sorts list of sqrts into order required by hardsqrtsign % (and many other parts of the package). begin scalar i,v; v:=mkvect(10); %should be good enough! while u do << i:=degreenest(car u,var); if i iequal 0 then interr "Non-dependent sqrt found"; if i > 10 then interr "Degree of nesting exceeds 10 (recompile with 10 increased)"; putv(v,i,(car u).getv(v,i)); u:=cdr u >>; u:=getv(v,10); for i :=9 step -1 until 1 do u:=nconc(getv(v,i),u); return u end; symbolic procedure sqrtsign(sqrts,x); if nestedsqrts then hardsqrtsign(sortsqrts(sqrts,x),list nil) else easysqrtsign(sqrts,list nil); endmodule; module kron; % Kronecker factorization of univ. polys over integers. % Authors: Mary Ann Moore and Arthur C. Norman. global '(!*trint); exports linfac,quadfac; imports zfactor; % Only linear and quadratic factors are found. symbolic procedure linfac(w); trykr(w,'(0 1)); symbolic procedure quadfac(w); trykr(w,'(-1 0 1)); symbolic procedure trykr(w,points); %Look for factor of w by evaluation at (points) and use of % interpolate. Return (fac . cofac) with fac=nil if none % found and cofac=nil if nothing worthwhile is left. begin scalar values,attempt; if null w then return nil . nil; if (length points > car w) then return w . nil; %that says if w is already tiny, it is already factored. values:=mapcar(points,function (lambda x; evalat(w,x))); if !*trint then << printc ("At x= " . points); printc ("p(x)= " . values)>>; if 0 member values then go to lucky; %(x-1) is a factor! values:=mapcar(values,function zfactors); rplacd(values,mapcar(cdr values,function (lambda y; append(y,mapcar(y,function minus))))); if !*trint then <<printc "Possible factors go through some of"; print values>>; attempt:=search4fac(w,values,nil); if null attempt then attempt:=nil . w; return attempt; lucky: %here (x-1) is a factor because p(0) or p(1) or p(-1) %vanished and cases p(0), p(-1) will have been removed %elsewhere. attempt:='(1 1 -1); %the factor return attempt . testdiv(w,attempt) end; symbolic procedure zfactors n; % Produces a list of all (positive) integer factors of the integer n. if n=0 then list 0 else if (n:=abs n)=1 then list 1 else combinationtimes zfactor n; symbolic procedure search4fac(w,values,cv); % Combinatorial search. cv gets current selected value-set. % Returns nil if fails, else factor . cofactor. if null values then tryfactor(w,cv) else begin scalar ff,q; ff:=car values; %try all values here loop: if null ff then return nil; %no factor found q:=search4fac(w,cdr values,(car ff) . cv); if null q then << ff:=cdr ff; go to loop>>; return q end; symbolic procedure tryfactor(w,cv); % Tests if cv represents a factor of w. begin scalar ff,q; if null cddr cv then ff:=linethrough(cadr cv,car cv) else ff:=quadthrough(caddr cv,cadr cv,car cv); if ff='failed then return nil; %it does not interpolate q:=testdiv(w,ff); if q='failed then return nil; %not a factor return ff . q end; symbolic procedure evalat(p,n); % Evaluate polynomial at integer point n. begin scalar r; r:=0; p:=cdr p; while not null p do << r:=n*r+car p; p:=cdr p >>; return r end; symbolic procedure testdiv(a,b); % Quotient a/b or failed. begin scalar q; q:=testdiv1(cdr a,car a,cdr b,car b); if q='failed then return q; return (car a-car b) . q end; symbolic procedure testdiv1(a,da,b,db); if da<db then begin check0: if null a then return nil else if not zerop car a then return 'failed; a:=cdr a; go to check0 end else begin scalar q; q:=divide(car a,car b); if zerop cdr q then q:=car q else return 'failed; a:=testdiv1(ambq(cdr a,cdr b,q),da-1,b,db); if a='failed then return a; return q . a end; symbolic procedure ambq(a,b,q); % A-B*Q with Q an integer. if null b then a else ((car a)-(car b)*q) . ambq(cdr a,cdr b,q); symbolic procedure linethrough(y0,y1); begin scalar a; a:=y1-y0; if zerop a then return 'failed; if a<0 then <<a:=-a; y0:=-y0 >>; if onep gcdn(a,y0) then return list(1,a,y0); return 'failed end; symbolic procedure quadthrough(ym1,y0,y1); begin scalar a,b,c; a:=divide(ym1+y1,2); if zerop cdr a then a:=(car a)-y0 else return 'failed; if zerop a then return 'failed; %linear things already done. c:=y0; b:=divide(y1-ym1,2); if zerop cdr b then b:=car b else return 'failed; if not onep gcdn(a,gcd(b,c)) then return 'failed; if a<0 then <<a:=-a; b:=-b; c:=-c>>; return list(2,a,b,c) end; endmodule; module lowdeg; % Splitting of low degree polynomials. % Author: To be determined. fluid '(clogflag knowndiscrimsign zlist); global '(!*trint); exports forceazero,makepolydf,quadratic,covecdf,exponentdf; imports dfquotdf,gcdf,interr,minusdfp,multdf,multdfconst,!*multf, negsq,minusp,printsq,multsq,invsq,pnth,nth,mknill, negdf,plusdf,printdf,printsq,quotf,sqrtdf,var2df,vp2,addsq,sub1; symbolic procedure covecdf(pol,var,degree); % Extract coefficients of polynomial wrt var, given a degree-bound % degree. Result is a lisp vector. begin scalar v,x,w; w:=pol; v:=mkvect(degree); while not null w do << x:=exponentof(var,lpow w,zlist); if (x<0) or (x>degree) then interr "Bad degree in covecdf"; putv(v,x,lt w . getv(v,x)); w:=red w >>; for i:=0:degree do putv(v,i,multdf(reversewoc getv(v,i), var2df(var,-i,zlist))); return v end; symbolic procedure quadratic(pol,var,res); % Add in to res logs or arctans corresponding to splitting the % polynomial. Pol given that it is quadratic wrt var. % Does not assume pol is univariate. begin scalar a,b,c,w,discrim; w:=covecdf(pol,var,2); a:=getv(w,2); b:=getv(w,1); c:=getv(w,0); % that split the quadratic up to find the coefficients a,b,c. if !*trint then << printc "a="; printdf a; printc "b="; printdf b; printc "c="; printdf c>>; discrim:=plusdf(multdf(b,b), multdfconst((-4) . 1,multdf(a,c))); if !*trint then << printc "Discriminant is"; printdf discrim>>; if null discrim then interr "Discrim=0 in quadratic"; if knowndiscrimsign then <<if knowndiscrimsign eq 'negative then go to atancase>> else if (not clogflag) and (minusdfp discrim) then go to atancase; discrim:=sqrtdf(discrim); if discrim='failed then go to nofactors; if !*trint then << printc "Square root is"; printdf discrim>>; w:=var2df(var,1,zlist); w:=multdf(w,a); b:=multdfconst(1 ./ 2,b); discrim:=multdfconst(1 ./ 2,discrim); w:=plusdf(w,b); %a*x+b/2. a:=plusdf(w,discrim); b:=plusdf(w,negdf(discrim)); if !*trint then << printc "Factors are"; printdf a; printdf b>>; return ('log . a) . ('log . b) . res; atancase: discrim:=sqrtdf negdf discrim; %sqrt(4*a*c-b**2) this time! if discrim='failed then go to nofactors; %sqrt did not exist? res := ('log . pol) . res; %one part of the answer a:=multdf(a,var2df(var,1,zlist)); a:=plusdf(b,multdfconst(2 ./ 1,a)); a:=dfquotdf(a,discrim); %assumes division is exact return ('atan . a) . res; nofactors: if !*trint then <<printc "The following quadratic does not seem to factor"; printdf pol>>; return ('log . pol) . res end; symbolic procedure exponentof(var,l,zl); if null zl then interr "Var not found in exponentof" else if var=car zl then car l else exponentof(var,cdr l,cdr zl); symbolic procedure df2sf a; if null a then nil else if ((null red a) and (denr lc a = 1) and (lpow a=vp2 zlist)) then numr lc a else interr "Nasty cubic or quartic"; symbolic procedure makepolydf p; % Multiply df by lcm of denominators of all coefficient denominators. begin scalar h,w; if null(w:=p) then return nil; %poly is zero already. h:=denr lc w; %a good start. w:=red w; while not null w do << h:=quotf(!*multf(h,denr lc w),gcdf(h,denr lc w)); w:=red w >>; %h is now lcm of denominators. return multdfconst(h ./ 1,p) end; symbolic procedure forceazero(p,n); %Shift polynomial p so that coeff of x**(n-1) vanishes. %Return the amount of the shift, update (vector) p. begin scalar r,i,w; for i:=0:n do putv(p,i,df2sf getv(p,i)); %convert to polys. r:=getv(p,n-1); if null r then return nil ./ 1; %already zero. r:= !*multsq(r ./ 1,invsq(!*multf(n,getv(p,n)) ./ 1)); % Used to be subs2q multsq %the shift amount. %now I have to set p:=subst(x-r,x,p) and then reduce to sf again. if !*trint then << printc "Shift is by "; printsq r>>; w:=mkvect(n); %workspace vector. for i:=0:n do putv(w,i,nil ./ 1); %zero it. i:=n; while not minusp i do << mulvecbyxr(w,negsq r,n); %W:=(X-R)*W; putv(w,0,addsq(getv(w,0),getv(p,i) ./ 1)); i:=i-1 >>; if !*trint then << printc "SQ shifted poly is"; print w>>; for i:=0:n do putv(p,i,getv(w,i)); w:=denr getv(p,0); for i:=1:n do w:=quotf(!*multf(w,denr getv(p,i)), gcdf(w,denr getv(p,i))); for i:=0:n do putv(p,i,numr !*multsq(getv(p,i),w ./ 1)); % Used to be subs2q multsq w:=getv(p,0); for i:=1:n do w:=gcdf(w,getv(p,i)); if not (w=1) then for i:=0:n do putv(p,i,quotf(getv(p,i),w)); if !*trint then << printc "Final shifted poly is "; print p>>; return r end; symbolic procedure mulvecbyxr(w,r,n); % W is a vector representing a poly of degree n. % Multiply it by (x+r). begin scalar i,im1; i:=n; im1:=sub1 i; while not minusp im1 do << putv(w,i,!*addsq(getv(w,im1),!*multsq(r,getv(w,i)))); % Used to be subs2q addsq/multsq i:=im1; im1:=sub1 i >>; putv(w,0,!*multsq(getv(w,0),r)); % Used to be subs2q multsq return w end; endmodule; module reform; % Reformulate expressions using C-constant substitution. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(cmap cval loglist ulist); global '(!*trint); exports logstosq,substinulist; imports prepsq,mksp,nth,multsq,addsq,domainp,invsq,plusdf; symbolic procedure substinulist ulist; % Substitutes for the C-constants in the values of the U's given in % ULIST. Result is a D.F. if null ulist then nil else begin scalar temp,lcu; lcu:=lc ulist; temp:=evaluateuconst numr lcu; if null numr temp then temp:=nil else temp:=((lpow ulist) .* !*multsq(temp,!*invsq(denr lcu ./ 1))) .+ nil; return plusdf(temp,substinulist red ulist) end; symbolic procedure evaluateuconst coefft; % Substitutes for the C-constants into COEFFT (=S.F.). Result is S.Q.; if null coefft or domainp coefft then coefft ./ 1 else begin scalar temp; if null(temp:=assoc(mvar coefft,cmap)) then temp:=(!*p2f lpow coefft) ./ 1 else temp:=getv(cval,cdr temp); temp:=!*multsq(temp,evaluateuconst(lc coefft)); % Next line had addsq previously return !*addsq(temp,evaluateuconst(red coefft)) end; symbolic procedure logstosq; % Converts LOGLIST to sum of the log terms as a S.Q.; begin scalar lglst,logsq,i,temp; i:=1; lglst:=loglist; logsq:=nil ./ 1; loop: if null lglst then return logsq; temp:=cddr car lglst; if !*trint then <<printc "SF arg for log etc ="; printc temp>>; if not (caar lglst='iden) then << temp:=prepsq temp; %convert to prefix form. temp:=list(caar lglst,temp); %function name. temp:=((mksp(temp,1) .* 1) .+ nil) ./ 1 >>; temp:=!*multsq(temp,getv(cval,i)); % Next line had addsq previously logsq:=!*addsq(temp,logsq); lglst:=cdr lglst; i:=i+1; go to loop end; endmodule; module simplog; % Simplify logarithms. % Authors: Mary Ann Moore and Arthur C. Norman. exports simplog,simplogsq; imports quotf,prepf,mksp,simp!*,!*multsq,simptimes,addsq,minusf,negf, addf,comfac,negsq,mk!*sq,carx; symbolic procedure simplog(exxpr); simplogi carx(exxpr,'simplog); symbolic procedure simplogi(sq); begin if atom sq then go to simplify; if car sq eq 'times then return simpplus(for each u in cdr sq collect mk!*sq simplogi u); if car sq eq 'quotient then return addsq(simplogi cadr sq, negsq simplogi caddr sq); if car sq eq 'expt then return simptimes list(caddr sq, mk!*sq simplogi cadr sq); if car sq eq 'nthroot then return !*multsq(1 ./ caddr sq,simplogi cadr sq); % we had (nthroot of n). if car sq eq 'sqrt then return !*multsq(1 ./ 2,simplogi argof sq); if car sq = '!*sq then return simplogsq cadr sq; simplify: sq:=simp!* sq; return simplogsq sq end; symbolic procedure simplogsq sq; addsq((simplog2 numr sq),negsq(simplog2 denr sq)); symbolic procedure simplog2(sf); if atom sf then if null sf then rederr "Log 0 formed" else if numberp sf then if sf iequal 1 then nil ./ 1 else if sf iequal 0 then rederr "Log 0 formed" else((mksp(list('log,sf),1) .* 1) .+ nil) ./ 1 else formlog(sf) else begin scalar form; form:=comfac sf; if not null car form then return addsq(formlog(form .+ nil), simplog2 quotf(sf,form .+ nil)); % we have killed common powers. form:=cdr form; if form neq 1 then return addsq(simplog2 form, simplog2 quotf(sf,form)); % remove a common factor from the sf. return (formlog sf) end; symbolic procedure formlogterm(sf); begin scalar u; u:=mvar sf; if not atom u and (car u member '(times sqrt expt nthroot)) then u:=addsq(simplog2 lc sf, !*multsq(simplogi u,simp!* ldeg sf)) else if (lc sf iequal 1) and (ldeg sf iequal 1) then u:=((mksp(list('log,u),1) .* 1) .+ nil) ./ 1 else u:=addsq(simptimes list(list('log,u),ldeg sf), simplog2 lc sf); return u end; symbolic procedure formlog sf; if null red sf then formlogterm sf else if minusf sf then addf((mksp(list('log,-1),1) .* 1) .+ nil, formlog2 negf sf) ./ 1 else (formlog2 sf) ./ 1; symbolic procedure formlog2 sf; ((mksp(list('log,prepf sf),1) .* 1) .+ nil); endmodule; module simpsqrt; % Simplify square roots. % Authors: Mary Ann Moore and Arthur C. Norman. % Heavily modified J.H. Davenport for algebraic functions. fluid '(!*backtrace !*conscount !*galois !*pvar basic!-listofallsqrts gaussiani basic!-listofnewsqrts kord!* knowntobeindep listofallsqrts listofnewsqrts sqrtflag sqrtlist sqrt!-places!-alist variable varlist zlist); global '(!*tra !*trint); % This module should be rewritten in terms of the REDUCE function % SIMPSQRT; % remd 'simpsqrt; exports proper!-simpsqrt,simpsqrti,simpsqrtsq,simpsqrt2,sqrtsave, newplace,actualsimpsqrt,formsqrt; symbolic procedure proper!-simpsqrt(exprn); simpsqrti carx(exprn,'proper!-simpsqrt); symbolic procedure simpsqrti sq; begin scalar u; if atom sq then if numberp sq then return (simpsqrt2 sq) ./ 1 else if (u:=get(sq,'avalue)) then return simpsqrti cadr u % BEWARE!!! This is VERY system dependent. else return simpsqrt2((mksp(sq,1) .* 1) .+ nil) ./ 1; % If it doesnt have an AVALUE then it is itself; if car sq eq 'times then return mapply(function multsq, mapcar(cdr sq,function simpsqrti)); if car sq eq 'quotient then return multsq(simpsqrti cadr sq, invsq simpsqrti caddr sq); if car sq eq 'expt and numberp caddr sq then if evenp caddr sq then return simpexpt list(cadr sq,caddr sq / 2) else return simpexpt list(mk!*sq simpsqrti cadr sq,caddr sq); if car sq = '!*sq then return simpsqrtsq cadr sq; return simpsqrtsq tidysqrt simp!* sq end; symbolic procedure simpsqrtsq sq; (simpsqrt2 numr sq) ./ (simpsqrt2 denr sq); symbolic procedure simpsqrt2 sf; if minusf sf then if sf iequal -1 then gaussiani else begin scalar u; u:=negf sf; if numberp u then return multf(gaussiani,simpsqrt3 u); % we cannot negate general expressions for the following reason: % (%%%thesis remark%%%) % sqrt(x*x-1) under x->1/x gives sqrt(1-x*x)/x=i*sqrt(x*x-1)/x % under x->1/x gives x*i*sqrt(-1+1/x*x)=i**2*sqrt(x*x-1) % hence an abysmal catastrophe; return simpsqrt3 sf end else simpsqrt3 sf; symbolic procedure simpsqrt3 sf; begin scalar u; u:=assoc(sf,listofallsqrts); if u then return cdr u; % now see if 'knowntobeindep'can help. u:=atsoc(listofnewsqrts,knowntobeindep); if null u then go to no; u:=assoc(sf,cdr u); if u then << listofallsqrts:=u.listofallsqrts; return cdr u >>; no: u:=actualsimpsqrt sf; listofallsqrts:=(sf.u).listofallsqrts; return u end; symbolic procedure sqrtsave(u,v,place); begin scalar a; %u is new value of listofallsqrts, v of new. a:=assoc(place,sqrt!-places!-alist); if null a then sqrt!-places!-alist:=(place.(listofnewsqrts.listofallsqrts)) .sqrt!-places!-alist else rplacd(a,listofnewsqrts.listofallsqrts); listofnewsqrts:=v; % throw away things we are not going to need in future. if not !*galois then listofallsqrts:=u; % we cannot guarantee the validity of our calculations. if listofallsqrts eq u then return nil; v:=listofallsqrts; while not (cdr v eq u) do v:=cdr v; rplacd(v,nil); % listofallsqrts is all those added since routine was entered. v:=atsoc(listofnewsqrts,knowntobeindep); if null v then knowntobeindep:=(listofnewsqrts.listofallsqrts) . knowntobeindep else rplacd(v,union(cdr v,listofallsqrts)); listofallsqrts:=u; return nil end; symbolic procedure newplace(u); % Says to restart algebraic bases at a new place u. begin scalar v; v:=assoc(u,sqrt!-places!-alist); if null v then << listofallsqrts:=basic!-listofallsqrts; listofnewsqrts:=basic!-listofnewsqrts >> else << v:=cdr v; listofnewsqrts:=car v; listofallsqrts:=cdr v >>; return if v then v else listofnewsqrts.listofallsqrts end; symbolic procedure mknewsqrt u; % U is prefix form. begin scalar v,w; if not !*galois then go to new; % no checking required. v:=addf(!*p2f mksp(!*pvar,2),negf !*q2f tidysqrt simp u); % count !*conscount; w:=errorset(list('afactor,mkquote v,mkquote !*pvar),t,!*backtrace); % if !*tra then << % princ "*** That took "; % princ (!*conscount - count nil); % printc " conses" >>; % count 0; if atom w then go to new else w:=car w; %the actual result of afactor. if cdr w then go to notnew; new: w:=sqrtify u; listofnewsqrts:=w . listofnewsqrts; return !*kk2f w; notnew: w:=car w; v:=stt(w,!*pvar); if car v neq 1 then rederr "HELP ..."; w:=addf(w,multf(cdr v,(mksp(!*pvar,car v) .* -1) .+nil)); w:=sqrt2top(w ./ cdr v); w:=quotf(numr w,denr w); if null w then rederr "Division failure"; return w end; symbolic procedure actualsimpsqrt(sf); if sf iequal -1 then gaussiani else actualsqrtinner(sf,listofnewsqrts); symbolic procedure actualsqrtinner(sf,l); if null l then actualsimpsqrt2 sf else begin scalar z; % z:=simp argof car l; % if denr z neq 1 or (z := numr z) iequal -1 z:=!*q2f simp argof car l; if z iequal -1 then return actualsqrtinner(sf,cdr l); z:=quotf(sf,z); if null z then return actualsqrtinner(sf,cdr l); return !*multf(!*kk2f car l,actualsimpsqrt z) end; symbolic procedure actualsimpsqrt2(sf); if atom sf then if null sf then nil else if numberp sf then if sf < 0 then multf(gaussiani,actualsimpsqrt2(- sf)) %Above 2 lines inserted JHD 4 Sept 80; % test case: SQRT(B*X**2-C)/SQRT(X); else begin scalar n; n:=int!-sqrt sf; % Changed for conformity with DEC20 LISP JHD July 1982; if not fixp n then return mknewsqrt sf else return n end else mknewsqrt(sf) else begin scalar form; form:=comfac sf; if car form then return multf((if null cdr sf and (car sf = form) then formsqrt(form .+ nil) else simpsqrt2(form .+ nil)), %The above 2 lines changed by JHD; %(following suggestions of Morrison); %to conform to Standard LISP 4 Sept 80; simpsqrt2 quotf(sf,form .+ nil)); % we have killed common powers. form:=cdr form; if form neq 1 then return multf(simpsqrt2 form, simpsqrt2 quotf(sf,form)); % remove a common factor from the sf. return formsqrt sf end; symbolic procedure int!-sqrt n; % Return sqrt of n if same is exact, or something non-numeric % otherwise. if not numberp n then 'nonnumeric else if n<0 then 'negative else if floatp n then sqrt!-float n else if n<2 then n else int!-nr(n,(n+1)/2); symbolic procedure int!-nr(n,root); % root is an overestimate here. nr moves downwards to root; begin scalar w; w:=root*root; if n=w then return root; w:=(root+n/root)/2; if w>=root then return !*q2f simpsqrt list n; return int!-nr(n,w) end; symbolic procedure formsqrt(sf); if (null red sf) then if (lc sf iequal 1) and (ldeg sf iequal 1) then mknewsqrt mvar sf else multf(if evenp ldeg sf then !*p2f mksp(mvar sf,ldeg sf / 2) else exptf(mknewsqrt mvar sf,ldeg sf),simpsqrt2 lc sf) else begin scalar varlist,zlist,sqrtlist,sqrtflag; scalar v,l,n,w; % This returns a list, the i-th member of which is % a list of the factors of multiplicity i (as s.f's); v:=jsqfree(sf,if variable and involvesf(sf,variable) then variable else findatom mvar sf); % VARIABLE is the best thing to do square-free % decompositions with respect to, but anything % else will do if VARIABLE is not set; if null cdr v and null cdar v then return mknewsqrt prepf sf; % The JSQFREE did nothing; l:=nil; n:=0; while v do << n:=n+1; w:=car v; while w do << l:=list('expt,mk!*sq !*f2q car w,n) . l; w:=cdr w >>; v:=cdr v >>; if null cdr l then l:=car l else l:='times.l; % makes L into a valid prefix form; return !*q2f simpsqrti l end; symbolic procedure findatom pf; if atom pf then pf else findatom argof pf; symbolic procedure sqrtify u; % Actually creates the sqrt. begin scalar v,n,prinlist; n:=degreenest(u,nil); % v:=list('sqrt,u); v := mksqrt u; % To ensure sqrt**2 rule set. prinlist:=member(v,kord!*); if prinlist then return car prinlist; % This might improve sharing. % anyway, we mustn't re-add this object to KORD!*; while kord!* and eqcar(car kord!*,'sqrt) and (degreenest(argof car kord!*,nil) > n) do << prinlist:=(car kord!*) . prinlist; kord!*:=cdr kord!* >>; kord!*:=v . kord!*; while prinlist do << kord!*:=(car prinlist) . kord!*; prinlist:=cdr prinlist >>; return v end; % deflist ('((sqrt (((x) quotient (sqrt x) (times 2 x))))),'dfn); % put('sqrt,'simpfn,'proper!-simpsqrt); % Now in driver. endmodule; module isolve; % Routines for solving the final reduction equation. % Author: Mary Ann Moore and Arthur C. Norman. % Modifications by: John P. Fitch. fluid '(badpart ccount cmap cmatrix cval indexlist lhs!* lorder nnn orderofelim pt rhs!* sillieslist tanlist ulist zlist); global '(!*number!* !*statistics !*trint); exports solve!-for!-u; imports nth,findpivot,gcdf,int!-gensym1,mkvect,interr,multdfconst, !*multf!*,negdf,orddf,plusdf,printdf,printsf,printspreadc,printsq, quotf,putv,spreadc,subst4eliminatedcs,mknill,pnth,domainp,addf, invsq,multsq; symbolic procedure uterm(powu,rhs!*); % Finds the contribution from RHS!* of reduction equation, of the; % U-coefficient given by POWU. Result is in D.F.; if null rhs!* then nil else begin scalar coef,power; power:=addinds(powu,lpow rhs!*); coef:=evaluatecoeffts(numr lc rhs!*,powu); if null coef then return uterm(powu,red rhs!*); coef:=coef ./ denr lc rhs!*; return plusdf((power .* coef) .+ nil,uterm(powu,red rhs!*)) end; symbolic procedure solve!-for!-u(rhs!*,lhs!*,ulist); % Solves the reduction eqn LHS!*=RHS!*. Returns list of U-coefficients % and their values (ULIST are those we have so far), and a list of % C-equations to be solved (CLIST are the eqns we have so far). if null lhs!* then ulist else begin scalar u,lpowlhs; lpowlhs:=lpow lhs!*; begin scalar ll,mm,chge; ll:=maxorder(rhs!*,zlist,0); mm:=lorder; while mm do << if car ll < car mm then << chge:=t; rplaca(mm,car ll) >>; ll:=cdr ll; mm:=cdr mm >>; if !*trint and chge then << print ("Maxorder now ".lorder) >> end; u:=pickupu(rhs!*,lpow lhs!*,t); if null u then << if !*trint then << printc "***** C-equation to solve:"; printsf numr lc lhs!*; printc " = 0"; printc " ">>; % Remove a zero constant from the lhs, rather than use % Gauss Elim; if gausselimn(numr lc lhs!*,lt lhs!*) then lhs!*:=squashconstants(red lhs!*) else lhs!*:=red lhs!* >> else << ulist:=(car u . !*multsq(coefdf(lhs!*,lpowlhs),invsq cdr u)).ulist; % used to be subs2q multsq if !*statistics then !*number!*:=!*number!*+1; if !*trint then <<prin2 "***** U"; prin2 car u; prin2t " ="; printsq multsq(coefdf(lhs!*,lpowlhs),invsq cdr u); printc " ">>; lhs!*:=plusdf(lhs!*, negdf multdfconst(cdar ulist,uterm(car u,rhs!*))) >>; if !*trint then << printc ".... LHS is now:"; printdf lhs!*; printc " ">>; return solve!-for!-u(rhs!*,lhs!*,ulist) end; symbolic procedure squashconstants(express); begin scalar constlst,ii,xp,cl,subby,cmt,xx; constlst:=reverse cmap; cmt:=cmatrix; xxx: xx:=car cmt; % Look at next row of Cmatrix; cl:=constlst; % and list of the names; ii:=1; % will become index of removed constant; while not getv(xx,ii) do << ii:=ii+1; cl:=cdr cl >>; subby:=caar cl; %II is now index, and SUBBY the name; if member(subby,sillieslist) then <<cmt:=cdr cmt; go to xxx>>; %This loop must terminate; % This is because at least one constant remains; xp:=prepsq !*f2q getv(xx,0); % start to build up the answer; cl:=cdr cl; if not (ccount=ii) then for jj:=ii+1:ccount do << if getv(xx,jj) then xp:=list('plus,xp, list('times,caar cl, prepsq !*f2q getv(xx,jj))); cl:=cdr cl >>; xp:=list('quotient,list('minus,xp), prepsq !*f2q getv(xx,ii)); if !*trint then << prin2 "Replace "; prin2 subby; prin2 " by "; printsq simp xp >>; sillieslist:=subby . sillieslist; return subdf(express,xp,subby) end; symbolic procedure checku(ulist,u); % Checks that U is not already in ULIST - ie. that this u-coefficient; % has not already been given a value; if null ulist then nil else if (car u) = caar ulist then t else checku(cdr ulist,u); symbolic procedure checku1(powu,rhs!*); %Checks that use of a particular U-term will not cause trouble; %by introducing negative exponents into lhs when it is used; begin top: if null rhs!* then return nil; if negind(powu,lpow rhs!*) then if not null evaluatecoeffts(numr lc rhs!*,powu) then return t; rhs!*:=red rhs!*; go to top end; symbolic procedure negind(pu,pr); %check if substituting index values in power gives rise to -ve % exponents; if null pu then nil else if (car pu+caar pr)<0 then t else negind(cdr pu,cdr pr); symbolic procedure evaluatecoeffts(coefft,indlist); % Substitutes the values of the i,j,k,...'s that appear in the S.F. ; % COEFFT (=coefficient of r.h.s. of reduction equation). Result is S.F.; if null coefft or domainp coefft then if coefft=0 then nil else coefft else begin scalar temp; if mvar coefft member indexlist then temp:=valuecoefft(mvar coefft,indlist,indexlist) else temp:=!*p2f lpow coefft; temp:=!*multf(temp,evaluatecoeffts(lc coefft,indlist)); return addf(temp,evaluatecoeffts(red coefft,indlist)) end; symbolic procedure valuecoefft(var,indvalues,indlist); % Finds the value of VAR, which should be in INDLIST, given INDVALUES; % - the corresponding values of INDLIST variables; if null indlist then interr "Valuecoefft - no value" else if var eq car indlist then if car indvalues=0 then nil else car indvalues else valuecoefft(var,cdr indvalues,cdr indlist); symbolic procedure addinds(powu,powrhs); % Adds indices in POWU to those in POWRHS. Result is LPOW of D.F.; if null powu then if null powrhs then nil else interr "Powrhs too long" else if null powrhs then interr "Powu too long" else (car powu + caar powrhs).addinds(cdr powu,cdr powrhs); symbolic procedure pickupu(rhs!*,powlhs,flg); % Picks up the 'lowest' U coefficient from RHS!* if it exists and % returns it in the form of LT of D.F.. % Returns NIL if no legal term in RHS!* can be found. % POWLHS is the power we want to match (LPOW of D.F). % and COEFFU is the list of previous coefficients that must be zero; begin scalar coeffu,u; pt:=rhs!*; top: if null pt then return nil; %no term found - failed; u:=nextu(lt pt,powlhs); %check this term...; if null u then go to notthisone; if not testord(car u,lorder) then go to neverthisone; if not checkcoeffts(coeffu,car u) then go to notthisone; %that inhibited clobbering things already passed over; if checku(ulist,u) then go to notthisone; %that avoided redefining a u value; if checku1(car u,rhs!*) then go to neverthisone; %avoid introduction of negative exponents; if flg then u:=patchuptan(list u,powlhs,red pt,rhs!*); return u; neverthisone: coeffu:=(lc pt) . coeffu; notthisone: pt:=red pt; go to top end; symbolic procedure patchuptan(u,powlhs,rpt,rhs!*); begin scalar uu,cc,dd,tanlist,redu,redu1; pt:=rpt; while pt do << if (uu:=pickupu(pt,powlhs,nil)) and testord(car uu,lorder) then << % Nasty found, patch it up; cc:=(int!-gensym1('!C).caar u).cc; % CC is an alist of constants; if !*trint then <<prin2 "***** U"; prin2 caar u; prin2t " ="; print caar cc >>; redu:=plusdf(redu, multdfconst(!*k2q caar cc,uterm(caar u,rhs!*))); u:=uu.u >>; if pt then pt:=red pt >>; redu1:=redu; while redu1 do begin scalar xx; xx:=car redu1; if !*trint then << prin2 "Introduced residue "; print xx >>; if (not testord(car xx,lorder)) then << if !*trint then << printsq cdr xx; printc " = 0" >>; if dd:=killsingles(cadr xx,cc) then << redu:=subdf(redu,0,car dd); redu1:=subdf(redu1,0,car dd); ulist:=((cdr dd).(nil ./ 1)).ulist; u:=rmve(u,cdr dd); cc:=purgeconst(cc,dd) >> else redu1:=cdr redu1 >> else redu1:=cdr redu1 end; for each xx in redu do << if (not testord(car xx,lorder)) then << while cc do << addctomap(caar cc); ulist:=((cdar cc).(!*k2q caar cc)) . ulist; if !*statistics then !*number!*:=!*number!*+1; cc:=cdr cc >>; gausselimn(numr lc redu,lt redu)>> >>; if redu then << while cc do << addctomap(caar cc); ulist:=((cdar cc).(!*k2q caar cc)).ulist; if !*statistics then !*number!*:=!*number!*+1; cc:=cdr cc >>; lhs!*:=plusdf(lhs!*,negdf redu) >>; return car u end; symbolic procedure killsingles(xx,cc); if atom xx then nil else if not (cdr xx eq nil) then nil else begin scalar dd; dd:=assoc(caaar xx,cc); if dd then return dd; return killsingles(cdar xx,cc) end; symbolic procedure rmve(l,x); if caar l=x then cdr l else cons(car l,rmve(cdr l,x)); symbolic procedure subdf(a,b,c); % SUBSTITUTE B FOR C INTO THE DF A; % Used to get rid of silly constants introduced; if a=nil then nil else begin scalar x; x:=subs2q subf(numr lc a,list (c . b)) ; if x=(nil . 1) then return subdf(red a,b,c) else return plusdf( list ((lpow a).((car x).!*multf(cdr x,denr lc a))), subdf(red a,b,c)) end; symbolic procedure testord(a,b); % Test order of two DF's in recursive fashion; if null a then t else if car a leq car b then testord(cdr a,cdr b) else nil; symbolic procedure tanfrom(rhs!*,z,nnn); % We notice that in all bad cases we have (j-num)tan**j...; % Extract the num; begin scalar n,zz,r,rr; r:=rhs!*; n:=0; zz:=zlist; while car zz neq z do << n:=n+1; zz:=cdr zz >>; a: if null r then go to b; rr:=caar r; % The list of powers; for i:=1:n do rr:=cdr rr; if fixp caar rr then if caar rr>0 then << rr:=numr cdar r; if null red rr then rr:=nil ./ 1 else if fixp (rr:=quotf(red rr,lc rr)) then rr:=-rr else rr:=0>>; if atom rr then go to b; r:=cdr r; go to a; b: if null r then return maxfrom(lhs!*,nnn)+1; return max(rr,maxfrom(lhs!*,nnn)+1) end; symbolic procedure coefdf(y,u); if y=nil then nil else if lpow y=u then lc y else coefdf(red y,u); symbolic procedure purgeconst(a,b); % Remove a const from and expression. May be the same as DELETE?; if null a then nil else if car a=b then purgeconst(cdr a,b) else cons(car a,purgeconst(cdr a,b)); symbolic procedure maxorder(rhs!*,z,n); % Find a limit on the order of terms, theis is ad hoc; if null z then nil else if eqcar(car z,'sqrt) then cons(1,maxorder(rhs!*,cdr z,n+1)) else if (atom car z) or (caar z neq 'tan) then cons(maxfrom(lhs!*,n)+1,maxorder(rhs!*,cdr z,n+1)) else cons(tanfrom(rhs!*,car z,n),maxorder(rhs!*,cdr z,n+1)); symbolic procedure maxfrom(l,n); % Largest order in the nth varable; if null l then 0 else max(nth(caar l,n+1),maxfrom(cdr l,n)); symbolic procedure copy u; if atom u then u else cons(copy car u,copy cdr u); symbolic procedure addctomap cc; begin scalar ncval; ccount:=ccount+1; ncval:=mkvect(ccount); for i:=0:(ccount-1) do putv(ncval,i,getv(cval,i)); putv(ncval,ccount,nil ./ 1); cval:=ncval; cmap:=(cc . ccount).cmap; if !*trint then << prin2 "Constant map changed to "; print cmap >>; cmatrix:=mapcar(cmatrix,function addtovector); end; symbolic procedure addtovector v; begin scalar vv; vv:=mkvect(ccount); for i:=0:(ccount-1) do putv(vv,i,getv(v,i)); putv(vv,ccount,nil); return vv end; symbolic procedure checkcoeffts(cl,indv); % checks to see that the coefficients in CL (coefficient list - S.Q.s); % are zero when the i,j,k,... are given values in INDV (LPOW of; % D.F.). if so the result is true else NIL=false; if null cl then t else begin scalar res; res:=evaluatecoeffts(numr car cl,indv); if not(null res or res=0) then return nil else return checkcoeffts(cdr cl,indv) end; symbolic procedure nextu(ltrhs,powlhs); % picks out the appropriate U coefficients for term: LTRHS to match the % powers of the z-variables given in POWLHS (= exponent list of D.F.). % return this coefficient in form LT of D.F. If U coefficient does % not exist then result is NIL. If it is multiplied by a zero then % result is NIL; if null ltrhs then nil else begin scalar indlist,ucoefft; indlist:=subtractinds(powlhs,car ltrhs,nil); if null indlist then return nil; ucoefft:=evaluatecoeffts(numr cdr ltrhs,indlist); if null ucoefft or ucoefft=0 then return nil; return indlist .* (ucoefft ./ denr cdr ltrhs) end; symbolic procedure subtractinds(powlhs,l,sofar); % subtract the indices in list L from those in POWLHS to find; % appropriate values for i,j,k,... when equating coefficients of terms; % on lhs of reduction eqn. SOFAR is the resulting value list we; % have constructed so far. if any i,j,k,... value is -ve then result; % is NIL; if null l then reversewoc sofar else if ((car powlhs)-(caar l))<0 then nil else subtractinds(cdr powlhs,cdr l, ((car powlhs)-(caar l)) . sofar); symbolic procedure gausselimn(equation,tokill); % Performs Gaussian elimination on the matrix for the c-equations; % as each c-equation is found. EQUATION is the next one to deal with; begin scalar newrow,pivot; if zerop ccount then go to noway; %failure newrow:=mkvect(ccount); spreadc(equation,newrow,1); subst4eliminatedcs(newrow,reverse orderofelim,reverse cmatrix); pivot:=findpivot newrow; if null pivot then go to nopivotfound; orderofelim:=pivot . orderofelim; newrow:=makeprim newrow; %remove hcf from new equation cmatrix:=newrow . cmatrix; % if !*trint then printspreadc newrow; return t; nopivotfound: if null getv(newrow,0) then << if !*trint then printc "Already included"; return nil>>; %equation was 0=0 noway: badpart:=tokill . badpart; %non-integrable term. if !*trint then printc "Inconsistent"; return nil end; symbolic procedure makeprim row; begin scalar g; g:=getv(row,0); for i:=1:ccount do g:=gcdf(g,getv(row,i)); if g neq 1 then for i:=0:ccount do putv(row,i,quotf(getv(row,i),g)); for i := 0:ccount do <<g := getv(row,i); if g and not domainp g then putv(row,i,numr resimp((rootextractf g) ./ 1))>>; return row end; endmodule; module sqrtf; % Square root of standard forms. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(!*noextend zlist); exports minusdfp,sqrtdf,nrootn,domainp,minusf; imports contentsmv,gcdf,interr,!*multf,partialdiff,printdf,quotf, simpsqrt2,vp2; symbolic procedure minusdfp a; % Test sign of leading coedd of d.f. if null a then interr "Minusdfp 0 illegal" else minusf numr lc a; symbolic procedure sqrtdf l; % Takes square root of distributive form. "Failed" usually means % that the square root is not among already existing objects. if null l then nil else begin scalar c; if lpow l=vp2 zlist then go to ok; c:=sqrtsq df2q l; if numr c eq 'failed then return 'failed; if denr c eq 'failed then return 'failed; return for each u in f2df numr c collect (car u).!*multsq(cdr u,1 ./ denr c); ok: c:=sqrtsq lc l; if numr c eq 'failed or denr c eq 'failed then return 'failed else return (lpow l .* c) .+nil end; symbolic procedure sqrtsq a; sqrtf numr a ./ sqrtf denr a; symbolic procedure sqrtf p; begin scalar ip,qp; if null p then return nil; ip:=sqrtf1 p; qp:=cdr ip; ip:=car ip; %respectable and nasty parts of the sqrt. if qp=1 then return ip; %exact root found. if !*noextend then return 'failed; % We cannot add new square roots in this case, since it is % then impossible to determine if one square root depends % on another if new ones are being added all the time. if zlistp qp then return 'failed; % Liouville's theorem tells you that you never need to add % new algebraics depending on the variable of integration. qp:=simpsqrt2 qp; return !*multf(ip,qp) end; symbolic procedure zlistp qp; if atom qp then member(qp,zlist) else or(member(mvar qp,zlist),zlistp lc qp,zlistp red qp); symbolic procedure sqrtf1 p; % Returns a . b with p=a**2*b. if domainp p then if fixp p then nrootn(p,2) else !*q2f simpsqrt list prepf p . 1 else begin scalar co,pp,g,pg; co:=contentsmv(p,mvar p,nil); %contents of p. pp:=quotf(p,co); %primitive part. co:=sqrtf1(co); %process contents via recursion. g:=gcdf(pp,partialdiff(pp,mvar pp)); pg:=quotf(pp,g); g:=gcdf(g,pg); %a repeated factor of pp. if g=1 then pg:=1 . pp else << pg:= quotf(pp,!*multf(g,g)); %what is still left. pg:=sqrtf1(pg); %split that up. rplaca(pg,!*multf(car pg,g))>>; %put in the thing found here. rplaca(pg, !*multf(car pg,car co)); rplacd(pg, !*multf(cdr pg,cdr co)); return pg end; % NROOTN removed as in REDUCE base. endmodule; module tdiff; % Differentiation routines for integrator. % Authors: Mary Ann Moore and Arthur C. Norman. exports !-!-simpdf; imports simpcar,kernp,diffsq,prepsq,msgpri; flag('(!-!-simpdf),'lose); symbolic procedure !-!-simpdf u; % U is a list of forms, the first an expression and the remainder % kernels and numbers. % Value is derivative of first form wrt rest of list. begin scalar v,x,y,tt; tt := time(); %start the clock; v := cdr u; u := simpcar u; a: if null v or null numr u then go to exit; x := if null y or y=0 then simpcar v else y; if null kernp x then go to e; x := caaaar x; v := cdr v; if null v then go to c; y := simpcar v; if null numr y then go to d else if not denr y=1 or not numberp numr y then go to c; y := car y; v := cdr v; b: if y=0 then go to a; u := diffsq(u,x); y := y-1; go to b; c: u := diffsq(u,x); go to a; d: y := nil; v := cdr v; go to a; exit: print list('time,time()-tt); return u; e: msgpri("Differentiation wrt",prepsq x,"not allowed",nil,t) end; put('tdf,'simpfn,'!-!-simpdf); endmodule; module tidysqrt; % General tidying up of square roots. % Authors: Mary Ann Moore and Arthur C. Norman. % Modifications by J.H. Davenport. exports sqrt2top,tidysqrt; %symbolic procedure tidysqrtdf a; % if null a then nil % else begin scalar tt,r; % tt:=tidysqrt lc a; % r:=tidysqrtdf red a; % if null numr tt then return r; % return ((lpow a) .* tt) .+ r % end; % symbolic procedure tidysqrt q; begin scalar nn,dd; nn:=tidysqrtf numr q; if null nn then return nil ./ 1; %answer is zero. dd:=tidysqrtf denr q; return multsq(nn,invsq dd) end; symbolic procedure tidysqrtf p; %Input - standard form. %Output - standard quotient. %Simplifies sqrt(a)**n with n>1. if domainp p then p ./ 1 else begin scalar v,w; v:=lpow p; if car v='i then v:=mksp('(sqrt -1),cdr v); %I->sqrt(-1); if eqcar(car v,'sqrt) and not onep cdr v then begin scalar x; %here we have a reduction to apply. x:=divide(cdr v,2); %halve exponent. w:=exptsq(simp cadar v,car x); %rational part of answer. if not zerop cdr x then w:=multsq(w, ((mksp(car v,1) .* 1) .+ nil) ./ 1); %the next line allows for the horrors of nested sqrts. w:=tidysqrt w end else w:=((v .* 1) .+ nil) ./ 1; v:=multsq(w,tidysqrtf lc p); return addsq(v,tidysqrtf red p) end; symbolic procedure multoutdenr q; % Move sqrts in a sq to the numerator. begin scalar n,d,root,conj; n:=numr q; d:=denr q; while (root:=findsquareroot d) do << conj:=conjugatewrt(d,root); n:=!*multf(n,conj); d:=!*multf(d,conj) >>; while (root:=findnthroot d) do << conj:=conjugateexpt(d,root,kord!*); n:=!*multf(n,conj); d:=!*multf(d,conj) >>; return (n . d); end; symbolic procedure conjugateexpt(d,root,kord!*); begin scalar ord,ans,repl,xi; ord:=caddr caddr root; % the denominator of the exponent; ans:=1; kord!*:= (xi:=gensym()) . kord!*; % XI is an ORD'th root of unity; for i:=1:ord-1 do << ans:=!*multf(ans,numr subf(d, list(root . list('times,root,list('explt,xi,i))))); while (mvar ans eq xi) and ldeg ans > ord do ans:=addf(red ans,(xi) to (ldeg ans - ord) .* lc ans .+ nil); if (mvar ans eq xi) and ldeg ans = ord then ans:=addf(red ans,lc ans) >>; if (mvar ans eq xi) and ldeg ans = ord-1 then << repl:=-1; for i:=1:ord-2 do repl:=(xi) to i .* -1 .+ repl; ans:=addf(red ans,!*multf(lc ans,repl)) >>; if not domainp ans and mvar ans eq xi then interr "Conjugation failure"; return ans; end; symbolic procedure sqrt2top q; begin scalar n,d; n:=multoutdenr q; d:=denr n; n:=numr n; if d eq denr q then return q;%no change. if d iequal 1 then return (n ./ 1); q:=gcdcoeffsofsqrts n; if q iequal 1 then if minusf d then return (negf n ./ negf d) else return (n ./ d); q:=gcdf(q,d); n:=quotf(n,q); d:=quotf(d,q); if minusf d then return (negf n ./ negf d) else return (n ./ d) end; %symbolic procedure denrsqrt2top q; %begin % scalar n,d; % n:=multoutdenr q; % d:=denr n; % n:=numr n; % if d eq denr q % then return d; % no changes; % if d iequal 1 % then return 1; % q:=gcdcoeffsofsqrts n; % if q iequal 1 % then return d; % q:=gcdf(q,d); % if q iequal 1 % then return d % else return quotf(d,q) % end; symbolic procedure findsquareroot p; % Locate a sqrt symbol in poly p. if domainp p then nil else begin scalar w; w:=mvar p; %check main var first. if atom w then return nil; %we have passed all sqrts. if eqcar(w,'sqrt) then return w; w:=findsquareroot lc p; if null w then w:=findsquareroot red p; return w end; symbolic procedure findnthroot p; nil; % Until corrected. symbolic procedure x!-findnthroot p; % Locate an n-th root symbol in poly p. if domainp p then nil else begin scalar w; w:=mvar p; %check main var first. if atom w then return nil; %we have passed all sqrts. if eqcar(w,'expt) and eqcar(caddr w,'quotient) then return w; w:=findnthroot lc p; if null w then w:=findnthroot red p; return w end; symbolic procedure conjugatewrt(p,var); % Var -> -var in form p. if domainp p then p else if mvar p=var then begin scalar x,c,r; x:=tdeg lt p; %degree c:=lc p; %coefficient r:=red p; %reductum x:=remainder(x,2); %now just 0 or 1. if x=1 then c:=negf c; %-coefficient. return (lpow p .* c) .+ conjugatewrt(r,var) end else if ordop(var,mvar p) then p else (lpow p .* conjugatewrt(lc p,var)) .+ conjugatewrt(red p,var); symbolic procedure gcdcoeffsofsqrts u; if atom u then if numberp u and minusp u then -u else u else if eqcar(mvar u,'sqrt) then begin scalar v; v:=gcdcoeffsofsqrts lc u; if v iequal 1 then return v else return gcdf(v,gcdcoeffsofsqrts red u) end else begin scalar root; root:=findsquareroot u; if null root then return u; u:=makemainvar(u,root); root:=gcdcoeffsofsqrts lc u; if root iequal 1 then return 1 else return gcdf(root,gcdcoeffsofsqrts red u) end; endmodule; module trcase; % Driving routine for integration of transcendental fns. % Authors: Mary Ann Moore and Arthur C. Norman. % Modifications by: John P. Fitch. fluid '(!*backtrace !*nowarnings !*purerisch !*reverse badpart ccount cmap cmatrix content cuberootflag cval denbad denominator indexlist lhs!* loglist lorder orderofelim rhs!* sillieslist sqfr sqrtflag sqrtlist tanlist svar varlist xlogs zlist); % !*reverse: flag to re-order zlist. % !*nowarnings: flag to lose messages. global '(!*failhard !*number!* !*ratintspecial !*seplogs !*spsize!* !*statistics !*trint gensymcount); switch failhard; exports transcendentalcase; imports backsubst4cs,countz,createcmap,createindices,df2q,dfnumr, difflogs,fsdf,factorlistlist,findsqrts,findtrialdivs,gcdf,mkvect, interr,logstosq,mergin,multbyarbpowers,!*multf,multsqfree, printdf,printsq,quotf,rationalintegrate,putv, simpint1,solve!-for!-u,sqfree,sqmerge,sqrt2top,substinulist,trialdiv, mergein,negsq,addsq,f2df,mknill,pnth,invsq,multsq,domainp,mk!*sq, mksp,prettyprint,prepsq; % Note that SEPLOGS keeps logarithmic part of result together as a % kernel form, but this can lead to quite messy results. symbolic procedure transcendentalcase(integrand,svar,xlogs,zlist,varlist); begin scalar divlist,jhd!-content,content,prim,sqfr,dfu,indexlist, % JHD!-CONTENT is local, while CONTENT is free (set in SQFREE). sillieslist,originalorder,wrongway, sqrtlist,tanlist,loglist,dflogs,eprim,dfun,unintegrand, sqrtflag,badpart,rhs!*,lhs!*,gcdq,cmap,cval,orderofelim,cmatrix; scalar cuberootflag,ccount,denominator,result,denbad; gensymcount:=0; integrand:=sqrt2top integrand; % Move the sqrts to the numerator. if !*trint then << printc "Extension variables z<i> are"; print zlist>>; if !*ratintspecial and null cdr zlist then return rationalintegrate(integrand,svar); % *** now unnormalize integrand, maybe ***. begin scalar w,gg; gg:=1; foreach z in zlist do << w:=subs2 diffsq(simp z,svar); gg:=!*multf(gg,quotf(denr w,gcdf(denr w,gg))) >>; gg:=quotf(gg,gcdf(gg,denr integrand)); unintegrand:=(!*multf(gg,numr integrand) ./ !*multf(gg,denr integrand)); if !*trint then << printc "Unnormalized integrand ="; printsq unintegrand >> end; divlist:=findtrialdivs zlist; %also puts some things on loglist sometimes. % if !*trint % then << printc "Exponentials and tans to try dividing:"; % print divlist>>; sqrtlist:=findsqrts zlist; % if !*trint then << printc "Square-root z-variables"; % print sqrtlist >>; divlist:=trialdiv(denr unintegrand,divlist); % if !*trint then << printc "Divisors:"; % print car divlist; % print cdr divlist>>; %n.b. the next line also sets 'content' as a free variable. % Since SQFREE may be used later, we copy it into JHD!-CONTENT. prim:=sqfree(cdr divlist,zlist); jhd!-content:=content; printfactors(prim,nil); eprim:=sqmerge(countz car divlist,prim,nil); printfactors(eprim,t); % if !*trint then << terpri(); % printsf denominator; % terpri(); % printc "...content is:"; % printsf jhd!-content>>; sqfr:=for each u in eprim collect multup u; % sqfr:=multsqfree eprim; % if !*trint then << printc "...sqfr is:"; % superprint sqfr>>; if !*reverse then zlist:=reverse zlist; %ALTER ORDER FUNCTION; indexlist:=createindices zlist; % if !*trint then << printc "...indices are:"; % superprint indexlist>>; dfu:=dfnumr(svar,car divlist); % if !*trint then << terpri(); % printc "************ Derivative of u is:"; % printsq dfu>>; loglist:=append(loglist,factorlistlist (prim,nil)); loglist:=mergein(xlogs,loglist); loglist:=mergein(tanlist,loglist); cmap:=createcmap(); ccount:=length cmap; if !*trint then << printc "Loglist "; print loglist >>; dflogs:=difflogs(loglist,denr unintegrand,svar); if !*trint then << printc "************ 'Derivative' of logs is:"; printsq dflogs>>; dflogs:=addsq((numr unintegrand) ./ 1,negsq dflogs); % Put everything in reduction eqn over common denominator. gcdq:=gcdf(denr dflogs,denr dfu); dfun:= !*multf(numr dfu, denbad:=quotf(denr dflogs,gcdq)); denbad:=!*multf(denr dfu,denbad); denbad:= !*multf(denr unintegrand,denbad); dflogs:= !*multf(numr dflogs,quotf(denr dfu,gcdq)); dfu:=dfun; % Now DFU and DFLOGS are S.F.s. rhs!*:=multbyarbpowers f2df dfu; if checkdffail(rhs!*,svar) then interr "Simplification failure"; if !*trint then << printc "Distributed Form of U is:"; printdf rhs!*>>; lhs!*:=f2df dflogs; if checkdffail(lhs!*,svar) then interr "Simplification failure"; if !*trint then << printc "Distributed Form of l.h.s. is:"; printdf lhs!*; terpri()>>; cval:=mkvect(ccount); for i:=0 : ccount do putv(cval,i,nil ./ 1); lorder:=maxorder(rhs!*,zlist,0); originalorder:=lorder; if !*trint then << printc "Maximum order determined as "; print lorder >>; if !*statistics then << !*number!*:=0; !*spsize!*:=1; foreach xx in lorder do !*spsize!*:=!*spsize!* * (xx+1) >>; % That calculates the largest U that can appear. dfun:=solve!-for!-u(rhs!*,lhs!*,nil); backsubst4cs(nil,orderofelim,cmatrix); % if !*trint then if not (ccount=0) then printvecsq cval; if !*statistics then << prin2 !*number!*; prin2 " used out of "; printc !*spsize!* >>; badpart:=substinulist badpart; %substitute for c<i> still in badpart. dfun:=df2q substinulist dfun; % if !*trint then superprint dfun; result:= !*multsq(dfun,!*invsq(denominator ./ 1)); result:= !*multsq(result,!*invsq(jhd!-content ./ 1)); % if !*trint then superprint result; dflogs:=logstosq(); if not null numr dflogs then << if !*seplogs and (not domainp numr result) then << result:=mk!*sq result; result:=(mksp(result,1) .* 1) .+ nil; result:=result ./ 1 >>; result:=addsq(result,dflogs)>>; if !*trint then << superprint result; terpri(); printc "*****************************************************"; printc "************ THE INTEGRAL IS : **********************"; printc "*****************************************************"; terpri(); printsq result; terpri()>>; if not null badpart then << if !*trint then printc "plus a bad part"; lhs!*:=badpart; lorder:=maxorder(rhs!*,zlist,0); while lorder do << if car lorder > car originalorder then wrongway:=t; lorder:=cdr lorder; originalorder:=cdr originalorder >>; dfun:=df2q badpart; if !*trint then <<printsq dfun; printc "Denbad = "; printsf denbad>>; dfun:= !*multsq(dfun,invsq(denbad ./ 1)); if wrongway then << result:= nil ./ 1; dfun:=integrand >>; if rootcheckp(unintegrand,svar) then return simpint1(integrand . svar.nil) else if !*purerisch or allowedfns zlist then dfun:=simpint1 (dfun . svar.nil) else << !*purerisch:=t; if !*trint then <<printc " [Transforming ..."; printsq dfun>>; denbad:=transform(dfun,svar); if denbad=dfun then dfun:=simpint1(dfun . svar.nil) else <<denbad:=errorset('(integratesq denbad svar xlogs), !*backtrace,!*backtrace); if not atom denbad then dfun:=untan car denbad else dfun:=simpint1(dfun . svar.nil) >> >>; if !*trint then printsq dfun; if !*failhard then rederr "FAILHARD switch set"; if !*seplogs and not domainp result then << result:=mk!*sq result; if not numberp result then result:=(mksp(result,1) .* 1) .+ nil; result:=result ./ 1>>; result:=addsq(result,dfun) >>; % if !*overlaymode then excise transcode; return sqrt2top result end; symbolic procedure checkdffail(u,v); u and (depends(lc u,v) or checkdffail(red u,v)); symbolic procedure printfactors(w,prdenom); % W is a list of factors to each power. If PRDENOM is true % this prints denominator of answer, else prints square-free % decomposition. begin scalar i,wx; i:=1; if prdenom then << denominator:=1; if !*trint then printc "Denominator of 1st part of answer is:"; if not null w then w:=cdr w >>; loopx: if w=nil then return; if !*trint then <<prin2 "Factors of multiplicity "; print i>>; wx:=car w; while not null wx do << if !*trint then printsf car wx; for j:=1 : i do denominator:= !*multf(car wx,denominator); wx:=cdr wx >>; i:=i+1; w:=cdr w; go to loopx end; % unfluid '(dfun svar xlogs); endmodule; module halfangle; % Routines for conversion to half angle tangents. % Author: Steve Harrington. % Modifications by: John P. Fitch. fluid '(!*gcd); exports halfangle,untan; symbolic procedure transform(u,x); % Transform the SQ U to remove the 'bad' functions sin, cos, cot etc % in favor of half angles; halfangle(u,x); symbolic procedure quotqq(u1,v1); multsq(u1, invsq(v1)); symbolic procedure !*subtrq(u1,v1); addsq(u1, negsq(v1)); symbolic procedure !*int2qm(u1); if u1=0 then nil . 1 else u1 . 1; symbolic procedure halfangle(r,x); % Top level procedure for converting; % R is a rational expression to be converted, % X the integration variable. % A rational expression is returned. quotqq(hfaglf(numr(r),x), hfaglf(denr(r),x)); symbolic procedure hfaglf(p,x); % Converting polynomials, a rational expression is returned. if domainp(p) then !*f2q(p) else subs2q addsq(multsq(exptsq(hfaglk(mvar(p),x), ldeg(p)), hfaglf(lc(p),x)), hfaglf(red(p),x)); symbolic procedure hfaglk(k,x); % Converting kernels, a rational expression is returned. begin scalar kt; if atom k or not member(x,flatten(cdr(k))) then return !*k2q k; k := car(k) . hfaglargs(cdr(k), x); kt := simp list('tan, list('quotient, cadr(k), 2)); return if car(k) = 'sin then quotqq(multsq(!*int2qm(2),kt), addsq(!*int2qm(1), exptsq(kt,2))) else if car(k) = 'cos then quotqq(!*subtrq(!*int2qm(1),exptsq(kt,2)),addsq(!*int2qm(1), exptsq(kt,2))) else if car(k) = 'tan then quotqq(multsq(!*int2qm(2),kt), !*subtrq(!*int2qm(1), exptsq(kt,2))) else if car(k) = 'sinh then quotqq(!*subtrq(exptsq(!*k2q('expt.('e. cdr k)),2), !*int2qm(1)), multsq(!*int2qm(2), !*k2q('expt . ('e . cdr(k))))) else if car(k) = 'cosh then quotqq(addsq(exptsq(!*k2q('expt.('e. cdr k)),2), !*int2qm(1)), multsq(!*int2qm(2), !*k2q('expt . ('e . cdr(k))))) else if car(k) = 'tanh then quotqq(!*subtrq(exptsq(!*k2q('expt.('e. cdr k)),2), !*int2qm(1)), addsq(exptsq(!*k2q ('expt.('e.cdr(k))),2), !*int2qm(1))) else !*k2q(k); % additional transformation might be added here. end; symbolic procedure hfaglargs(l,x); % Conversion of argument list. if null l then nil else prepsq(hfaglk(car(l),x)) . hfaglargs(cdr(l), x); symbolic procedure untanf x; % This should be done by a table. begin scalar y,z,w; if domainp x then return x . 1; y := mvar x; if eqcar(y,'int) then error1(); % assume all is hopeless. z := ldeg x; w := 1 . 1; y := if atom y then !*k2q y else if car y eq 'tan then if evenp z then <<z := z/2; simp list('quotient, list('plus, list('minus, list('cos, 'times . (2 . cdr y))), 1),list('plus, list('cos, 'times . (2 . cdr y)), 1))>> else if z=1 then simp list('quotient, list('plus, list('minus, list('cos, 'times . (2 . cdr y))), 1),list('sin, 'times . (2 . cdr y))) else <<z := (z - 1)/2; w := simp list('quotient, list('plus, list('minus, list('cos, 'times . (2 . cdr y))), 1),list('sin, 'times . (2 . cdr y))); simp list('quotient, list('plus, list('minus, list('cos, 'times . (2 . cdr y))), 1),list('plus, list('cos, 'times . (2 . cdr y)), 1))>> else simp y; return addsq(multsq(multsq(exptsq(y,z),untanf lc x),w), untanf red x) end; symbolic procedure untanlist(y); if null y then nil else (prepsq (untan(simp car y)) . untanlist(cdr y)); symbolic procedure untan(x); % Expects x to be canonical quotient. begin scalar y; y:=cossqchk sinsqrdchk multsq(untanf(numr x), invsq untanf(denr x)); return if length flatten y>length flatten x then x else y end; symbolic procedure sinsqrdchk(x); multsq(sinsqchkf(numr x), invsq sinsqchkf(denr x)); symbolic procedure sinsqchkf(x); begin scalar y,z,w; if domainp x then return x . 1; y := mvar x; z := ldeg x; w := 1 . 1; y := if eqcar(y,'sin) then if evenp z then <<z := quotient(z,2); simp list('plus,1,list('minus, list('expt,('cos . cdr(y)),2)))>> else if z = 1 then !*k2q y else << z := quotient(difference(z,1),2); w := !*k2q y; simp list('plus,1,list('minus, list('expt,('cos . cdr(y)),2)))>> else !*k2q y; return addsq(multsq(multsq(exptsq(y,z),sinsqchkf(lc x)),w), sinsqchkf(red x)); end; symbolic procedure cossqchkf(x); begin scalar y,z,w,x1,x2; if domainp x then return x . 1; y := mvar x; z := ldeg x; w := 1 . 1; x1 := cossqchkf(lc x); x2 := cossqchkf(red x); x := addsq(multsq(!*p2q lpow x,x1),x2); y := if eqcar(y,'cos) then if evenp z then <<z := quotient(z,2); simp list('plus,1,list('minus, list('expt,('sin . cdr(y)),2)))>> else if z = 1 then !*k2q y else << z := quotient(difference(z,1),2); w := !*k2q y; simp list('plus,1,list('minus, list('expt,('sin . cdr(y)),2)))>> else !*k2q y; y := addsq(multsq(multsq(exptsq(y,z),w),x1),x2); return if length(y) > length(x) then x else y; end; symbolic procedure cossqchk(x); begin scalar !*gcd; !*gcd := t; return multsq(cossqchkf(numr x), invsq cossqchkf(denr x)) end; symbolic procedure lrootchk(l,x); % Checks each member of list l for a root. if null l then nil else krootchk(car l, x) or lrootchk(cdr l, x); symbolic procedure krootchk(f,x); % Checks a kernel to see if it is a root. if atom f then nil else if car(f) = 'sqrt and member(x, flatten cdr f) then t else if car(f) = 'expt and not atom caddr(f) and caaddr(f) = 'quotient and member(x, flatten cadr f) then t else lrootchk(cdr f, x); symbolic procedure rootchk1p(f,x); % Checks polynomial for a root. if domainp f then nil else krootchk(mvar f,x) or rootchk1p(lc f,x) or rootchk1p(red f,x); symbolic procedure rootcheckp(f,x); % Checks rational (standard quotient) for a root. rootchk1p(numr f,x) or rootchk1p(denr f,x); endmodule; module trialdiv; % Trial division routines. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(denominator loglist tanlist); global '(!*trint); exports countz,findsqrts,findtrialdivs,trialdiv,simp,mksp; imports !*multf,printsf,quotf; symbolic procedure countz dl; % DL is a list of S.F.s; begin scalar s,n,rl; loop2: if null dl then return arrangelistz rl; n:=1; loop1: n:=n+1; s:=car dl; dl:=cdr dl; if not null dl and (s eq car dl) then go to loop1 else rl:=(s.n).rl; go to loop2 end; symbolic procedure arrangelistz d; begin scalar n,s,rl,r; n:=1; if null d then return rl; loopd: if (cdar d)=n then s:=(caar d).s else r:=(car d).r; d:=cdr d; if not null d then go to loopd; d:=r; rl:=s.rl; s:=nil; r:=nil; n:=n+1; if not null d then go to loopd; return reversewoc rl end; symbolic procedure findtrialdivs zl; %zl is list of kernels found in integrand. result is a list %giving things to be treated specially in the integration %viz: exps and tans. %Result is list of form ((a . b) ...) % with a a kernel and car a=expt or tan % and b a standard form for either expt or (1+tan**2). begin scalar dlists1,args1; while not null zl do << if exportan car zl then << if caar zl='tan then << args1:=(mksp(car zl,2) .* 1) .+ 1; tanlist:=(args1 ./ 1) . tanlist>> else args1:=!*k2f car zl; dlists1:=(car zl . args1) . dlists1>>; zl:=cdr zl >>; return dlists1 end; symbolic procedure exportan dl; if atom dl then nil else begin % extract exp or tan fns from the z-list. if eq(car dl,'tan) then return t; nxt: if not eq(car dl,'expt) then return nil; dl:=cadr dl; if atom dl then return t; % Make sure we find nested exponentials? go to nxt end; symbolic procedure findsqrts z; begin scalar r; while not null z do << if eqcar(car z,'sqrt) then r:=(car z) . r; z:=cdr z >>; return r end; symbolic procedure trialdiv(x,dl); begin scalar qlist,q; while not null dl do if not null(q:=quotf(x,cdar dl)) then << if (caaar dl='tan) and not eqcar(qlist,cdar dl) then loglist:=('iden . simp cadr caar dl) . loglist; %tan fiddle! qlist:=(cdar dl).qlist; x:=q >> else dl:=cdr dl; return qlist.x end; endmodule; module unifac; % Univariate factorization for integration. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(knowndiscrimsign zlist); global '(!*trint); exports unifac; imports cubic,linfac,printdf,quadfac,quadratic,quartic,vp1, gcd,minusp,prettyprint; symbolic procedure unifac(pol,var,degree,res); begin scalar w,q,c; w:=pol; if !*trint then superprint w; %now try looking for linear factors. trylin: q:=linfac(w); if null car q then go to nomorelin; res := ('log . back2df(car q,var)) . res; w:=cdr q; go to trylin; nomorelin: q:=quadfac(w); if null car q then go to nomorequad; res := quadratic(back2df(car q,var),var,res); w:=cdr q; go to nomorelin; nomorequad: if null w then return res; %all done. degree:=car w; %degree of what is left. c:=back2df(w,var); if degree=3 then res:=cubic(c,var,res) else if degree=4 then res:=quartic(c,var,res) else if evenp degree and pairp (q := halfpower cddr w) then <<w := (degree/2) . (cadr w . q); w := unifac(w,var,car w,nil); res := pluckfactors(w,var,res)>> else << printc "The following has not been split"; printdf c; res:=('log . c) . res>>; return res end; symbolic procedure halfpower w; if null w then nil else if car w=0 then (lambda r; if r eq 'failed then r else cadr w . r) halfpower cddr w else 'failed; symbolic procedure pluckfactors(w,var,res); begin scalar p,q,knowndiscrimsign; while w do <<p := car w; if car p eq 'atan then nil else if car p eq 'log then <<q := doublepower cdr p . q; %prin2 "q="; %printdf car q; >> else interr "Bad form"; w := cdr w>>; while q do <<p := car q; if caaar p=4 then <<knowndiscrimsign := 'negative; res := quartic(p,var,res); knowndiscrimsign := nil>> else if caaar p=2 then res := quadratic(p,var,res) else res := ('log . p) . res; q := cdr q>>; return res end; symbolic procedure doublepower r; if null r then nil else ((for each j in caar r collect 2*j) . cdar r) . doublepower cdr r; symbolic procedure back2df(p,v); % Undo the effect of uniform. begin scalar r,n; n:=car p; p:=cdr p; while not minusp n do << if not zerop car p then r:= (vp1(v,n,zlist) .* (car p ./ 1)) .+ r; p:=cdr p; n:=n-1 >>; return reversewoc r end; endmodule; module uniform; % Convert from D.F. to list of coefficients. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(zlist); exports uniform; imports exponentof; symbolic procedure uniform(p,v); %Convert from d.f. in one variable (v) to a simple list of %coeffs (with degree consed onto front). %Fails if coefficients are not all simple integers. if null p then 0 . (0 . nil) else begin scalar a,b,c,d; a:=exponentof(v,lpow p,zlist); b:=lc p; if not(denr b=1) then return 'failed; b:=numr b; if null b then b:=0 else if not numberp b then return 'failed; if a=0 then return a . (b . nil); %constant term. c:=uniform(red p,v); if c='failed then return 'failed; d:=car c; c:=cdr c; d:=d+1; while not (a=d) do << c:=0 . c; d:=d+1>>; return a . (b . c) end; endmodule; module makevars; % Make dummy variables for integration process. % Authors: Mary Ann Moore and Arthur C. Norman. fluid '(!*gensymlist!* !*purerisch); exports getvariables,varsinlist,varsinsq,varsinsf,findzvars, createindices,mergein; imports dependsp,union; % Note that 'i' is already maybe committed for sqrt(-1), % also 'l' and 'o' are not used as they print badly on certain % terminals etc and may lead to confusion. !*gensymlist!* := '(! j ! k ! m ! n ! p ! q ! r ! s ! t ! u ! v ! w ! x ! y ! z); %mapc(!*gensymlist!*,function remob); %REMOB protection; symbolic procedure varsinlist(l,vl); % L is a list of s.q. - find all variables mentioned, % given thal vl is a list already known about. begin while not null l do << vl:=varsinsf(numr car l,varsinsf(denr car l,vl)); l:=cdr l >>; return vl end; symbolic procedure getvariables sq; varsinsf(numr sq,varsinsf(denr sq,nil)); symbolic procedure varsinsq(sq,vl); varsinsf(numr sq,varsinsf(denr sq,vl)); symbolic procedure varsinsf(form,l); if domainp form then l else begin while not domainp form do << l:=varsinsf(lc form,union(l,list mvar form)); form:=red form >>; return l end; symbolic procedure findzvars(vl,zl,var,flg); begin scalar v; % VL is the crude list of variables found in the original integrand; % ZL must have merged into it all EXP, LOG etc terms from this. % If FLG is true then ignore DF as a function. scan: if null vl then return zl; v:=car vl; % next variable. vl:=cdr vl; % at present items get put onto ZL if they are non-atomic % and they depend on the main variable. The arguments of % functions are decomposed by recursive calls to findzvar. %give up if V has been declared dependent on other things; if atom v and v neq var and depends(v,var) then rederr "Can't integrate in the presence of side-relations" else if not atom v and (not v member zl) and dependsp(v,var) then if car v='!*sq then zl:=findzvarssq(cadr v,zl,var) else if car v memq '(times quotient plus minus difference int) or (((car v) eq 'expt) and fixp caddr v) then zl:=findzvars(cdr v,zl,var,flg) else if flg and car v eq 'df then <<!*purerisch := t; return zl>> % try and stop it else zl:=v . findzvars(cdr v,zl,var,flg); % scan arguments of fn. %ACH: old code used to look only at CADR if a DF involved. go to scan end; symbolic procedure findzvarssq(sq,zl,var); findzvarsf(numr sq,findzvarsf(denr sq,zl,var),var); symbolic procedure findzvarsf(sf,zl,var); if domainp sf then zl else findzvarsf(lc sf, findzvarsf(red sf, findzvars(list mvar sf,zl,var,nil), var), var); symbolic procedure createindices zl; % Produces a list of unique indices, each associated with a ; % different Z-variable; reversewoc crindex1(zl,!*gensymlist!*); symbolic procedure crindex1(zl,gl); begin if null zl then return nil; if null gl then << gl:=list int!-gensym1 'i; %new symbol needed; nconc(!*gensymlist!*,gl) >>; return (car gl) . crindex1(cdr zl,cdr gl) end; symbolic procedure rmember(a,b); if null b then nil else if a=cdar b then car b else rmember(a,cdr b); symbolic procedure mergein(dl,ll); % Adjoin logs of things in dl to existing list ll. if null dl then ll else if rmember(car dl,ll) then mergein(cdr dl,ll) else mergein(cdr dl,('log . car dl) . ll); endmodule; module vect; % Vector support routines. % Authors: Mary Ann Moore and Arthur C. Norman. % Modified by: James H. Davenport. exports mkuniquevect,mkvec,mkvecf2q,mkidenm,copyvec,vecsort,swap, non!-null!-vec,mkvect2; symbolic procedure mkuniquevect v; begin scalar u,n; n:=upbv v; for i:=0:n do begin scalar uu; uu:=getv(v,i); if not (uu member u) then u:=uu.u end; return mkvec u end; symbolic procedure mkvec(l); begin scalar v,i; v:=mkvect(isub1 length l); i:=0; while l do <<putv(v,i,car l); i:=iadd1 i; l:=cdr l>>; return v end; symbolic procedure mkvecf2q(l); begin scalar v,i,ll; v:=mkvect(isub1 length l); i:=0; while l do << ll:=car l; if ll = 0 then ll:=nil; putv(v,i,!*f2q ll); i:=iadd1 i; l:=cdr l >>; return v end; symbolic procedure mkidenm n; begin scalar ans,u; scalar c0,c1; c0:=nil ./ 1; c1:= 1 ./ 1; % constants. ans:=mkvect(n); for i:=0 step 1 until n do << u:=mkvect n; for j:=0 step 1 until n do if i iequal j then putv(u,j,c1) else putv(u,j,c0); putv(ans,i,u) >>; return ans end; symbolic procedure copyvec(v,n); begin scalar new; new:=mkvect(n); for i:=0:n do putv(new,i,getv(v,i)); return new end; symbolic procedure vecsort(u,l); % Sorts vector v of numbers into decreasing order. % Performs same interchanges of all vectors in the list l. begin scalar j,k,n,v,w; n:=upbv u;% elements 0...n exist. % algorithm used is a bubble sort. for i:=1:n do begin v:=getv(u,i); k:=i; loop: j:=k; k:=isub1 k; w:=getv(u,k); if v<=w then goto ordered; putv(u,k,v); putv(u,j,w); mapc(l,function (lambda u;swap(u,j,k))); if k>0 then goto loop; ordered: end; return nil end; symbolic procedure swap(u,j,k); if null u then nil else begin scalar v; %swaps elements i,j of vector u. v:=getv(u,j); putv(u,j,getv(u,k)); putv(u,k,v) end; symbolic procedure non!-null!-vec v; begin scalar cnt; cnt := 0; for i:=0:upbv v do if getv(v,i) then cnt:=iadd1 cnt; return cnt end; symbolic procedure mkvect2(n,initial); begin scalar u; u:=mkvect n; for i:=0:n do putv(u,i,initial); return u end; endmodule; end; |
Added r33/mathlib.red version [099f0ed8fd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | MODULE MATHLIB; % Some useful mathematical functions. % Authors: W. Galway, M. L. Griss, A. C. Hearn. D. Irish, A. C. Norman, % D. Morrison. % ***** Constants declared as NewNam's ***** % We can't use these long numbers in some Lisps because the reader can't % handle them (and it would truncate instead of round, anyway). These % are here for reference for implementation on other machines. % put('NumberPi,'NewNam,3.14159265358979324); % put('NumberPi!/2,'NewNam,1.57079632679489662); % put('NumberPi!/4,'NewNam,0.785398163397448310); deflist('((Number2Pi 6.2831853) (NumberPi 3.1415927) (NumberPi!/2 1.5707963) (NumberPi!/4 0.78539816) (Number3Pi!/4 2.3561945) (Number!-2Pi -6.2831853) (Number!-Pi -3.1415927) (Number!-Pi!/2 -1.5707963) (Number!-Pi!/4 -0.78539816) (SqrtTolerance 0.0000001) (NumberE 2.718281828) (NumberInverseE 0.36787944) (NaturalLog2 0.69314718) (NaturalLog10 2.3025851) (TrigPrecisionLimit 80)), 'newnam); % ***** Basic Functions ***** symbolic procedure mod(M,N); % Returns M modulo N. Unlike remainder function, it returns % positive result in range 0..N-1, even if M is negative. % Needs more work for case of negative N.) (if result >= 0 then result else result + N) where result = remainder(M,N); symbolic procedure Floor x; % Returns the largest integer less than or equal to x % (i.e. the "greatest integer" function.) % Note the trickiness to compensate for fact that (unlike APL's % "FLOOR" function) FIX truncates towards zero. if fixp x then x else (if x = float n then n else if x >= 0 then n else n-1) where n = fix x; symbolic procedure Ceiling X; % Returns the smallest integer greater than or equal to X. % Note the trickiness to compensate for fact that (unlike APL's % "FLOOR" function) FIX truncates towards zero. if fixp X then X else (if x = float n then n else if x >= 0 then n+1 else n) where n = fix x; symbolic procedure Round X; % Rounds to the closest integer. % Kind of sloppy -- it's biased when the digit causing rounding is a % five. It's a bit weird with negative arguments, round(-2.5)= -2. if fixp X then X else floor(X+0.5); % ***** Trigonometric Functions ***** % Trig functions are all in radians. The following few functions may % be used to convert to/from degrees, or degrees/minutes/seconds. symbolic procedure DegreesToRadians x; x*0.017453292; % 2*pi/360 symbolic procedure RadiansToDegrees x; x*57.29578; % 360/(2*pi) symbolic procedure RadiansToDMS x; % Converts radians to a list of degrees, minutes, and seconds % (rounded, not truncated, to the nearest integer). begin scalar Degs,Mins; x := RadiansToDegrees x; Degs := fix x; x := 60*(x-Degs); Mins := fix x; return list(Degs,Mins, Round(60*(x-Mins))) end; symbolic procedure DMStoRadians(Degs,Mins,Sex); % Converts degrees, minutes, seconds to radians. % DegreesToRadians(Degs+Mins/60.0+Sex/3600.0) DegreesToRadians(Degs+Mins*0.016666667+Sex*0.00027777778); symbolic procedure sin x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then <<neg := T; x := -x>>; if x>TrigPrecisionLimit then ErrorPrintF "Possible loss of precision in computation of SIN"; if x>NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi); if minusp x then <<neg := not neg; x := -x>>; if x > NumberPi!/2 then x := NumberPi-x; return if neg then -ScaledSine x else ScaledSine x end; symbolic procedure ScaledSine x; % assumes its argument is scaled to between 0 and pi/2. begin scalar xsqrd; xsqrd := x*x; return x*(1+xsqrd*(-0.16666667+xsqrd*(0.0083333315 +xsqrd*(-0.0001984090 +xsqrd*(0.0000027526-xsqrd*0.0000000239))))) end; symbolic procedure cos x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. <<if minusp x then x := - x; if x>TrigPrecisionLimit then ErrorPrintf "Possible loss of precision in computation of COS"; if x>NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi); if minusp x then x := -x; if x>NumberPi!/2 then -ScaledCosine(NumberPi-x) else ScaledCosine x>>; symbolic procedure ScaledCosine x; % Expects its argument to be between 0 and pi/2. begin scalar xsqrd; xsqrd := x*x; return 1+xsqrd*(-0.5+xsqrd*(0.041666642+xsqrd*(-0.0013888397+ xsqrd*(0.0000247609-xsqrd*0.0000002605)))) end; symbolic procedure tan x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then <<neg := T; x := -x>>; if x>TrigPrecisionLimit then ErrorPrintF "Possible loss of precision in computation of TAN"; if x>NumberPi!/2 then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi); if minusp x then <<neg := not neg; x := -x>>; if x<NumberPi!/4 then x := ScaledTangent x else x := ScaledCotangent(-(x-numberpi!/2)); return if neg then -x else x end; symbolic procedure cot x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then <<neg := T; x := -x>>; if x>NumberPi!/2 then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi); if x>TrigPrecisionLimit then ErrorPrintF "Possible loss of precision in computation of COT"; if minusp x then <<neg := not neg; x := -x>>; if x<NumberPi!/4 then x := ScaledCotangent x else x := ScaledTangent(-(x-numberpi!/2)); return if neg then -x else x end; symbolic procedure ScaledTangent x; % Expects its argument to be between 0 and pi/4. (x*(1.0+xsqrd*(0.3333314+xsqrd*(0.1333924 +xsqrd*(0.05337406 + xsqrd*(0.024565089 +xsqrd*(0.002900525+xsqrd*0.0095168091))))))) where xsqrd = x*x; symbolic procedure ScaledCotangent x; % Expects its argument to be between 0 and pi/4. ((1.0-xsqrd*(0.33333334+xsqrd*(0.022222029+xsqrd*(0.0021177168 + xsqrd*(0.0002078504+xsqrd*0.0000262619)))))/x) where xsqrd = x*x; symbolic procedure sec x; 1.0/cos x; symbolic procedure csc x; 1.0/sin x; symbolic procedure sinD x; sin DegreesToRadians x; symbolic procedure cosD x; cos DegreesToRadians x; symbolic procedure tanD x; tan DegreesToRadians x; symbolic procedure cotD x; cot DegreesToRadians x; symbolic procedure secD x; sec DegreesToRadians x; symbolic procedure cscD x; csc DegreesToRadians x; symbolic procedure asin x; begin scalar neg; if minusp x then <<neg := T; x := -x>>; if x>1.0 then stderror list("Argument to ASIN too large:",x); return if neg then CheckedArcCosine x - NumberPi!/2 else NumberPi!/2 - CheckedArcCosine x end; symbolic procedure acos x; begin scalar neg; if minusp x then <<neg := T; x := -x>>; if x>1.0 then stderror list("Argument to ACOS too large:",x); return if neg then NumberPi - CheckedArcCosine x else CheckedArcCosine x end; symbolic procedure CheckedArcCosine x; % Return cosine of a "checked number", assumes its argument is in % the range 0 <= x <= 1. sqrt(1.0-x)*(1.5707963+x*(-0.2145988+x*(0.088978987+x*(-0.050174305+ x*(0.030891881+x*(-0.017088126+x*(0.0066700901 -x*(0.0012624911)))))))); symbolic procedure atan x; if minusp x then if x < -1.0 then Number!-Pi!/2 + CheckedArcTangent(-1.0/x) else -CheckedArcTangent(-x) else if x>1.0 then NumberPi!/2 - CheckedArcTangent(1.0/x) else CheckedArcTangent x; symbolic procedure acot x; if minusp x then if x<-1.0 then -CheckedArcTangent(-1.0/x) else Number!-Pi!/2 + CheckedArcTangent(-x) else if x>1.0 then CheckedArcTangent(1.0/x) else NumberPi!/2 - CheckedArcTangent x; symbolic procedure CheckedArcTangent x; (x*(1+xsqrd*(-0.33333145+xsqrd*(0.19993551+xsqrd*(-0.14208899+ xsqrd*(0.10656264+xsqrd*(-0.07528964+xsqrd*(0.042909614+ xsqrd*(-0.016165737+xsqrd*0.0028662257))))))))) where xsqrd = x*x; symbolic procedure asec x; acos(1.0/x); symbolic procedure acsc x; asin(1.0/x); symbolic procedure asinD x; RadiansToDegrees asin x; symbolic procedure acosD x; RadiansToDegrees acos x; symbolic procedure atanD x; RadiansToDegrees atan x; symbolic procedure acotD x; RadiansToDegrees acot x; symbolic procedure asecD x; RadiansToDegrees asec x; symbolic procedure acscD x; RadiansToDegrees acsc x; % ***** Hyperbolic Functions ***** symbolic procedure sinh x; (exp x - exp(-x))/2.0; symbolic procedure cosh x; (exp x + exp(-x))/2.0; symbolic procedure tanh x; sinh x/cosh x; symbolic procedure csch x; 1/sinh x; symbolic procedure sech x; 1/cosh x; symbolic procedure coth x; 1/tanh x; symbolic procedure asinh x; log(x + sqrt(x**2+1.0)); symbolic procedure acosh x; <<if x<0 then x := -x; if x<1 then stderror list("Argument to ACOSH too small:",x); log(x + sqrt(x**2-1.0))>>; symbolic procedure atanh x; begin scalar neg; if x<0 then <<neg := t; x := -x>>; if x>=1 then stderror list("Argument to ATANH too large:",x); x := log((1.0+x)/(1-x)); return if neg then -x else x end; symbolic procedure acsch x; if x=0 then stderror "0 invalid argument to ACSCH" else log(y + sqrt(y**2+1)) where y = 1.0/x; symbolic procedure asech x; <<if x<0 then x := -x; if x>1 then stderror list("Argument to ASECH too large:",x); log(y + sqrt(y**2-1)) where y = 1.0/x>>; symbolic procedure acoth x; begin scalar neg; if x=0 then stderror "0 invalid argument to ACOTH" else if x<0 then <<neg := t; x := -x>>; if x<=1 then stderror list("Argument to ACOTH too small:",x); x := log((x+1.0)/(x-1)); return if neg then -x else x end; % ***** Roots and Such ***** symbolic procedure sqrt N; % Simple Newton-Raphson floating point square root calculator. % Not warranted against truncation errors, etc. begin integer scale; scalar answer; N:=FLOAT N; if N<0.0 then stderror list("SQRT given negative argument:",N); if zerop N then return N; % Scale argument to within 1e-10 to 1e+10; scale := 0; while N > 1.0E10 do <<scale := scale + 1; N := N * 1.0E-10>>; while N < 1.0E-10 do <<scale := scale - 1; N := N * 1.0E10>>; answer := if N>2.0 then (N+1)/2 else if N<0.5 then 2/(N+1) else N; % Here's the heart of the algorithm. while abs(answer**2/N - 1.0) > SqrtTolerance do answer := 0.5*(answer+N/answer); return answer * 10.0**(5*scale) end; % ***** Logs and Exponentials ***** symbolic procedure exp x; % Returns the exponential (ie, e**x) of its floatnum argument as % a flonum. The argument is scaled to % the interval -ln 2 to 0, and a Taylor series expansion % used (formula 4.2.45 on page 71 of Abramowitz and Stegun, % "Handbook of Mathematical Functions"). Note that little effort % has been expended to minimize truncation errors. % On many systems it will be appropriate to define a system- % specific EXP routine that does bother about rounding and that % understands the precision of the host floating point arithmetic; begin scalar N; N := ceiling(x / NaturalLog2); x := N * NaturalLog2 - x; return 2.0**N * (1.0+x*(-0.9999999995+x*(0.4999999206 +x*(-0.1666653019+x*(0.0416573475+x*(-0.0083013598 +x*(0.0013298820+x*(-0.0001413161)))))))) end; symbolic procedure log x; % See Abramowitz and Stegun, page 69. if x<=0.0 then stderror list("LOG given non-positive argument:",x) else if x < 1.0 then -log(1.0/x) else % Find natural log of x > 1; begin scalar nextx, ipart; % ipart is the "integer part" of % the logarithm. ipart := 0; % Keep multiplying by 1/e until x is small enough, may want to % be more "efficient" if we ever use really big numbers. while (nextx := NumberInverseE * x) > 1.0 do <<x := nextx; ipart := ipart + 1>>; return ipart + if x < 2.0 then CheckedLogarithm x else 2.0 * CheckedLogarithm(sqrt(x)) end; symbolic procedure CheckedLogarithm x; % Should have 1 <= x <= 2. (i.e. x = 1+y 0 <= y <= 1) <<x := x-1.0; x*(0.99999642+x*(-0.49987412+x*(0.33179903+x*(-0.24073381 +x*(0.16765407+x*(-0.09532939 +x*(0.036088494-x*0.0064535442)))))))>>; symbolic procedure log2 x; log x / NaturalLog2; symbolic procedure log10 x; log x / NaturalLog10; symbolic procedure factorial n; % simple factorial if n<0 or not fixp n then error(50,list(n,"invalid factorial argument")) else begin scalar m; m:=1; for i:=1:n do m:=m*i; return m; end; % Some functions from ALPHA_1 users symbolic procedure atan2d( y, x ); radianstodegrees atan2( y, x ); symbolic procedure atan2( y, x ); <<x := float x; y := float y; if x = 0.0 then if y>=0.0 then numberpi!/2 else numberpi+numberpi!/2 else if x>=0.0 and y>=0.0 then atan(y/x) % first quadrant. else if x<0.0 and y>=0.0 then numberpi - atan(y/-x) % second quadrant. else if x<0.0 and y<0.0 then numberpi + atan(y/x) % third quadrant. else number2pi - atan(-y/x) % fourth quadrant. >>; symbolic procedure transfersign( s, val ); % transfers the sign of s to val by returning abs(val) if s >= 0, % otherwise -abs(val). if s >= 0 then abs(val) else -abs(val); symbolic procedure dmstodegrees(degs,mins,sex); % converts degrees, minutes, seconds to degrees % degs+mins/60.0+sex/3600.0 degs+mins*0.016666667+sex*0.00027777778; symbolic procedure degreestodms x; % converts degrees to a list of degrees, minutes, and seconds % (all integers, rounded, not truncated). begin scalar degs,mins; degs := fix x; x := 60*(x-degs); mins := fix x; return list(degs,mins, round(60*(x-mins))) end; endmodule; end; |
Added r33/matr.red version [be96d4b0f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module matr; % Author: Anthony C. Hearn; % This module is rife with essential references to RPLAC-based % functions. fluid '(!*sub2); global '(nxtsym!* subfg!*); symbolic procedure matrix u; %declares list U as matrices; begin scalar v,w,x; for each j in u do if atom j then if null (x := gettype j) then put(j,'rtype,'matrix) else if x eq 'matrix then <<lprim list(x,j,"redefined"); put(j,'rtype,'matrix)>> else typerr(list(x,j),"matrix") else if not idp car j or length (v := revlis cdr j) neq 2 or not natnumlis v then errpri2(j,'hold) else if not (x := gettype car j) or x eq 'matrix then <<w := nil; for n := 1:car v do w := nzero cadr v . w; put(car j,'rtype,'matrix); put(car j,'rvalue,'mat . w)>> else typerr(list(x,car j),"matrix") end; symbolic procedure natnumlis u; % True if U is a list of natural numbers. null u or numberp car u and fixp car u and car u>0 and natnumlis cdr u; rlistat '(matrix); symbolic procedure nzero n; % Returns a list of N zeros. if n=0 then nil else 0 . nzero(n-1); % Parsing interface. symbolic procedure matstat; % Read a matrix. begin scalar x,y; a: scan(); scan(); y := xread 'paren; if not eqcar(y,'!*comma!*) then y := list y else y := remcomma y; x := y . x; if nxtsym!* eq '!) then return <<scan(); scan(); 'mat . reversip x>> else if not(nxtsym!* eq '!,) then symerr("Syntax error",nil); go to a end; put('mat,'stat,'matstat); symbolic procedure formmat(u,vars,mode); 'list . mkquote 'mat . for each x in cdr u collect('list . formlis(x,vars,mode)); put('mat,'formfn,'formmat); put('mat,'i2d,'mkscalmat); put('mat,'inversefn,'matinverse); put('mat,'lnrsolvefn,'lnrsolve); put('mat,'rtypefn,'(lambda (x) 'matrix)); flag('(mat tp),'matflg); flag('(mat),'noncommuting); put('mat,'prifn,'matpri); flag('(mat),'struct); % for parsing put('matrix,'fn,'matflg); put('matrix,'evfn,'matsm!*); flag('(matrix),'sprifn); put('matrix,'tag,'mat); put('matrix,'lengthfn,'matlength); put('matrix,'getelemfn,'getmatelem); put('matrix,'setelemfn,'setmatelem); symbolic procedure mkscalmat u; % Converts id u to 1 by 1 matrix. list('mat,list u); symbolic procedure getmatelem u; begin scalar x; x := get(car u,'rvalue); if not eqcar(x,'mat) then rederr list("Matrix",car u,"not set") else if not numlis (u := revlis cdr u) or length u neq 2 then errpri2(x . u,t); return nth(nth(cdr x,car u),cadr u) end; symbolic procedure setmatelem(u,v); letmtr(u,v,get(car u,'rvalue)); symbolic procedure matlength u; if not eqcar(u,'mat) then rederr list("Matrix",u,"not set") else list('list,length cdr u,length cadr u); symbolic procedure matsm!*(u,v); % Matrix expression simplification function. begin u := 'mat . for each j in matsm u collect for each k in j collect mk!*sq2 k; !*sub2 := nil; %since all substitutions done; return u end; symbolic procedure mk!*sq2 u; begin scalar x; x := !*sub2; %since we need value for each element; u := subs2 u; !*sub2 := x; return mk!*sq u end; symbolic procedure matsm u; begin scalar x,y; for each j in nssimp(u,'matrix) do <<y := multsm(car j,matsm1 cdr j); x := if null x then y else addm(x,y)>>; return x end; symbolic procedure matsm1 u; %returns matrix canonical form for matrix symbol product U; begin scalar x,y,z; integer n; a: if null u then return z else if eqcar(car u,'!*div) then go to d else if atom car u then go to er else if caar u eq 'mat then go to c1 else x := apply(caar u,cdar u); b: z := if null z then x else if null cdr z and null cdar z then multsm(caar z,x) else multm(x,z); c: u := cdr u; go to a; c1: if not lchk cdar u then rederr "Matrix mismatch"; x := for each j in cdar u collect for each k in j collect xsimp k; go to b; d: y := matsm cadar u; if (n := length car y) neq length y then rederr "Non square matrix" else if (z and n neq length z) then rederr "Matrix mismatch" else if cddar u then go to h else if null cdr y and null cdar y then go to e; x := subfg!*; subfg!* := nil; if null z then z := apply1(get('mat,'inversefn),y) else if null(x := get('mat,'lnrsolvefn)) then z := multm(apply1(get('mat,'inversefn),y),z) else z := apply2(get('mat,'lnrsolvefn),y,z); subfg!* := x; % Make sure there are no power substitutions. z := for each j in z collect for each k in j collect <<!*sub2 := t; subs2 k>>; go to c; e: if null caaar y then rederr "Zero denominator"; y := revpr caar y; z := if null z then list list y else multsm(y,z); go to c; h: if null z then z := generateident n; go to c; er: rederr list("Matrix",car u,"not set") end; symbolic procedure lchk u; begin integer n; if null u or atom car u then return nil; n := length car u; repeat u := cdr u until null u or atom car u or length car u neq n; return null u end; symbolic procedure addm(u,v); %returns sum of two matrix canonical forms U and V; for each j in addm1(u,v,function cons) collect addm1(car j,cdr j,function addsq); symbolic procedure addm1(u,v,w); if null u and null v then nil else if null u or null v then rederr "Matrix mismatch" else apply(w,list(car u,car v)) . addm1(cdr u,cdr v,w); symbolic procedure tp u; tp1 matsm u; put('tp,'rtypefn,'getrtypecar); symbolic procedure tp1 u; %returns transpose of the matrix canonical form U; %U is destroyed in the process; begin scalar v,w,x,y,z; v := w := list nil; while car u do <<x := u; y := z := list nil; while x do <<z := cdr rplacd(z,list caar x); x := cdr rplaca(x,cdar x)>>; w := cdr rplacd(w,list cdr y)>>; return cdr v end; symbolic procedure scalprod(u,v); %returns scalar product of two lists (vectors) U and V; if null u and null v then nil ./ 1 else if null u or null v then rederr "Matrix mismatch" else addsq(multsq(car u,car v),scalprod(cdr u,cdr v)); symbolic procedure multm(u,v); %returns matrix product of two matrix canonical forms U and V; (lambda x; for each y in u collect for each k in x collect scalprod(y,k)) tp1 v; symbolic procedure multsm(u,v); %returns product of standard quotient U and matrix standard form V; if u = (1 ./ 1) then v else for each j in v collect for each k in j collect multsq(u,k); symbolic procedure letmtr(u,v,y); %substitution for matrix elements; begin scalar z; if not eqcar(y,'mat) then rederr list("Matrix",car u,"not set") else if not numlis (z := revlis cdr u) or length z neq 2 then return errpri2(u,'hold); rplaca(pnth(nth(cdr y,car z),cadr z),v); end; endmodule; module matpri; % Matrix printing routines. % Author: Anthony C. Hearn; global '(!*nat); symbolic procedure setmatpri(u,v); matpri1(cdr v,u); put('mat,'setprifn,'setmatpri); symbolic procedure matpri u; matpri1(cdr u,"MAT"); symbolic procedure matpri1(u,x); %prints a matrix canonical form U with name X; begin scalar m,n; m := 1; for each y in u do <<n := 1; for each z in y do <<varpri(z,list('setq,list(x,m,n),z),'only); n := n+1>>; m := m+1>> end; endmodule; module bareiss; % Inversion routines using the Bareiss 2-step method. % Author: Anthony C. Hearn; % This module is rife with essential references to RPLAC-based % functions. fluid '(!*exp asymplis!*); global '(wtl!*); symbolic procedure matinverse u; lnrsolve(u,generateident length u); symbolic procedure lnrsolve(u,v); %U is a matrix standard form, V a compatible matrix form. %Value is U**(-1)*V. begin integer n; scalar !*exp,temp; !*exp := t; n := length u; if asymplis!* or wtl!* then <<temp := asymplis!* . wtl!*; asymplis!* := wtl!* := nil>>; v := backsub(bareiss car normmat augment(u,v),n); if temp then <<asymplis!* := car temp; wtl!* := cdr temp>>; u := rhside(car v,n); v := cdr v; return if temp then for each j in u collect for each k in j collect resimp(k ./ v) else for each j in u collect for each k in j collect cancel(k ./ v) end; symbolic procedure augment(u,v); if null u then nil else append(car u,car v) . augment(cdr u,cdr v); symbolic procedure generateident n; %returns matrix canonical form of identity matrix of order N. begin scalar u,v; for i := 1:n do <<u := nil; for j := 1:n do u := ((if i=j then 1 else nil) . 1) . u; v := u . v>>; return v end; symbolic procedure rhside(u,m); if null u then nil else pnth(car u,m+1) . rhside(cdr u,m); symbolic procedure bareiss u; %The 2-step integer preserving elimination method of Bareiss %based on the implementation of Lipson. %If the value of procedure is NIL then U is singular, otherwise the %value is the triangularized form of U (in matrix polynomial form). begin scalar aa,c0,ci1,ci2,ik1,ij,kk1,kj,k1j,k1k1,ui,u1,x; integer k,k1; %U1 points to K-1th row of U %UI points to Ith row of U %IJ points to U(I,J) %K1J points to U(K-1,J) %KJ points to U(K,J) %IK1 points to U(I,K-1) %KK1 points to U(K,K-1) %K1K1 points to U(K-1,K-1) %M in comments is number of rows in U %N in comments is number of columns in U. aa:= 1; k:= 2; k1:=1; u1:=u; go to pivot; agn: u1 := cdr u1; if null cdr u1 or null cddr u1 then return u; aa:=nth(car u1,k); %aa := u(k,k). k:=k+2; k1:=k-1; u1:=cdr u1; pivot: %pivot algorithm. k1j:= k1k1 := pnth(car u1,k1); if car k1k1 then go to l2; ui:= cdr u1; %i := k. l: if null ui then return nil else if null car(ij := pnth(car ui,k1)) then go to l1; l0: if null ij then go to l2; x:= car ij; rplaca(ij,negf car k1j); rplaca(k1j,x); ij:= cdr ij; k1j:= cdr k1j; go to l0; l1: ui:= cdr ui; go to l; l2: ui:= cdr u1; %i:= k; l21: if null ui then return; %if i>m then return; ij:= pnth(car ui,k1); c0:= addf(multf(car k1k1,cadr ij), multf(cadr k1k1,negf car ij)); if c0 then go to l3; ui:= cdr ui; %i:= i+1; go to l21; l3: c0:= quotf!*(c0,aa); kk1 := kj := pnth(cadr u1,k1); %kk1 := u(k,k-1); if cdr u1 and null cddr u1 then go to ev0 else if ui eq cdr u1 then go to comp; l31: if null ij then go to comp; %if i>n then go to comp; x:= car ij; rplaca(ij,negf car kj); rplaca(kj,x); ij:= cdr ij; kj:= cdr kj; go to l31; %pivoting complete. comp: if null cdr u1 then go to ev; ui:= cddr u1; %i:= k+1; comp1: if null ui then go to ev; %if i>m then go to ev; ik1:= pnth(car ui,k1); ci1:= quotf!*(addf(multf(cadr k1k1,car ik1), multf(car k1k1,negf cadr ik1)), aa); ci2:= quotf!*(addf(multf(car kk1,cadr ik1), multf(cadr kk1,negf car ik1)), aa); if null cddr k1k1 then go to comp3;%if j>n then go to comp3; ij:= cddr ik1; %j:= k+1; kj:= cddr kk1; k1j:= cddr k1k1; comp2: if null ij then go to comp3; rplaca(ij,quotf!*(addf(multf(car ij,c0), addf(multf(car kj,ci1), multf(car k1j,ci2))), aa)); ij:= cdr ij; kj:= cdr kj; k1j:= cdr k1j; go to comp2; comp3: ui:= cdr ui; go to comp1; ev0:if null c0 then return; ev: kj := cdr kk1; x := cddr k1k1; %x := u(k-1,k+1); rplaca(kj,c0); ev1:kj:= cdr kj; if null kj then go to agn; rplaca(kj,quotf!*(addf(multf(car k1k1,car kj), multf(car kk1,negf car x)), aa)); x := cdr x; go to ev1 end; symbolic procedure backsub(u,m); begin scalar detm,det1,ij,ijj,ri,summ,uj,ur; integer i,jj; %N in comments is number of columns in U. if null u then rederr "Singular matrix"; ur := reverse u; detm := car pnth(car ur,m); %detm := u(i,j). if null detm then rederr "Singular matrix"; i := m; rows: i := i-1; ur := cdr ur; if null ur then return u . detm; %if i=0 then return u . detm. ri := car ur; jj := m+1; ijj:=pnth(ri,jj); r2: if null ijj then go to rows; %if jj>n then go to rows; ij := pnth(ri,i); %j := i; det1 := car ij; %det1 := u(i,i); uj := pnth(u,i); summ := nil; %summ := 0; r3: uj := cdr uj; %j := j+1; if null uj then go to r4; %if j>m then go to r4; ij := cdr ij; summ := addf(summ,multf(car ij,nth(car uj,jj))); %summ:=summ+u(i,j)*u(j,jj); go to r3; r4: rplaca(ijj,quotf!*(addf(multf(detm,car ijj),negf summ),det1)); %u(i,j):=(detm*u(i,j)-summ)/det1; jj := jj+1; ijj := cdr ijj; go to r2 end; symbolic procedure normmat u; %U is a matrix standard form. %Value is dotted pair of matrix polynomial form and factor. begin scalar x,y,z; x := 1; for each v in u do <<y := 1; for each w in v do y := lcm(y,denr w); z := (for each w in v collect multf(numr w,quotf(y,denr w))) . z; x := multf(y,x)>>; return reverse z . x end; endmodule; module det; % Determinant and trace routines. % Author: Anthony C. Hearn; symbolic procedure simpdet u; detq matsm carx(u,'det); % The hashing and determinant routines below are due to M. L. Griss. comment Some general purpose hashing functions; flag('(array),'eval); %declared again for bootstrapping purposes; array !$hash 64; %general array for hashing; symbolic procedure gethash key; %access previously saved element; assoc(key,!$hash(remainder(key,64))); symbolic procedure puthash(key,valu); begin integer k; scalar buk; k := remainder(key,64); buk := (key . valu) . !$hash k; !$hash k := buk; return car buk end; symbolic procedure clrhash; for i := 0:64 do !$hash i := nil; comment Determinant Routines; symbolic procedure detq u; %top level determinant function; begin integer len; len := length u; %number of rows; for each x in u do if length x neq len then rederr "NON SQUARE MATRIX"; if len=1 then return caar u; clrhash(); u := detq1(u,len,0); clrhash(); return u end; symbolic procedure detq1(u,len,ignnum); %U is a square matrix of order LEN. Value is the determinant of U; %Algorithm is expansion by minors of first row; %IGNNUM is packed set of column indices to avoid; begin integer n2; scalar row,sign,z; row := car u; %current row; n2 := 1; if len=1 then return <<while twomem(n2,ignnum) do <<n2 := 2*n2; row := cdr row>>; car row>>; %last row, single element; if z := gethash ignnum then return cdr z; len := len-1; u := cdr u; z := nil ./ 1; for each x in row do <<if not twomem(n2,ignnum) then <<if numr x then <<if sign then x := negsq x; z:= addsq(multsq(x,detq1(u,len,n2+ignnum)), z)>>; sign := not sign>>; n2 := 2*n2>>; puthash(ignnum,z); return z end; symbolic procedure twomem(n1,n2); %for efficiency reasons, this procedure should be coded in assembly %language; not evenp(n2/n1); put('det,'simpfn,'simpdet); symbolic procedure simptrace u; begin integer n; scalar z; u := matsm carx(u,'trace); if length u neq length car u then rederr "NON SQUARE MATRIX"; n := 1; z := nil ./ 1; for each x in u do <<z := addsq(nth(x,n),z); n := n+1>>; return z end; put('trace,'simpfn,'simptrace); endmodule; module glmat; % Routines for inverting matrices and finding eigen-values % and vectors. Methods are the same as in glsolve module. % Author: Eberhard Schruefer. fluid '(!*cramer !*gcd kord!*); global '(!!arbint); if null !!arbint then !!arbint := 0; switch cramer; put('cramer,'simpfg, '((t (put 'mat 'lnrsolvefn 'clnrsolve) (put 'mat 'inversefn 'matinv)) (nil (put 'mat 'lnrsolvefn 'lnrsolve) (put 'mat 'inversefn 'matinverse)))); % algebraic operator arbcomplex; % Done this way since it's also defined in the solve1 module. deflist('((arbcomplex simpiden)),'simpfn); symbolic procedure clnrsolve(u,v); %interface to matrix package. multm(matinv u,v); symbolic procedure minv u; matinv matsm u; put('minv,'rtypefn,'(lambda (x) 'matrix)); flag('(minv),'matflg); %put('mateigen,'rtypefn,'(lambda (x) 'matrix)); remprop('mateigen,'rtypefn); %flag('(mateigen),'matflg); remflag('(mateigen),'matflg); put('detex,'simpfn,'detex); symbolic procedure matinv u; %u is a matrix form. Result is the inverse of matrix u. begin scalar sgn,x,y,z; integer l,m,lm; z := 1; lm := length car u; for each v in u do <<y := 1; for each w in v do y := lcm(y,denr w); m := lm; x := list(nil . (l := l + 1)) .* negf y .+ nil; for each j in reverse v do <<if numr j then x := list m .* multf(numr j,quotf(y,denr j)) .+ x; m := m - 1>>; z := c!:extmult(x,z)>>; if singularchk lpow z then rederr "singular matrix"; sgn := evenp length lpow z; return for each k in lpow z collect <<sgn := not sgn; for each j in lpow z collect mkglimat(k,z,sgn,j)>> end; symbolic procedure singularchk u; pairp car reverse u; flag('(mateigen),'opfn); flag('(mateigen),'noval); symbolic procedure mateigen(u,eival); %u is a matrix form, eival an indeterminate naming the eigenvalues. %Result is a list of lists: % {{eival-eq1,multiplicity1,eigenvector1},....}, %where eival-eq is a polynomial and eigenvector is a matrix. % How much should we attempt to solve the eigenvalue eq.? sqfr? % Sqfr is necessary if we want to have the full eigenspace. If there % are multiple roots another pass through eigenvector calculation % is needed(done). % We should actually perform the calculations in the extension % field generated by the eigenvalue equation(done inside). %*** needs still checking; seems to do fairly well. begin scalar arbvars,exu,sgn,q,r,s,x,y,z,eivec; integer l,m,lm; z := 1; if not(getrtype u eq 'matrix) then typerr(u,"matrix"); u := matsm u; lm := length car u; exu := for each v in u collect <<y := 1; for each w in v do y := lcm(y,denr w); m := lm; l := l + 1; x := nil; for each j in reverse v do <<if l=m then j := addsq(j,negsq !*k2q !*a2k eival); if numr j then x := list m .* multf(numr j,quotf(y,denr j)) .+ x; m := m - 1>>; y := z; z := c!:extmult(if null red x then << q := (if p then (car p . (cdr p + 1)) . delete(p,q) else (lc x . 1) . q) where p = assoc(lc x,q); !*p2f lpow x>> else x,z); x>>; r := if minusf lc z then negf lc z else lc z; r := numr subs2(r ./ 1); kord!* := eival . kord!*; if domainp r then s := 1 else s := comfac!-to!-poly comfac(r := reorder r); r := quotf1(r,s); r := if domainp r then nil else sqfrf r; if null domainp s and (mvar s eq eival) then if red s then r := (s . 1) . r else r := (!*k2f eival . ldeg s) . r; for each j in q do r := (absf reorder car j . cdr j) . r; kord!* := cdr kord!*; r := for each j in r collect reorder car j . cdr j; l := length r; return 'list . for each j in r collect <<if null((cdr j = 1) and (l = 1)) then <<y := 1; for each k in exu do if x := reduce!-mod!-eig(car j,c!:extmult(k,y)) then y := x>>; arbvars := nil; for each k in lpow z do if (y=1) or null(k member lpow y) then arbvars := (k . makearbcomplex()) . arbvars; sgn := (y=1) or evenp length lpow y; eivec := 'mat . for each k in lpow z collect list if x := assoc(k,arbvars) then mvar cdr x else prepsq!* mkgleig(k,y, sgn := not sgn,arbvars); list('list,prepsq!*(car j ./ 1),cdr j,eivec)>> end; symbolic procedure reduce!-mod!-eig(u,v); %reduces exterior product v wrt eigenvalue equation u. begin scalar x,y; for each j on v do if numr(y := reduce!-mod!-eigf(u,lc j)) then x := lpow j .* y .+ x; y := 1; for each j on x do y := lcm(y,denr lc j); return for each j on reverse x collect lpow j .* multf(numr lc j,quotf(y,denr lc j)) end; symbolic procedure reduce!-mod!-eigf(u,v); subs2 reduce!-eival!-powers(lpow u . negsq cancel(red u ./ lc u),v); symbolic procedure reduce!-eival!-powers(v,u); if domainp u then u ./ 1 else if mvar u eq caar v then reduce!-eival!-powers1(v,u ./ 1) else if ordop(caar v,mvar u) then u ./ 1 else addsq(multpq(lpow u,reduce!-eival!-powers(v,lc u)), reduce!-eival!-powers(v,red u)); symbolic procedure reduce!-eival!-powers1(v,u); %reduces powers with the help of the eigenvalue polynomial; if domainp numr u or (ldeg numr u<pdeg car v) then u else if ldeg numr u=pdeg car v then addsq(multsq(cdr v,lc numr u ./ denr u), red numr u ./ denr u) else reduce!-eival!-powers1(v, addsq(multsq(multpf(mvar numr u .** (ldeg numr u-pdeg car v), lc numr u) ./ denr u, cdr v),red numr u ./ denr u)); symbolic procedure detex u; %u is a matrix form, result is determinant of u. begin scalar f,x,y,z; integer m,lm; z := 1; u := matsm car u; lm := length car u; f := 1; for each v in u do <<y := 1; for each w in v do y := lcm(y,denr w); f := multf(y,f); m := lm; x := nil; for each j in v do <<if numr j then x := list m .* multf(numr j,quotf(y,denr j)) .+ x; m := m - 1>>; z := c!:extmult(x,z)>>; return cancel(lc z ./ f) end; symbolic procedure mkglimat(u,v,sgn,k); begin scalar s,x,y; x := nil ./ 1; y := lpow v; for each j on red v do if s := glmatterm(u,y,j,k) then x := addsq(cancel(s ./ lc v),x); return if sgn then negsq x else x end; symbolic procedure glmatterm(u,v,w,k); begin scalar x,y,sgn; x := lpow w; a: if null x then return if pairp car y and (cdar y = k) then lc w else nil; if car x = u then return nil else if car x member v then <<x := cdr x; if y then sgn := not sgn>> else if y then return nil else <<y := list car x; x := cdr x>>; go to a end; symbolic procedure mkgleig(u,v,sgn,arbvars); begin scalar s,x,y,!*gcd; x := nil ./ 1; y := lpow v; !*gcd := t; for each j on red v do if s := glsoleig(u,y,j,arbvars) then x := addsq(cancel(s ./ lc v),x); return if sgn then negsq x else x end; symbolic procedure glsoleig(u,v,w,arbvars); begin scalar x,y,sgn; x := lpow w; a: if null x then return if null car y then lc w else multf(cdr assoc(car y,arbvars), if sgn then negf lc w else lc w); if car x = u then return nil else if car x member v then <<x := cdr x; if y then sgn := not sgn>> else if y then return nil else <<y := list car x; x := cdr x>>; go to a end; %**** Support for exterior multiplication **** % Data structure is lpow ::= list of col.-ind. in exterior product % | nil . number of eq. for inhomog. terms. % lc ::= standard form symbolic procedure c!:extmult(u,v); %Special exterior multiplication routine. Degree of form v is %arbitrary, u is a one-form. if null u or null v then nil else if v = 1 then u %unity else (if x then cdr x .* (if car x then negf multf(lc u,lc v) else multf(lc u,lc v)) .+ c!:extadd(c!:extmult(!*t2f lt u,red v), c!:extmult(red u,v)) else c!:extadd(c!:extmult(!*t2f lt u,red v), c!:extmult(red u,v))) where x = c!:ordexn(car lpow u,lpow v); symbolic procedure c!:extadd(u,v); if null u then v else if null v then u else if lpow u = lpow v then (lambda x,y; if null x then y else lpow u .* x .+ y) (addf(lc u,lc v),c!:extadd(red u,red v)) else if c!:ordexp(lpow u,lpow v) then lt u .+ c!:extadd(red u,v) else lt v .+ c!:extadd(u,red v); symbolic procedure c!:ordexp(u,v); if null u then t else if car u = car v then c!:ordexp(cdr u,cdr v) else c!:ordxp(car u,car v); symbolic procedure c!:ordexn(u,v); %u is a single index, v a list. Returns nil if u is a member %of v or a dotted pair of a permutation indicator and the ordered %list of u merged into v. begin scalar s,x; a: if null v then return(s . reverse(u . x)) else if (u = car v) or (pairp u and pairp car v) then return nil else if c!:ordxp(u,car v) then return(s . append(reverse(u . x),v)) else <<x := car v . x; v := cdr v; s := not s>>; go to a end; symbolic procedure c!:ordxp(u,v); if pairp u then if pairp v then cdr u < cdr v else nil else if pairp v then t else u < v; endmodule; end; |
Added r33/mkfasl.red version [6cc13169e1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | MODULE MKFASL --- Produce a fasl loading version of a given file; % Author: Martin L. Griss. % Modifications by: Anthony C. Hearn; fluid '(rfasl!* rsrc!* !*break !*lower !*quiet!_faslout !*usermode !*writingfaslfile); global '(!*echo); symbolic procedure mkfasl u; % produce a FASL file for the module u; if errorp errorset(list('mkfasl1,mkquote u),t,!*backtrace) then <<if !*writingfaslfile then eval '(faslend); errorprintf("***** Error during mkfasl of %w%n",u)>>; flag('(mkfasl),'opfn); flag('(mkfasl),'noval); symbolic procedure mkfasl1 u; begin scalar !*int,!*lower,!*usermode,!*quiet!_faslout,!*break,echo, ichan,oldichan; echo := !*echo; !*echo := nil; !*quiet!_faslout := t; terpri(); prin2t bldmsg("*** Compiling %w ...",u); terpri(); u := string!-downcase u; ichan := open(concat(u,".red"),'input); oldichan := rds ichan; faslout bldmsg("%w%w",rfasl!*,u); begin1(); eval '(faslend); !*echo := echo; close ichan; rds oldichan end; endmodule; end; |
Added r33/mkreduce.sl version [6ab0299bb2].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | (setq !*verboseload t) (dskin "$reduce/src/symget.dat") % for fast plist access (load prolog) % Aliasing of ids used by PSL (flag '(foreach repeat while) 'lose) (load rlisp) % RLISP (load rend) % PSL dependent code (load arith) (load mathlib) % mathematical function library (load alg1) % basic algebra (load alg2) % and augmentations (load nbig) % PSL bignums (remd 'crefon) % Since we don't use PSL version (load entry) % entry points for other modules (load init!-file) % allows for init file .reducerc (setq !*verboseload nil) (initreduce) (setq date* "15-Jan-88") % Official release date |
Added r33/prolog.red version [b96035cd30].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % module prolog; % system dependent code for REDUCE % Author: Anthony C. Hearn % This file defines functions, variables and declarations needed to % make REDUCE and the underlying PSL system compatible, and which need % to be input before the system independent REDUCE source is loaded. % Code for resolving aliasing name conflicts. global '(!*quotenewnam); symbolic procedure define!-alias!-list u; begin scalar x; a: if null u then return nil; x := intern compress append(explode '!~,explode car u); put(car u,'newnam,x); put(car u,'quotenewnam,x); u := cdr u; go to a end; % Support for module loading symbolic procedure load!-module u; begin scalar x; if not idp u then rederr list(u,"is not a module name"); if null (x := get(u,'module!-list)) then return evload list u; a: if null x then return nil; load!-module car x; x := cdr x; go to a end; % PSL doesn't need PRINTPROMPT remflag('(printprompt),'lose); symbolic procedure printprompt u; nil; flag('(printprompt),'lose); flag('(aconc atsoc copy delasc eqcar geq lastpair leq mkquote neq prin2t reversip rplacw union xn putc yesp),'lose); flag('(block foreach lprim repeat while),'user); % permits redefinition !*quotenewnam := nil; define!-alias!-list '(arrayp do for on off logand logxor let clear flatten imports indx mkid copy mkvec vector editf spaces2 prettyprint); !*quotenewnam := t; % Resolution of non-local variable definitions. % The following PSL variables differ from the Standard LISP Report remprop('!*comp,'vartype); remprop('!*echo,'vartype); remprop('!*raise,'vartype); % The following are not in the Standard LISP Report, but differ from % usual REDUCE usage. remprop('!*output,'vartype); remprop('cursym!*,'vartype); % endmodule; end; |
Added r33/rcref.red version [a3cac14af6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module redio; % General Purpose I/O package, sorting and positioning. % Author: Martin L. Griss. % Modified by: Anthony C. Hearn. global '(!*formfeed lnnum!* maxln!* orig!* pgnum!* title!*); % This module is functionally equivalent to the PSL file PSL-CREFIO.RED. % FORMFEED (ON) controls ^L or spacer of ====; symbolic procedure initio(); % Set-up common defaults; begin !*formfeed:=t; orig!*:=0; lnnum!*:=0; linelength(75); maxln!*:=55; title!*:=nil; pgnum!*:=1; end; symbolic procedure lposn(); lnnum!*; initio(); symbolic procedure setpgln(p,l); begin if p then maxln!*:=p; if l then linelength(l); end; % We use EXPLODE to produce a list of chars from atomname, % and TERPRI() to terminate a buffer..all else % done in package..spaces,tabs,etc. ; comment Character lists are (length . chars), for FITS; symbolic procedure getes u; % Returns for U , EE=(Length . List of char); begin scalar ee; if not idp u then return<<ee:=explode u;length(ee).ee>>; if not(ee:=get(u,'rccnam)) then <<ee:=explode(u); ee:=length(ee) . ee; put(u,'rccnam,ee)>>; return ee; end; % symbolic smacro procedure prtwrd u; % if numberp u then prtnum u else prtatm u; symbolic procedure prtatm u; prin2 u; % For a nice print; symbolic procedure prtlst u; if atom u then prin2 u else for each x in u do prin2 x; symbolic procedure prtnum n; % We use this kludge to defeat the new line that several LISPs % including PSL like to insert when printing a number near the line % boundary. for each x in explode2 n do prin2 x; symbolic procedure princn ee; % output a list of chars, update POSN(); while (ee:=cdr ee) do prin2 car ee; symbolic procedure spaces n; for i:=1:n do prin2 '! ; symbolic procedure spaces!-to n; begin scalar x; x := n - posn(); if x<1 then newline n else spaces x; end; symbolic procedure setpage(title,page); % Initialise current page and title; begin title!*:= title ; pgnum!*:=page; end; symbolic procedure newline n; % Begins a fresh line at posn N; begin lnnum!*:=lnnum!*+1; if lnnum!*>=maxln!* then newpage() else terpri(); spaces(orig!*+n); end; symbolic procedure newpage(); % Start a fresh page, with PGNUM and TITLE, if needed; begin scalar a; a:=lposn(); lnnum!*:=0; if posn() neq 0 then newline 0; if a neq 0 then formfeed(); if title!* then <<spaces!-to 5; prtlst title!*>>; spaces!-to (linelength(nil)-4); if pgnum!* then <<prtnum pgnum!*; pgnum!*:=pgnum!*+1>> else pgnum!*:=2; newline 10; newline 0; end; symbolic procedure underline2 n; if n>=linelength(nil) then <<n:=linelength(nil)-posn(); for i:=0:n do prin2 '!- ; newline(0)>> else begin scalar j; j:=n-posn(); for i:=0:j do prin2 '!-; end; symbolic procedure lprint(u,n); % prints a list of atoms within block LINELENGTH(NIL)-n; begin scalar ee; integer l,m; spaces!-to n; l := linelength nil-posn(); if l<=0 then error(13,"WINDOW TOO SMALL FOR LPRINT"); while u do <<ee:=getes car u; u:=cdr u; if linelength nil<posn() then newline n; if car ee<(m := linelength nil-posn()) then princn ee else if car ee<l then <<newline n; princn ee>> else begin ee := cdr ee; a: for i := 1:m do <<prin2 car ee; ee := cdr ee>>; newline n; if null ee then nil else if length ee<(m := l) then princn(nil . ee) else go to a end; if posn()<linelength nil then prin2 '! >> end; symbolic procedure rempropss(atmlst,lst); for each x in atmlst do for each y in lst do remprop(x,y); symbolic procedure remflagss(atmlst,lst); for each x in lst do remflag(atmlst,x); symbolic procedure formfeed; if !*formfeed then eject() else <<terpri(); prin2 " ========================================= "; terpri()>>; endmodule; module rcref; % Cross reference program. % Author: Martin L. Griss. fluid '(!*backtrace !*cref !*defn !*mode calls!* curfun!* dfprint!* globs!* locls!* toplv!*); global '(undefg!* gseen!* btime!* expand!* haveargs!* notuse!* nolist!* dclglb!* entpts!* undefns!* seen!* tseen!* op!*!* cloc!* pfiles!* curlin!* pretitl!* !*creftime !*saveprops maxarg!* !*crefsummary !*comp !*raise !*rlisp !*globals !*algebraics); switch cref; !*algebraics:='t; % Default is normal parse of algebraic; !*globals:='t; % Do analyze globals; % !*RLISP:=NIL; % REDUCE as default; maxarg!*:=15; % Maximum args in Standard Lisp; % Requires REDIO and SORT support. deflist('((anlfn procstat) (crflapo procstat)),'stat); flag('(anlfn crflapo),'compile); comment EXPAND flag on these forces expansion of MACROS; expand!* := '(for foreach repeat while); nolist!* := nconc(deflist(slfns!*,'number!-of!-args),nolist!*)$ nolist!* := append('(and cond endmodule lambda list max min module or plus prog prog2 progn times), nolist!*); flag ('(plus times and or lambda progn max min cond prog case list), 'naryargs); dclglb!*:='(!*comp emsg!* !*raise); if not getd 'begin then flag('(rds deflist flag fluid global remprop remflag unfluid setq crefoff),'eval); symbolic procedure crefon; begin scalar a,ocrfil,crfil; btime!*:=time(); dfprint!* := 'refprint; !*defn := t; if not !*algebraics then put('algebraic,'newnam,'symbolic); flag(nolist!*,'nolist); flag(expand!*,'expand); flag(dclglb!*,'dclglb); % Global lists; entpts!*:=nil; % Entry points to package; undefns!*:=nil; % Functions undefined in package; seen!*:=nil; % List of all encountered functions; tseen!*:=nil; % List of all encountered types not flagged % FUNCTION; gseen!*:=nil; % All encountered globals; pfiles!*:=nil; % Processed files; undefg!*:=nil; % Undeclared globals encountered; curlin!*:=nil; % Position in file(s) of current command ; pretitl!*:=nil; % T if error or questionables found ; % Usages in specific function under analysis; globs!*:=nil; % Globals refered to in this ; calls!*:=nil; % Functions called by this; locls!*:=nil; % Defined local variables in this ; toplv!*:=t; % NIL if inside function body ; curfun!*:=nil; % Current function beeing analysed; op!*!*:=nil; % Current op. in LAP code; setpage(" Errors or questionables",nil); if getd 'begin then return nil; % In REDUCE; % The following loop is used when running in bare LISP; ndf: if not (a eq !$eof!$) then go lop; crfil:=nil; if null ocrfil then go lop; crfil:=caar ocrfil; rds cdar ocrfil; ocrfil:=cdr ocrfil; lop: a:=errorset('(!%nexttyi),t,!*backtrace); if atom a then go ndf; cloc!*:=if crfil then crfil . pgline() else nil; a:=errorset('(read),t,!*backtrace); if atom a then go ndf; a:=car a; if not pairp a then go lop; if car a eq 'dskin then <<ocrfil:=(crfil.rds open(cdr a,'input)).ocrfil; crfil:=cdr a; go lop>>; errorset(list('refprint,mkquote a),t,!*backtrace); if flagp(car a,'eval) and (car a neq 'setq or caddr a memq '(t nil) or constantp caddr a or eqcar(caddr a,'quote)) then errorset(a,t,!*backtrace); if !*defn then go lop end; symbolic procedure undefdchk fn; if not flagp(fn,'defd) then undefns!* := fn . undefns!*; symbolic procedure princng u; princn getes u; symbolic procedure crefoff; % main call, sets up, alphabetizes and prints; begin scalar tim,x; dfprint!* := nil; !*defn:=nil; if not !*algebraics then remprop('algebraic,'newnam); %back to normal; tim:=time()-btime!*; for each fn in seen!* do <<if null get(fn,'calledby) then entpts!*:=fn . entpts!*; undefdchk fn>>; tseen!*:=for each z in idsort tseen!* collect <<remprop(z,'tseen); for each fn in (x:=get(z,'funs)) do <<undefdchk fn; remprop(fn,'rccnam)>>; z.x>>; for each z in gseen!* do if get(z,'usedunby) then undefg!*:=z . undefg!*; setpage(" Summary",nil); newpage(); pfiles!*:=punused("Crossreference listing for files:", for each z in pfiles!* collect cdr z); entpts!*:=punused("Entry Points:",entpts!*); undefns!*:=punused("Undefined Functions:",undefns!*); undefg!*:=punused("Undeclared Global Variables:",undefg!*); gseen!*:=punused("Global variables:",gseen!*); seen!*:=punused("Functions:",seen!*); for each z in tseen!* do <<rplacd(z,punused(list(car z," procedures:"),cdr z)); x:='!( . nconc(explode car z,list '!)); for each fn in cdr z do <<fn:=getes fn; rplacd(fn,append(x,cdr fn)); rplaca(fn,length cdr fn)>> >>; if !*crefsummary then goto xy; if !*globals and gseen!* then <<setpage(" Global Variable Usage",1); newpage(); for each z in gseen!* do cref6 z>>; if seen!* then cref52(" Function Usage",seen!*); for each z in tseen!* do cref52(list(" ",car z," procedures"),cdr z); setpage(" Toplevel calls:",nil); x:=t; for each z in pfiles!* do if get(z,'calls) or get(z,'globs) then <<if x then <<newpage(); x:=nil>>; newline 0; newline 0; princng z; spaces!-to 15; underline2 (linelength(nil)-10); cref51(z,'calls,"Calls:"); if !*globals then cref51(z,'globs,"Globals:")>>; xy: if !*saveprops then goto xx; rempropss(seen!*,'(gall calls globs calledby alsois sameas)); remflagss(seen!*,'(seen cinthis defd)); rempropss(gseen!*,'(usedby usedunby boundby setby)); remflagss(gseen!*,'(dclglb gseen glb2rf glb2bd glb2st)); for each z in tseen!* do remprop(car z,'funs); % for each z in haveargs!* do remprop(z,'number!-of!-args); haveargs!* := gseen!* := seen!* := tseen!* := nil; xx: newline 2; if not !*creftime then return; btime!*:=time()-btime!*; setpage(" Timing Information",nil); newpage(); newline 0; prtatm " Total Time="; prtnum btime!*; prtatm " (ms)"; newline 0; prtatm " Analysis Time="; prtnum tim; newline 0; prtatm " Sorting Time="; prtnum (btime!*-tim); newline 0; newline 0 end; symbolic procedure punused(x,y); if y then <<newline 2; prtlst x; newline 0; lprint(y := idsort y,8); newline 0; y>>; symbolic procedure cref52(x,y); <<setpage(x,1); newpage(); for each z in y do cref5 z>>; symbolic procedure cref5 fn; % Print single entry; begin scalar x,y; newline 0; newline 0; prin1 fn; spaces!-to 15; y:=get(fn,'gall); if y then <<prin1 cdr y; x:=car y>> else prin2 "Undefined"; spaces!-to 25; if flagp(fn,'naryargs) then prin2 " Nary Args " else if (y:=get(fn,'number!-of!-args)) then <<prin2 " "; prin2 y; prin2 " Args ">>; underline2 (linelength(nil)-10); if x then <<newline 15; prtatm "Line:"; spaces!-to 27; prtnum cddr x; prtatm '!/; prtnum cadr x; prtatm " in "; prtatm car x>>; cref51(fn,'calledby,"Called by:"); cref51(fn,'calls,"Calls:"); cref51(fn,'alsois,"Is also:"); cref51(fn,'sameas,"Same as:"); if !*globals then cref51(fn,'globs,"Globals:") end; symbolic procedure cref51(x,y,z); if (x:=get(x,y)) then <<newline 15; prtatm z; lprint(idsort x,27)>>; symbolic procedure cref6 glb; % print single global usage entry; <<newline 0; prin1 glb; spaces!-to 15; notuse!*:=t; cref61(glb,'usedby,"Global in:"); cref61(glb,'usedunby,"Undeclared:"); cref61(glb,'boundby,"Bound in:"); cref61(glb,'setby,"Set by:"); if notuse!* then prtatm "*** Not Used ***">>; symbolic procedure cref61(x,y,z); if (x:=get(x,y)) then <<if not notuse!* then newline 15 else notuse!*:=nil; prtatm z; lprint(idsort x,27)>>; % Analyse bodies of LISP functions for % functions called, and globals used, undefined. smacro procedure flag1(u,v); flag(list u,v); smacro procedure remflag1(u,v); remflag(list u,v); smacro procedure isglob u; flagp(u,'dclglb); smacro procedure chkseen s; % Has this name been encountered already?; if not flagp(s,'seen) then <<flag1(s,'seen); seen!*:=s . seen!*>>; smacro procedure globref u; if not flagp(u,'glb2rf) then <<flag1(u,'glb2rf); globs!*:=u . globs!*>>; smacro procedure anatom u; % Global seen before local..ie detect extended from this; if !*globals and u and not(u eq 't) and idp u and not assoc(u,locls!*) then globref u; smacro procedure chkgseen g; if not flagp(g,'gseen) then <<gseen!*:=g . gseen!*; flag1(g,'gseen)>>; symbolic procedure do!-global l; % Catch global defns; % Distinguish FLUID from GLOBAL later; if pairp(l:=qcrf car l) and !*globals and toplv!* then <<for each v in l do chkgseen v; flag(l,'dclglb)>>; put('global,'anlfn,'do!-global); put('fluid,'anlfn,'do!-global); symbolic anlfn procedure unfluid l; if pairp(l:=qcrf car l) and !*globals and toplv!* then <<for each v in l do chkgseen v; remflag(l,'dclglb)>>; symbolic procedure add2locs ll; begin scalar oldloc; if !*globals then for each gg in ll do <<oldloc:=assoc(gg,locls!*); if not null oldloc then << qerline 0; prin2 "*** Variable "; prin1 gg; prin2 " nested declaration in "; princng curfun!*; newline 0; rplacd(oldloc,nil.oldloc)>> else locls!*:=(gg . list nil) . locls!*; if isglob(gg) or flagp(gg,'glb2rf) then globind gg; if flagp(gg,'seen) then <<qerline 0; prin2 "*** Function "; princng gg; prin2 " used as variable in "; princng curfun!*; newline 0>> >> end; symbolic procedure globind gg; <<flag1(gg,'glb2bd); globref gg>>; symbolic procedure remlocs lln; begin scalar oldloc; if !*globals then for each ll in lln do <<oldloc:=assoc(ll,locls!*); if null oldloc then if getd 'begin then rederr list(" Lvar confused",ll) else error(0,list(" Lvar confused",ll)); if cddr oldloc then rplacd(oldloc,cddr oldloc) else locls!*:=efface1(oldloc,locls!*)>> end; symbolic procedure add2calls fn; % Update local CALLS!*; if not(flagp(fn,'nolist) or flagp(fn,'cinthis)) then <<calls!*:=fn . calls!*; flag1(fn,'cinthis)>>; symbolic procedure anform u; if atom u then anatom u else anform1 u; symbolic procedure anforml l; begin while not atom l do <<anform car l; l:=cdr l>>; if l then anatom l end; symbolic procedure anform1 u; begin scalar fn,x; fn:=car u; u:=cdr u; if not atom fn then return <<anform1 fn; anforml u>>; if not idp fn then return nil else if isglob fn then <<globref fn; return anforml u>> else if assoc(fn,locls!*) then return anforml u; add2calls fn; checkargcount(fn,length u); if flagp(fn,'noanl) then nil else if x:=get(fn,'anlfn) then apply(x,list u) else anforml u end; symbolic anlfn procedure lambda u; <<add2locs car u; anforml cdr u; remlocs car u>>; symbolic procedure anlsetq u; <<anforml u; if !*globals and flagp(u:=car u,'glb2rf) then flag1(u,'glb2st)>>; put('setq,'anlfn,'anlsetq); symbolic anlfn procedure cond u; for each x in u do anforml x; symbolic anlfn procedure prog u; <<add2locs car u; for each x in cdr u do if not atom x then anform1 x; remlocs car u>>; symbolic anlfn procedure function u; if pairp(u:=car u) then anform1 u else if isglob u then globref u else if null assoc(u,locls!*) then add2calls u; flag('(quote go),'noanl); symbolic anlfn procedure errorset u; begin scalar fn,x; anforml cdr u; if eqcar(u:=car u,'quote) then return ersanform cadr u else if not((eqcar(u,'cons) or (x:=eqcar(u,'list))) and quotp(fn:=cadr u)) then return anform u; anforml cddr u; if pairp(fn:=cadr fn) then anform1 fn else if flagp(fn,'glb2rf) then nil else if isglob fn then globref fn else <<add2calls fn; if x then checkargcount(fn,length cddr u)>> end; symbolic procedure ersanform u; begin scalar locls!*; return anform u end; symbolic procedure anlmap u; <<anforml cdr u; if quotp(u:=caddr u) and idp(u:=cadr u) and not isglobl u and not assoc(u,locls!*) then checkargcount(u,1)>>; for each x in '(map mapc maplist mapcar mapcon mapcan) do put(x,'anlfn,'anlmap); symbolic anlfn procedure apply u; begin scalar fn; anforml cdr u; if quotp(fn:=cadr u) and idp(fn:=cadr fn) and eqcar(u:=caddr u,'list) then checkargcount(fn,length cdr u) end; symbolic procedure quotp u; eqcar(u,'quote) or eqcar(u,'function); put('cref ,'simpfg ,'((t (crefon)) (nil (crefoff)))); symbolic procedure outref(s,varlis,body,type); begin scalar curfun!*,calls!*,globs!*,locls!*,toplv!*,a; a:=if varlis memq '(anp!!atom anp!!idb anp!!eq anp!!unknown) then nil else length varlis; s := outrdefun(s,type,if a then a else get(body,'number!-of!-args)); if a then <<add2locs varlis; anform(body); remlocs varlis>> else if null body or not idp body then nil else if varlis eq 'anp!!eq then <<put(s,'sameas,list body); traput(body,'alsois,s)>> else add2calls body; outrefend s end; symbolic procedure traput(u,v,w); begin scalar a; if a:=get(u,v) then (if not(toplv!* or w memq a) then rplacd(a,w . cdr a)) else put(u,v,list w) end; smacro procedure toput(u,v,w); if w then put(u,v,if toplv!* then union(w,get(u,v)) else w); symbolic procedure union(x,y); if null x then y else union(cdr x,if car x member y then y else car x . y); symbolic procedure outrefend s; <<toput(s,'calls,calls!*); for each x in calls!* do <<remflag1(x,'cinthis); if not x eq s then <<chkseen x; traput(x,'calledby,s)>> >>; toput(s,'globs,globs!*); for each x in globs!* do <<traput(x,if isglob x then 'usedby else <<chkgseen x; 'usedunby>>,s); remflag1(x,'glb2rf); if flagp(x,'glb2bd) then <<remflag1(x,'glb2bd); traput(x,'boundby,s)>>; if flagp(x,'glb2st) then <<remflag1(x,'glb2st); traput(x,'setby,s)>> >> >>; symbolic procedure recref(s,type); <<qerline 2; prtatm "*** Redefinition to "; prin1 type; prtatm " procedure, of:"; cref5 s; rempropss(list s,'(calls globs sameas)); newline 2>>; symbolic procedure outrdefun(s,type,v); begin s:=qtypnm(s,type); if flagp(s,'defd) then recref(s,type) else flag1(s,'defd); if flagp(type,'function) and (isglob s or assoc(s,locls!*)) then <<qerline 0; prin2 "**** Variable "; princng s; prin2 " defined as function"; newline 0>>; if v and not flagp(type,'naryarg) then defineargs(s,v); put(s,'gall,curlin!* . type); globs!*:=nil; calls!*:=nil; return curfun!*:=s end; flag('(macro fexpr),'naryarg); symbolic procedure qtypnm(s,type); if flagp(type,'function) then <<chkseen s; s>> else begin scalar x,y,z; if (y:=get(type,'tseen)) and (x:=atsoc(s,cdr y)) then return cdr x; if null y then <<y:=list ('!( . nconc(explode type,list '!))); put(type,'tseen,y); tseen!* := type . tseen!*>>; x := compress (z := explode s); rplacd(y,(s . x) . cdr y); y := append(car y,z); put(x,'rccnam,length y . y); traput(type,'funs,x); return x end; symbolic procedure defineargs(name,n); begin scalar calledwith,x; calledwith:=get(name,'number!-of!-args); if null calledwith then return hasarg(name,n); if n=calledwith then return nil; if x := get(name,'calledby) then instdof(name,n,calledwith,x); hasarg(name,n) end; symbolic procedure instdof(name,n,m,fnlst); <<qerline 0; prin2 "***** "; prin1 name; prin2 " called with "; prin2 m; prin2 " instead of "; prin2 n; prin2 " arguments in:"; lprint(idsort fnlst,posn()+1); newline 0>>; symbolic procedure hasarg(name,n); <<haveargs!*:=name . haveargs!*; if n>maxarg!* then <<qerline 0; prin2 "**** "; prin1 name; prin2 " has "; prin2 n; prin2 " arguments"; newline 0 >>; put(name,'number!-of!-args,n)>>; symbolic procedure checkargcount(name,n); begin scalar correctn; if flagp(name,'naryargs) then return nil; correctn:=get(name,'number!-of!-args); if null correctn then return hasarg(name,n); if not correctn=n then instdof(name,correctn,n,list curfun!*) end; symbolic procedure refprint u; begin scalar x,y; % x:=if cloc!* then filemk car cloc!* else "*ttyinput*"; x:=if cloc!* then car cloc!* else "*TTYINPUT*"; if (curfun!*:=assoc(x,pfiles!*)) then <<x:=car curfun!*; curfun!*:=cdr curfun!*>> else <<pfiles!*:=(x.(curfun!*:=gensym())).pfiles!*; y:=reversip cdr reversip cdr explode x; put(curfun!*,'rccnam,length y . y)>>; curlin!*:=if cloc!* and cdr cloc!* then x . cdr cloc!* else nil; calls!*:=globs!*:=locls!*:=nil; anform u; outrefend curfun!* end; symbolic procedure filemk u; % Convert a file specification from lisp format to a string. % This is essentially the inverse of MKFILE; begin scalar dev,name,flg,flg2; if null u then return nil else if atom u then name := explode2 u else for each x in u do if x eq 'dir!: then flg := t else if atom x then if flg then dev := '!< . nconc(explode2 x,list '!>) else if x eq 'dsk!: then dev:=nil else if !%devp x then dev := explode2 x else name := explode2 x else if atom cdr x then name := nconc(explode2 car x,'!. . explode2 cdr x) else <<flg2 := t; dev := '![ . nconc(explode2 car x, '!, . nconc(explode2 cadr x,list '!]))>>; u := if flg2 then nconc(name,dev) else nconc(dev,name); return compress('!" . nconc(u,'(!"))) end; flag('(smacro nmacro),'cref); symbolic anlfn procedure put u; if toplv!* and qcputx cadr u then anputx u else anforml u; put('putc,'anlfn,get('put,'anlfn)); symbolic procedure qcputx u; eqcar(u,'quote) and (flagp(cadr u,'cref) or flagp(cadr u,'compile)); symbolic procedure anputx u; begin scalar nam,typ,body; nam:=qcrf car u; typ:=qcrf cadr u; u:=caddr u; if atom u then <<body:=qcrf u; u:='anp!!atom>> else if car u memq '(quote function) then if eqcar(u:=cadr u,'lambda) then <<body:=caddr u; u:=cadr u>> else if idp u then <<body:=u; u:='anp!!idb>> else return nil else if car u eq 'cdr and eqcar(cadr u,'getd) then <<body:=qcrf cadadr u; u:='anp!!eq>> else if car u eq 'get and qcputx caddr u then <<body:=qtypnm(qcrf cadr u,cadr caddr u); u:='anp!!eq>> else if car u eq 'mkcode then <<anform cadr u; u:=qcrf caddr u; body:=nil>> else <<body:=qcrf u; u:='anp!!unknown>>; outref(nam,u,body,typ) end; symbolic anlfn procedure putd u; if toplv!* then anputx u else anforml u; symbolic anlfn procedure de u; outdefr(u,'expr); symbolic anlfn procedure df u; outdefr(u,'fexpr); symbolic anlfn procedure dm u; outdefr(u,'macro); symbolic anlfn procedure dn u; % PSL function outdefr(u,'macro); symbolic anlfn procedure ds u; % PSL function outdefr(u,'smacro); symbolic procedure outdefr(u,type); outref(car u,cadr u,caddr u,type); symbolic procedure qcrf u; if null u or u eq t then u else if eqcar(u,'quote) then cadr u else <<anform u; compress explode '!?value!?!?>>; flag('(expr fexpr macro smacro nmacro),'function); symbolic anlfn procedure lap u; if pairp(u:=qcrf car u) then begin scalar globs!*,locls!*,calls!*,curfun!*,toplv!*,x; while u do <<if pairp car u then if x:=get(op!*!*:=caar u,'crflapo) then apply(x,list u) else if !*globals then for each y in cdar u do anlapev y; u:=cdr u>>; qoutrefe() end; symbolic crflapo procedure !*entry u; <<qoutrefe(); u:=cdar u; outrdefun(car u,cadr u,caddr u)>>; symbolic procedure qoutrefe; begin if null curfun!* then if globs!* or calls!* then <<curfun!*:=compress explode '!?lap!?!?; chkseen curfun!*>> else return; outrefend curfun!* end; symbolic crflapo procedure !*lambind u; for each x in caddar u do globind car x; symbolic crflapo procedure !*progbind u; for each x in cadar u do globind car x; symbolic procedure lincall u; <<add2calls car (u:=cdar u); checkargcount(car u,caddr u)>>; put('!*link,'crflapo,'lincall); put('!*linke,'crflapo,'lincall); symbolic procedure anlapev u; if pairp u then if car u memq '(global fluid) then <<u:=cadr u; globref u; if flagp(op!*!*,'store) then put(u,'glb2st,'t)>> else <<anlapev car u; anlapev cdr u>>; flag('(!*store),'store); symbolic procedure qerline u; if pretitl!* then newline u else <<pretitl!*:=t; newpage()>>; % These functions defined to be able to run in bare LISP; symbolic procedure eqcar(u,v); pairp u and car u eq v; symbolic procedure mkquote u; list('quote,u); symbolic procedure efface1(u,v); if null v then nil else if u eq car v then cdr v else rplacd(v,efface1(u,cdr v)); % DECSystem 10/20 dependent part; flag('(pop movem setzm hrrzm),'store); symbolic procedure lapcallf u; begin scalar fn; return if eqcar(cadr (u:=cdar u),'e) then <<add2calls(fn:=cadadr u); checkargcount(fn,car u)>> else if !*globals then anlapev cadr u end; put('jcall,'crflapo,'lapcallf); put('callf,'crflapo,'lapcallf); put('jcallf,'crflapo,'lapcallf); symbolic crflapo procedure call u; if not(caddar u = '(e !*lambind!*)) then lapcallf u else while ((u:=cdr u) and pairp car u and caar u = 0) do globind cadr caddar u; endmodule; end; |
Added r33/rend.red version [0f45790d17].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module rend; % Cray and Sun 4 PSL REDUCE "back-end". % Authors: Martin L. Griss, Anthony C. Hearn and Winfried Neun. % Except where noted, this works with both PSL 3.2 and PSL 3.4. fluid '(!*break !*eolinstringok !*gc !*int !*mode !*usermode currentreadmacroindicator!* currentscantable!* % current!-modulus errout!* lispscantable!* promptstring!* rlispscantable!*); global '(!$eol!$ !*echo !*extraecho !*loadversion !*raise !*rlisp2 crchar!* date!* esc!* e!-value!* ft!-tolerance!* ifl!* ipl!* largest!-small!-modulus ofl!* pi!-value!* spare!* statcounter systemname!*); switch break,gc,usermode,verboseload; !*fastcar := t; % Since REDUCE doesn't use car and cdr on atoms. % One inessential reference to REVERSIP in this module (left unchanged). % This file defines the system dependent code necessary to run REDUCE % under PSL. Comment The following functions, which are referenced in the basic REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to complete the definition of REDUCE: BYE DELCP ERROR1 FILETYPE MKFIL ORDERP QUIT SEPRP SETPCHAR. Prototypical descriptions of these functions are as follows; remprop('bye,'stat); symbolic procedure bye; %Returns control to the computer's operating system command level. %The current REDUCE job cannot be restarted; <<close!-output!-files(); exitlisp()>>; deflist('((bye endstat)),'stat); symbolic procedure delcp u; %Returns true if U is a semicolon, dollar sign, or other delimiter. %This definition replaces one in the BOOT file; u eq '!; or u eq '!$; symbolic procedure seprp u; %returns true if U is a blank or other separator (eg, tab or ff). %This definition replaces one in the BOOT file; u eq '! or u eq '! or u eq !$eol!$; symbolic procedure error1; %This is the simplest error return, without a message printed. It can %be defined as ERROR(99,NIL) if necessary; throw('!$error!$,99); symbolic procedure filetype u; %determines if string U has a specific file type. begin scalar v,w; v := cdr explode u; while v and not(car v eq '!.) do <<if car v eq '!< then while not(car v eq '!>) do v := cdr v; v := cdr v>>; if null v then return nil; v := cdr v; while v and not(car v eq '!") do <<w := car v . w; v := cdr v>>; return intern compress reversip w end; symbolic procedure mkfil u; %converts file descriptor U into valid system filename; if stringp u then u else if not idp u then typerr(u,"file name") else string!-downcase id2string u; % The following is a pretty crude definition, but since it isn't used % very much, its performance doesn't really matter. symbolic procedure string!-downcase u; begin scalar z; if not stringp u then u := id2string u; for each x in explode u do if x memq '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) then z := cdr atsoc(x, '((A . !a) (B . !b) (C . !c) (D . !d) (E . !e) (F . !f) (G . !g) (H . !h) (I . !i) (J . !j) (K . !k) (L . !l) (M . !m) (N . !n) (O . !o) (P . !p) (Q . !q) (R . !r) (S . !s) (T . !t) (U . !u) (V . !v) (W . !w) (X . !x) (Y . !y) (Z . !z))) . z else z := x . z; return compress reverse z end; symbolic procedure orderp(u,v); % Returns true if U has same or higher order than id V by some % consistent convention (eg unique position in memory). wleq(inf u,inf v); % PSL 3.4 form. % id2int u <= id2int v; % PSL 3.2 form. procedure setpchar c; % Set prompt, return old one. begin scalar oldprompt; oldprompt := promptstring!*; promptstring!* := if stringp c then c else if idp c then copystring id2string c else bldmsg("%W", c); return oldprompt end; Comment The following functions are only referenced if various flags are set, or the functions are actually defined. They are defined in another module, which is not needed to build the basic system. The name of the flag follows the function name, enclosed in parentheses: BFQUOTIENT!: (BIGFLOAT) CEDIT (?) COMPD (COMP) EDIT1 This function provides a link to an editor. However, a definition is not necessary, since REDUCE checks to see if it has a function value. EMBFN (?) EZGCDF (EZGCD) FACTORF (FACTOR) LOAD!-MODULE (defined in prolog) PRETTYPRINT (DEFN --- also called by DFPRINT) This function is used in particular for output of RLISP expressions in LISP syntax. If that feature is needed, and the prettyprint module is not available, then it should be defined as PRINT RPRINT (PRET) TEXPT!: (BIGFLOAT) TEXPT!:ANY (BIGFLOAT) TIME (TIME) returns elapsed time from some arbitrary initial point in milliseconds; Comment The FACTOR module also requires a definition for GCTIME. Since this is currently undefined in PSL, we provide the following definition; symbolic procedure gctime; gctime!*; Comment The following operator is used to save a REDUCE session as a file for later use; symbolic procedure savesession u; savesystem("Saved session",u,nil); flag('(savesession),'opfn); flag('(savesession),'noval); Comment make "cd" and "system" available as operators; flag('(cd system),'opfn); flag('(cd system),'noval); Comment The current REDUCE model allows for the availability of fast arithmetical operations on small integers (called "inums"). All modern LISPs provide such support. However, the program will still run without these constructs. The relevant functions that should be defined for this purpose are as follows; remflag('(iplus itimes),'lose); remprop('iplus,'infix); % to allow for redefinition. remprop('itimes,'infix); symbolic macro procedure iplus u; expand(cdr u,'iplus2); symbolic macro procedure itimes u; expand(cdr u,'itimes2); flag('(iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp idifference iquotient iremainder ilessp igreaterp), 'lose); Comment There are also a number of system constants required for each implementation. In systems that don't support inums, the equivalent single precision integers should be used; % E!-VALUE and PI!-VALUE are values for these constants that fit in % the single precision floating point range of the machine. % FT!-TOLERANCE is the tolerance of floating point calculations. % LARGEST!-SMALL!-MODULUS is the largest power of two that can % fit in the fast arithmetic (inum) range of the implementation. % These four are constant for the life of the system and could be % compiled in-line if the compiler permits it. e!-value!* := 2.718282; pi!-value!* := 3.141593; ft!-tolerance!* := 0.000001; largest!-small!-modulus := 2**23; % If the (small) modular arithmetic is always limited to LARGEST-SMALL- % MODULUS, it all fits in the inum range of the machine, with the % exception of modular-times, that needs to use generic arithmetic for % the multiplication. However, on some machines (e.g., the VAX), it is % possible to 'borrow' the extra precision needed, so that the following % definition works. This will not work of course for non-inums. % remflag('(modular!-times),'lose); % smacro procedure modular!-times(u,v); % iremainder(itimes2(u,v),current!-modulus); % flag('(modular!-times),'lose); % The following two definitions are commented out as they lead to % unchecked vector ranges; % symbolic smacro procedure getv(a,b); igetv(a,b); % symbolic smacro procedure putv(a,b,c); iputv(a,b,c); flag('(intersection),'lose); Comment PSL Specific patches; Comment We need to define a function BEGIN, which acts as the top-level call to REDUCE, and sets the appropriate variables; % global '(startuproutine!* toploopread!* toploopeval!* toploopprint!* % toploopname!*); remflag('(begin),'go); symbolic procedure begin; begin !*echo := not !*int; !*extraecho := t; ifl!* := ipl!* := ofl!* := nil; if null date!* then go to a; if !*loadversion then errorset('(load entry),nil,nil); !*gc := nil; !*usermode := nil; linelength if !*int then 80 else 115; prin2 "REDUCE 3.3, "; prin2 date!*; prin2t " ..."; !*mode := if getd 'addsq then 'algebraic else 'symbolic; if !*mode eq 'algebraic then !*break := nil; %since most REDUCE users won't use LISP date!* := nil; a: crchar!* := '! ; if errorp errorset('(begin1),nil,nil) then go to a; %until PSL fixed prin2t "Entering LISP ... " end; flag('(begin),'go); Comment Initial setups for REDUCE; spare!* := 11; % We need this for bootstrapping. symbolic procedure initreduce; % Initial declarations for REDUCE <<statcounter := 0; spare!* := 11; !*int := t; !*eolinstringok := t; % we don't want the "string continued" msg. remd 'main; copyd('main,'rlispmain); date!* := date()>>; symbolic procedure rlispmain; begin scalar l; rlispscantable!* := mkvect 128; l := '(17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 11 11 11 20 11 00 01 02 03 04 05 06 07 08 09 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 rlispdipthong); for i:=0:128 do <<putv(rlispscantable!*,i,car l); l := cdr l>>; currentreadmacroindicator!* := 'rlispreadmacro; currentscantable!* := rlispscantable!*; errout!* := 1; % Errors to standard output, not special stream; eval '(begin); currentscantable!* := lispscantable!*; % But Slisp should use same % syntax as RLISP? standardlisp() end; flag('(dskin savesystem reclaim),'opfn); flag('(dskin savesystem),'noval); flag('(load),'noform); deflist('((load rlis)),'stat); flag('(tr trst untr untrst),'noform); deflist('((tr rlis) (trst rlis) (untr rlis) (untrst rlis)),'stat); % The following is PSL 3.4 specific. switch fulltrace; % Prevents node renaming in trace output. !*fulltrace := t; % Since we usually want it this way. Comment The global variable ESC* is used by the interactive string editor (defined in CEDIT) as a terminator for input strings. In PSL we use the escape character; esc!* := '!; Comment The following declarations are needed to build various modules; flag('(nth pnth spaces subla),'lose); % used in ALG1 flag('(explode2 explode21),'lose); % used in RPRINT flag('(flag1 remflag1),'lose); % used in RCREF Comment The following are only needed for PSL 3.2; % symbolic fexpr procedure definebop u; u; % symbolic fexpr procedure definerop u; u; Comment Specific Optimizations for Cray and Sun 4 version; remflag('(quotdd),'lose); symbolic procedure quotdd(u,v); % U and V are domain elements. Value is U/V if division is exact, % NIL otherwise. if atom u then if atom v %%% then if remainder(u,v)=0 then u/v else nil then (if cdr div = 0 then car div else NIL) where div = divide (u,v) else quotdd(apply1(get(car v,'i2d),u),v) else if atom v then quotdd(u,apply1(get(car u,'i2d),v)) else dcombine(u,v,'quotient); flag('(quotdd),'lose); remflag('(mchk),'lose); symbolic procedure mchk(u,v); IF u eq v then cons(nil,nil) else mchk!-aux (u,v); symbolic procedure mchk!-aux(U,V); if not idp u and not idp v and u=v then cons(nil,nil) else if atom v then if v memq frlis!* then list list (v . u) else nil else if atom u %special check for negative number match; then if numberp u and u<0 then mchk!-aux(list('minus,-u),v) else nil else if car u eq car v then mcharg(cdr u,cdr v,car u) else nil; flag('(mchk),'lose); remflag('(update!-pline),'lose); symbolic procedure update!-pline(x,y,pline); for each j in pline collect ((iplus2(caaar j,x) . iplus2(cdaar j,x)) . iplus2(cdar j ,y)) . cdr j; flag('(update!-pline),'lose); remflag('(peq ordpp noncomp),'lose); symbolic smacro procedure peq(u,v); %tests for equality of powers U and V; (( eq(cdu1,cdu2) and if eq(cu1,cu2) then t else if atom cu1 or atom cu2 then NIL else equal(cu1,cu2) ) where cu1 = car u1,cu2 = car u2,cdu1 = cdr u1,cdu2 = cdr u2 ) where u1 = u,u2 = v; symbolic smacro procedure ordpp(uu,vv); % This used to check (incorrectly) for NCMP!*; ((if caru eq carv then igreaterp(cdru,cdrv) else ordop(caru,carv) ) where caru = car u, carv = car v, cdru = cdr u, cdrv = cdr v )where u=uu,v=vv; symbolic smacro procedure noncomp uu; ( pairp u and ((idp caru and flagp(caru,'noncom) )where caru = car u)) where u = uu; flag('(peq ordpp noncomp),'lose); Comment Now set the system name; systemname!* := 'sparc; endmodule; end; |
Added r33/rlisp.red version [8bdc4a17ce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % module module; % Support for module use. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(exportslist!* importslist!* module!-name!* old!-mode!*); !*mode := 'symbolic; % initial value. symbolic procedure exports u; begin exportslist!* := union(u,exportslist!*); end; symbolic procedure imports u; begin importslist!* := union(u,importslist!*); end; symbolic procedure module u; %Sets up a module definition; begin if null module!-name!* then old!-mode!* := !*mode; module!-name!* := car u . module!-name!*; !*mode := 'symbolic end; symbolic procedure endmodule; begin if null module!-name!* then rederr "ENDMODULE called outside module"; exportslist!* := nil; importslist!* := nil; module!-name!* := cdr module!-name!*; if module!-name!* then return nil; !*mode := old!-mode!*; old!-mode!* := nil end; deflist('((exports rlis) (imports rlis) (module rlis)),'stat); put('endmodule,'stat,'rlis); % Done this way for bootstrapping purposes. flag('(endmodule),'go); % endmodule; module newtok; % Functions for introducing infix tokens to the system. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*redeflg!*); global '(!*msg preclis!*); %Several operators in REDUCE are used in an infix form (e.g., %+,- ). The internal alphanumeric names associated with these %operators are introduced by the function NEWTOK defined below. %This association, and the precedence of each infix operator, is %initialized in this section. We also associate printing characters %with each internal alphanumeric name as well; preclis!*:= '(or and not member memq equal neq eq geq greaterp leq lessp freeof plus difference times quotient expt cons); deflist ('( (not not) (plus plus) (difference minus) (minus minus) (times times) (quotient recip) (recip recip) ), 'unary); flag ('(and or !*comma!* plus times),'nary); flag ('(cons setq plus times),'right); deflist ('((minus plus) (recip times)),'alt); symbolic procedure mkprec; begin scalar x,y,z; x := 'where . ('!*comma!* . ('setq . preclis!*)); y := 1; a: if null x then return nil; put(car x,'infix,y); put(car x,'op,list list(y,y)); %for RPRINT; if z := get(car x,'unary) then put(z,'infix,y); if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y)); x := cdr x; y := add1 y; go to a end; mkprec(); symbolic procedure newtok u; begin scalar !*redeflg!*,x,y; if atom u or atom car u or null idp caar u then typerr(u,"NEWTOK argument"); % set up SWITCH* property. put(caar u,'switch!*, cdr newtok1(car u,cadr u,get(caar u,'switch!*))); % set up PRTCH property. y := intern compress consescc car u; if !*redeflg!* then lprim list(y,"redefined"); put(cadr u,'prtch,y); if x := get(cadr u,'unary) then put(x,'prtch,y) end; symbolic procedure newtok1(charlist,name,propy); if null propy then lstchr(charlist,name) else if null cdr charlist then begin if cdr propy and !*msg then !*redeflg!* := t; return list(car charlist,car propy,name) end else car charlist . newtok2(cdr charlist,name,car propy) . cdr propy; symbolic procedure newtok2(charlist,name,assoclist); if null assoclist then list lstchr(charlist,name) else if car charlist eq caar assoclist then newtok1(charlist,name,cdar assoclist) . cdr assoclist else car assoclist . newtok2(charlist,name,cdr assoclist); symbolic procedure consescc u; if null u then nil else '!! . car u . consescc cdr u; symbolic procedure lstchr(u,v); if null cdr u then list(car u,nil,v) else list(car u,list lstchr(cdr u,v)); newtok '((!$) !*semicol!*); newtok '((!;) !*semicol!*); newtok '((!+) plus); newtok '((!-) difference); newtok '((!*) times); newtok '((!^) expt); newtok '((!* !*) expt); newtok '((!/) quotient); newtok '((!=) equal); newtok '((!,) !*comma!*); newtok '((!() !*lpar!*); newtok '((!)) !*rpar!*); newtok '((!:) !*colon!*); newtok '((!: !=) setq); newtok '((!.) cons); newtok '((!<) lessp); newtok '((!< !=) leq); newtok '((!< !<) !*lsqb!*); newtok '((!>) greaterp); newtok '((!> !=) geq); newtok '((!> !>) !*rsqb!*); put('expt,'prtch,'!*!*); % To ensure that FORTRAN output is correct. flag('(difference minus plus setq),'spaced); flag('(newtok),'eval); endmodule; module support; % Basic functions needed to support RLISP and REDUCE. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure aconc(u,v); %adds element v to the tail of u. u is destroyed in process; nconc(u,list v); symbolic procedure arrayp u; get(u,'rtype) eq 'array; symbolic procedure atsoc(u,v); if null v then nil else if u eq caar v then car v else atsoc(u,cdr v); symbolic procedure eqcar(u,v); null atom u and car u eq v; symbolic procedure flagpcar(u,v); null atom u and idp car u and flagp(car u,v); symbolic procedure idlistp u; % True if u is a list of id's. null u or null atom u and idp car u and idlistp cdr u; symbolic procedure mkprog(u,v); 'prog . (u . v); symbolic procedure mkquote u; list('quote,u); symbolic procedure mksetq(u,v); list('setq,u,v); symbolic procedure pairvars(u,vars,mode); % Sets up pairings of parameters and modes. begin scalar x; a: if null u then return append(reversip!* x,vars) else if null idp car u then symerr("Invalid parameter",nil); x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure prin2t u; progn(prin2 u, terpri(), u); symbolic procedure reversip u; begin scalar x,y; a: if null u then return y; x := cdr u; y := rplacd(u,y); u := x; go to a end; symbolic procedure smemq(u,v); %true if id U is a member of V at any level (excluding %quoted expressions); if atom v then u eq v else if car v eq 'quote then nil else smemq(u,car v) or smemq(u,cdr v); symbolic procedure union(x,y); if null x then y else union(cdr x,if car x member y then y else car x . y); symbolic procedure xn(u,v); if null u then nil else if car u member v then car u . xn(cdr u,delete(car u,v)) else xn(cdr u,v); symbolic procedure u>=v; null(u<v); symbolic procedure u<=v; null(u>v); symbolic procedure u neq v; null(u=v); symbolic procedure setdiff(u,v); if null v then u else setdiff(delete(car v,u),cdr v); % symbolic smacro procedure u>=v; null(u<v); % symbolic smacro procedure u<=v; null(u>v); % symbolic smacro procedure u neq v; null(u=v); % List changing alternates (may also be defined as copying functions) symbolic procedure aconc!*(u,v); nconc(u,list v); % append(u,list v); symbolic procedure nconc!*(u,v); nconc(u,v); % append(u,v); symbolic procedure reversip!* u; reversip u; % reverse u; symbolic procedure rplaca!*(u,v); rplaca(u,v); % v . cdr u; symbolic procedure rplacd!*(u,v); rplacd(u,v); % car u . v; % The following functions should be provided in the compiler for % efficient coding. symbolic procedure apply1(u,v); apply(u,list v); symbolic procedure apply2(u,v,w); apply(u,list(v,w)); symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x)); % The following function is needed by several modules. It is more % REDUCE-specific than other functions in this module, but since it % needs to be defined early on, it might as well go here. symbolic procedure gettype u; % Returns a REDUCE-related type for the expression U. % It needs to be more table driven than the current definition. if numberp u then 'number else if null atom u or null u or null idp u then 'form else if get(u,'simpfn) then 'operator else if get(u,'avalue) then 'variable else if getd u then 'procedure else if globalp u then 'global else if fluidp u then 'fluid else if flagp(u,'parm) then 'parameter else get(u,'rtype); endmodule; module slfns; % Complete list of Standard LISP functions. % Author: Anthony C. Hearn. global '(!*argnochk slfns!*); slfns!* := '( (abs 1) (add1 1) (append 2) (apply 2) (assoc 2) (atom 1) (car 1) (cdr 1) (caar 1) (cadr 1) (cdar 1) (cddr 1) (caaar 1) (caadr 1) (cadar 1) (caddr 1) (cdaar 1) (cdadr 1) (cddar 1) (cdddr 1) (caaaar 1) (caaadr 1) (caadar 1) (caaddr 1) (cadaar 1) (cadadr 1) (caddar 1) (cadddr 1) (cdaaar 1) (cdaadr 1) (cdadar 1) (cdaddr 1) (cddaar 1) (cddadr 1) (cdddar 1) (cddddr 1) (close 1) (codep 1) (compress 1) (cons 2) (constantp 1) (de 3) (deflist 2) (delete 2) % (DF 3) conflicts with algebraic operator DF (difference 2) (digit 1) (divide 2) (dm 3) (dn 3) (ds 3) (eject 0) (eq 2) (eqn 2) (equal 2) (error 2) (errorset 3) (eval 1) (evlis 1) (expand 2) (explode 1) (expt 2) (fix 1) (fixp 1) (flag 2) (flagp 2) (float 1) (floatp 1) (fluid 1) (fluidp 1) (function 1) (gensym 0) (get 2) (getd 1) (getv 2) (global 1) (globalp 1) (go 1) (greaterp 2) (idp 1) (intern 1) (length 1) (lessp 2) (linelength 1) (liter 1) (lposn 0) (map 2) (mapc 2) (mapcan 2) (mapcar 2) (mapcon 2) (maplist 2) (max2 2) (member 2) (memq 2) (minus 1) (minusp 1) (min2 2) (mkvect 1) (nconc 2) (not 1) (null 1) (numberp 1) (onep 1) (open 2) (pagelength 1) (pair 2) (pairp 1) (plus2 2) (posn 0) (print 1) (prin1 1) (prin2 1) (prog2 2) (put 3) (putd 3) (putv 3) (quote 1) (quotient 2) (rds 1) (read 0) (readch 0) (remainder 2) (remd 1) (remflag 2) (remob 1) (remprop 2) (return 1) (reverse 1) (rplaca 2) (rplacd 2) (sassoc 3) (set 2) (setq 2) (stringp 1) (sublis 2) (subst 3) (sub1 1) (terpri 0) (times2 2) (unfluid 1) (upbv 1) (vectorp 1) (wrs 1) (zerop 1) ); if !*argnochk then deflist(slfns!*,'number!-of!-args); endmodule; module superv; % REDUCE supervisory functions. % Author: Anthony C. Hearn. % Modified by: Jed B. Marti. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*defn !*errcont !*int !*mode !*slin !*time dfprint!* lreadfn!* semic!* tslin!*); global '(!$eof!$ !*byeflag!* !*demo !*echo !*extraecho !*lessspace !*micro!-version !*nosave!* !*output !*pret !*rlisp2 !*strind !*struct cloc!* cmsg!* crbuf!* crbuflis!* crbuf1!* cursym!* eof!* erfg!* ifl!* ipl!* initl!* inputbuflis!* key!* ofl!* opl!* ogctime!* otime!* program!* programl!* promptexp!* resultbuflis!* st!* statcounter symchar!* tok!* ttype!* ws); !*output := t; eof!* := 0; initl!* := '(fname!* outl!*); statcounter := 0; % The true REDUCE supervisory function is BEGIN, again defined in the % system dependent part of this program. However, most of the work is % done by BEGIN1, which is called by BEGIN for every file encountered % on input; symbolic procedure errorp u; %returns true if U is an ERRORSET error format; atom u or cdr u; symbolic procedure flagp!*!*(u,v); idp u and flagp(u,v); symbolic procedure printprompt u; %Prints the prompt expression for input; progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*); symbolic procedure setcloc!*; % Used to set for file input a global variable CLOC!* to dotted pair % of file name and dotted pair of line and page being read. % Currently a place holder for system specific function, since not % supported in Standard LISP. CLOC!* is used in the INTER and RCREF % modules. cloc!* := if null ifl!* then nil else car ifl!* . nil; symbolic procedure command; begin scalar x; if !*demo and (x := ifl!*) then progn(terpri(),rds nil,readch(),rds cadr x); if null !*slin then if !*rlisp2 then progn(s!&(), key!* := tok!*, m!-metarlisp(), (if st!* then x := car st!* else x := nil), st!* := nil) else progn(scan(), setcloc!*(), key!* := cursym!*, x := xread1 nil) else progn(key!* := (semic!* := '!;), setcloc!*(), x := (if lreadfn!* then apply(lreadfn!*,nil) else read()), if key!* eq '!; then key!* := if atom x then x else car x); if !*struct then x := structchk x; if !*pret then progn(terpri(),rprint x); if null !*slin then x := form x; return x end; symbolic procedure begin1; begin scalar mode,parserr,result,x; if !*rlisp2 then prolog 'm!-metarlisp; otime!* := time(); % the next line is that way for bootstrapping purposes. if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0; a0: cursym!* := '!*semicol!*; a: if null terminalp() or !*nosave!* then go to b else if statcounter>0 then add2buflis(); statcounter := statcounter + 1; crbuf1!* := nil; % For input string editor. !*strind := 0; % Used by some versions of input editor. promptexp!* := compress('!! . append(explode statcounter, explode if null symchar!* or !*mode eq 'algebraic then '!:! else '!*! )); setpchar promptexp!*; b: parserr := nil; !*nosave!* := nil; if !*time then eval '(showtime); %Since a STAT; if !*output and null ofl!* and terminalp() and null !*defn and null !*lessspace then terpri(); if tslin!* then progn(!*slin := car tslin!*, lreadfn!* := cdr tslin!*, tslin!* := nil); mapcar(initl!*,function sinitl); if !*int then erfg!* := nil; %to make editing work properly; if null !*rlisp2 and cursym!* eq 'end then progn(comm1 'end, return nil) else if terminalp() and (!*rlisp2 or null(key!* eq 'ed)) then printprompt promptexp!*; program!* := errorset('(command),t,!*backtrace); if !*rlisp2 then if tok!* eq '!*semic!* then semic!* := '!; else semic!* := '!$; condterpri(); if errorp program!* then go to err1; program!* := car program!*; if eofcheck() then go to c else eof!* := 0; if !*rlisp2 then if program!* = '(end) then return nil else nil else if cursym!* eq 'end then if !*micro!-version and terminalp() then go to a0 else progn(comm1 'end, return nil) else if eqcar(program!*,'retry) then program!* := programl!*; %The following section decides what the target mode should be. %That mode is also assumed to be the printing mode; if flagp!*!*(key!*,'modefn) then mode := key!* else if null atom program!* % and null !*micro!-version and null(car program!* eq 'quote) and (null(idp car program!* and (flagp(car program!*,'nochange) or flagp(car program!*,'intfn) or car program!* eq 'list)) or car program!* memq '(setq setel setf) and eqcar(caddr program!*,'quote)) then mode := 'symbolic else if key!* eq 'input and (x := rassoc!*(program!*,inputbuflis!*)) then mode := cddr x else mode := !*mode; program!* := convertmode1(program!*,nil,'symbolic,mode); add2inputbuf(program!*,!*mode); % This used to be MODE, but then ED n wouldn't work. if null !*rlisp2 and null atom program!* and car program!* memq '(bye quit) then if getd 'bye then progn(eval program!*, go to b) else progn(!*byeflag!* := t, return nil) else if null !*rlisp2 and eqcar(program!*,'ed) then progn((if getd 'cedit and terminalp() then cedit cdr program!* else lprim "ED not supported"), go to b) else if !*defn then if erfg!* then go to a else if null flagp!*!*(key!*,'ignore) and null eqcar(program!*,'quote) then go to d; b1: if !*output and ifl!* and !*echo and null !*lessspace then terpri(); result := errorset((if mode eq 'symbolic then program!* else list('assgneval,mkquote program!*)), t,!*backtrace); if errorp result or erfg!* then progn(programl!* := program!*,go to err2) else if !*defn then go to a; if null(mode eq 'symbolic) then progn(program!* := cdar result, result := list caar result); add2resultbuf(car result,mode); if null !*output then go to a else if (null !*rlisp2 and semic!* eq '!;) or (!*rlisp2 and tok!* eq '!*semic!*) then if mode eq 'symbolic then if null car result and null(!*mode eq 'symbolic) then nil else begin terpri(); result := errorset(list('print,mkquote car result), t,!*backtrace) end else if car result then result := errorset(list('varpri,mkquote car result, mkquote program!*, mkquote 'only), t,!*backtrace); if errorp result then go to err3 else go to a; c: if crbuf1!* then progn(lprim "Closing object improperly removed. Redo edit.", crbuf1!* := nil, go to a) else if eof!*>4 then progn(lprim "End-of-file read", return eval '(bye)) else if terminalp() then progn(crbuf!* := nil, go to b) else return nil; d: if program!* then dfprint program!*; if null flagp!*!*(key!*,'eval) then go to a else go to b1; err1: if eofcheck() or eof!*>0 then go to c else if program!*="BEGIN invalid" then go to a; parserr := t; err2: resetparser(); %in case parser needs to be modified; err3: erfg!* := t; if null !*int and null !*errcont then progn(!*defn := t, !*echo := t, (if null cmsg!* then lprie "Continuing with parsing only ..."), cmsg!* := t) else if null !*errcont then progn(result := pause1 parserr, (if result then return null eval result), erfg!* := nil) else erfg!* := nil; go to a end; flag ('(deflist flag fluid global remflag remprop unfluid),'eval); symbolic procedure assgneval u; % Evaluate (possible) assignment statements and return results in a % form that allows required printing of such assignments. begin scalar x,y; a: if atom u then go to b else if car u eq 'setq then x := ('setq . cadr u) . x else if car u eq 'setel then x := ('setel . mkquote eval cadr u) . x else if car u eq 'setk then x := ('setk . mkquote if atom (y := eval cadr u) then y else car y . revlis cdr y) . x else go to b; u := caddr u; go to a; b: u := mkquote eval u; c: if null x then return(eval u . u); u := list(caar x,cdar x,u); x := cdr x; go to c end; symbolic procedure rassoc!*(u,v); % Finds term in which U is the first term in the right part of a term % in the association list V, or NIL if term is not found; if null v then nil else if u = cadar v then car v else rassoc!*(u,cdr v); symbolic procedure close!-input!-files; % Close all input files currently open; begin if ifl!* then progn(rds nil,ifl!* := nil); aa: if null ipl!* then return nil; close cdar ipl!*; ipl!* := cdr ipl!*; go to aa end; symbolic procedure close!-output!-files; % Close all output files currently open; begin if ofl!* then progn(wrs nil,ofl!* := nil); aa: if null opl!* then return nil; close cdar opl!*; opl!* := cdr opl!*; go to aa end; symbolic procedure add2buflis; begin if null crbuf!* then return nil; crbuf!* := reversip crbuf!*; %put in right order; a: if seprp car crbuf!* then progn(crbuf!* := cdr crbuf!*, go to a); crbuflis!* := (statcounter . crbuf!*) . crbuflis!*; crbuf!* := nil end; symbolic procedure add2inputbuf(u,mode); begin if null terminalp() or !*nosave!* then return nil; inputbuflis!* := (statcounter . u . mode) . inputbuflis!* end; symbolic procedure add2resultbuf(u,mode); begin if mode eq 'symbolic or null u or !*nosave!* then return nil; ws := u; if terminalp() then resultbuflis!* := (statcounter . u) . resultbuflis!* end; symbolic procedure condterpri; !*output and !*echo and !*extraecho and (null !*int or ifl!*) and null !*defn and terpri(); symbolic procedure eofcheck; % true if an end-of-file has been read in current input sequence; program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1); symbolic procedure resetparser; %resets the parser after an error; if null !*slin then comm1 t; symbolic procedure terminalp; %true if input is coming from an interactive terminal; !*int and null ifl!*; symbolic procedure dfprint u; %Looks for special action on a form, otherwise prettyprints it; if dfprint!* then apply(dfprint!*,list u) else if cmsg!* then nil else if null eqcar(u,'progn) then prettyprint u else begin a: u := cdr u; if null u then return nil; dfprint car u; go to a end; symbolic procedure showtime; begin scalar x,y; x := otime!*; otime!* := time(); x := otime!*-x; y := ogctime!*; ogctime!* := gctime(); y := ogctime!* - y; x := x - y; terpri(); prin2 "Time: "; prin2 x; prin2 " ms"; if y = 0 then return terpri(); prin2 " plus GC time: "; prin2 y; prin2 " ms" end; symbolic procedure sinitl u; set(u,get(u,'initl)); endmodule; module tok; % Identifier and reserved character reading. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(semic!*); global '(!$eof!$ !$eol!$ !*quotenewnam !*raise crbuf!* crbuf1!* crchar!* curline!* cursym!* eof!* ifl!* nxtsym!* outl!* ttype!*); !*quotenewnam := t; crchar!* := '! ; curline!* := 1; % The function TOKEN defined below is used for reading identifiers % and reserved characters (such as parentheses and infix operators). % It is called by the function SCAN, which translates reserved % characters into their internal name, and sets up the output of the % input line. The following definitions of TOKEN and SCAN are quite % general, but also inefficient. The reading process can often be % speeded up considerably if these functions (especially token) are % written in terms of the explicit LISP used. symbolic procedure prin2x u; outl!* := u . outl!*; symbolic procedure mkstrng u; %converts the uninterned id U into a string; %if strings are not constants, this should be replaced by %list('string,u); u; symbolic procedure readch1; begin scalar x; if null terminalp() then progn(x := readch(), x eq !$eol!$ and (curline!* := curline!*+1), return x) else if crbuf1!* then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end else x := readch(); crbuf!* := x . crbuf!*; return x end; symbolic procedure token1; begin scalar x,y,z; x := crchar!*; a: if seprp x then progn(x := readch1(), go to a) else if digit x then go to number else if liter x then go to letter else if x eq '!% then go to coment else if x eq '!! then go to escape else if x eq '!' then progn(crchar!* := readch1(), nxtsym!* := mkquote rread(), ttype!* := 4, return nxtsym!*) else if x eq '!" then go to string; ttype!* := 3; if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr()); nxtsym!* := x; a1: if delcp x then crchar!*:= '! else crchar!*:= readch1(); go to c; escape: begin scalar raise; raise := !*raise; !*raise := nil; y := x . y; x := readch1(); !*raise := raise end; letter: ttype!* := 0; let1: y := x . y; if digit (x := readch1()) or liter x then go to let1 else if x eq '!! then go to escape; nxtsym!* := intern compress reversip!* y; b: crchar!* := x; c: return nxtsym!*; number: ttype!* := 2; num1: y := x . y; z := x; if digit (x := readch1()) or x eq '!. or x eq 'e or z eq 'e then go to num1; nxtsym!* := compress reversip!* y; go to b; string: begin scalar raise; raise := !*raise; !*raise := nil; strinx: y := x . y; if null((x := readch1()) eq '!") then go to strinx; y := x . y; nxtsym!* := mkstrng compress reversip!* y; !*raise := raise end; ttype!* := 1; go to a1; coment: if null(readch1() eq !$eol!$) then go to coment; x := readch1(); go to a end; symbolic procedure token; %This provides a hook for a faster TOKEN; token1(); symbolic procedure filenderr; begin eof!* := eof!*+1; if terminalp() then error1() else error(99,if ifl!* then list("End-of-file read in file",car ifl!*) else "End-of-file read") end; symbolic procedure ptoken; begin scalar x; x := token(); if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*; %an explicit reference to OUTL!* used here; prin2x x; if null ((x eq '!() or (x eq '!))) then prin2x '! ; return x end; symbolic procedure rread1; % Modified to use QUOTENEWNAM's for ids. begin scalar x,y; x := ptoken(); if null (ttype!*=3) then return if null idp x or null !*quotenewnam or null(y := get(x,'quotenewnam)) then x else y else if x eq '!( then return rrdls() else if null (x eq '!+ or x eq '!-) then return x; y := ptoken(); if null numberp y then progn(nxtsym!* := " ", symerr("Syntax error: improper number",nil)) else if x eq '!- then y := apply('minus,list y); %we need this construct for bootstrapping purposes; return y end; symbolic procedure rrdls; begin scalar x,y,z; a: x := rread1(); if null (ttype!*=3) then go to b else if x eq '!) then return z else if null (x eq '!.) then go to b; x := rread1(); y := ptoken(); if null (ttype!*=3) or null (y eq '!)) then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil)) else return nconc(z,x); b: z := nconc(z,list x); go to a end; symbolic procedure rread; progn(prin2x " '",rread1()); symbolic procedure scan; begin scalar x,y; if null (cursym!* eq '!*semicol!*) then go to b; a: nxtsym!* := token(); b: if null atom nxtsym!* then go to q1 else if nxtsym!* eq 'else or cursym!* eq '!*semicol!* then outl!* := nil; prin2x nxtsym!*; c: if null idp nxtsym!* then go to l else if (x:=get(nxtsym!*,'newnam)) and (null (x=nxtsym!*)) then go to new else if nxtsym!* eq 'comment OR NXTSYM!* EQ '!% AND TTYPE!*=3 THEN GO TO COMM ELSE IF NULL(TTYPE!* = 3) THEN GO TO L ELSE IF NXTSYM!* EQ !$eof!$ then return filenderr() else if nxtsym!* eq '!' then go to quote else if null (x:= get(nxtsym!*,'switch!*)) then go to l else if eqcar(cdr x,'!*semicol!*) then go to delim; sw1: nxtsym!* := token(); if null(ttype!* = 3) then go to sw2 else if nxtsym!* eq !$eof!$ then return filenderr() else if car x then go to sw3; sw2: cursym!*:=cadr x; if cursym!* eq '!*rpar!* then go to l2 else return cursym!*; sw3: if null (y:= atsoc(nxtsym!*,car x)) then go to sw2; prin2x nxtsym!*; x := cdr y; go to sw1; comm: if delcp crchar!* then go to com1; crchar!* := readch(); go to comm; com1: crchar!* := '! ; condterpri(); go to a; delim: semic!*:=nxtsym!*; return (cursym!*:='!*semicol!*); new: nxtsym!* := x; if stringp x then go to l else if atom x then go to c else go to l; quote: nxtsym!* := mkquote rread1(); go to l; q1: if null (car nxtsym!* eq 'string) then go to l; prin2x " "; prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*); l: cursym!*:=nxtsym!*; l1: nxtsym!* := token(); if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr(); l2: if numberp nxtsym!* or (atom nxtsym!* and null get(nxtsym!*,'switch!*)) then prin2x " "; return cursym!* end; endmodule; module xread; % Routines for parsing REDUCE input. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!* nxtsym!*); % The conversion of a REDUCE expression to LISP prefix form is carried % out by the function XREAD. This function initiates the scanning % process, and then calls the auxiliary function XREAD1 to perform the % actual parsing. Both XREAD and XREAD1 are used by many functions % whenever an expression must be read; flag ('(end !*colon!* !*semicol!*),'delim); symbolic procedure chknewnam u; % Check to see if U has a newnam, and return it else return U. begin scalar x; return if null(x := get(u,'newnam)) or x eq u then u else if idp x then chknewnam x else x end; symbolic procedure mkvar(u,v); u; symbolic procedure remcomma u; if eqcar(u,'!*comma!*) then cdr u else list u; symbolic procedure xread1 u; begin scalar v,w,x,y,z,z1,z2; % v: expression being built % w: prefix operator stack % x: infix operator stack % y: infix value or stat property % z: current symbol % z1: next symbol % z2: temporary storage; a: z := cursym!*; a1: if null idp z then nil else if z eq '!*lpar!* then go to lparen else if z eq '!*rpar!* then go to rparen else if y := get(z,'infix) then go to infx % The next line now commented out was intended to allow a STAT % to be used as a label. However, it prevents the definition of % a diphthong whose first character is a colon. % else if nxtsym!* eq '!: then nil else if flagp(z,'delim) then go to delimit else if y := get(z,'stat) then go to stat; a2: y := nil; a3: w := z . w; if numberp z and idp (z1 := chknewnam nxtsym!*) and null flagp(z1,'delim) and null(get(z1,'switch!*) and null(z1 eq '!()) and null get(z1,'infix) then progn(cursym!* := 'times, go to a); % allow for implicit * after a number. next: z := scan(); go to a1; lparen: y := nil; if scan() eq '!*rpar!* then go to lp1 % no args else if flagpcar(w,'struct) then z := xread1 car w else z := xread1 'paren; if flagp(u,'struct) then progn(z := remcomma z, go to a3) else if null eqcar(z,'!*comma!*) then go to a3 else if null w then (if u eq 'lambda then go to a3 else symerr("Improper delimiter",nil)) else w := (car w . cdr z) . cdr w; go to next; lp1: if w then w := list car w . cdr w; %function of no args; go to next; rparen: if null u or u eq 'group or u eq 'proc then symerr("Too many right parentheses",nil) else go to end1; infx: if z eq '!*comma!* or null atom (z1 := scan()) or numberp z1 then go to in1 else if z1 eq '!*rpar!*%infix operator used as variable; or z1 eq '!*comma!* or flagp(z1,'delim) then go to in2 else if z1 eq '!*lpar!*%infix operator in prefix position; and null atom(z1 := xread 'paren) and car z1 eq '!*comma!* and (z := z . cdr z1) then go to a1; in1: if w then go to unwind else if null(z := get(z,'unary)) then symerr("Redundant operator",nil); v := '!*!*un!*!* . v; go to pr1; in2: y := nil; w := z . w; in3: z := z1; go to a1; unwind: z2 := mkvar(car w,z); un1: w:= cdr w; if null w then go to un2 else if numberp car w then symerr("Missing operator",nil); z2 := list(car w,z2); go to un1; un2: v:= z2 . v; preced: if null x then if y=0 then go to end2 else nil else if y<caar x or (y=caar x and ((z eq cdar x and null flagp(z,'nary) and null flagp(z,'right)) or get(cdar x,'alt))) then go to pr2; pr1: x:= (y . z) . x; if null(z eq '!*comma!*) then go to in3 else if cdr x or null u or u memq '(lambda paren) or flagp(u,'struct) then go to next else go to end2; pr2: %if cdar x eq 'setq then go to assign else; if cadr v eq '!*!*un!*!* then (if car v eq '!*!*un!*!* then go to pr1 else z2 := list(cdar x,car v)) else z2 := cdar x . if eqcar(car v,cdar x) and flagp(cdar x,'nary) then (cadr v . cdar v) else list(cadr v,car v); x:= cdr x; v := z2 . cddr v; go to preced; stat: if null(flagp(z,'go) or null(u eq 'proc) and (flagp(y,'endstat) or (null delcp nxtsym!* and null (nxtsym!* eq '!,)))) then go to a2; w := apply(y,nil) . w; y := nil; go to a; delimit: if z eq '!*colon!* and null(u eq 'for) and (null !*blockp or null w or null atom car w or cdr w) or flagp(z,'nodel) and (null u or u eq 'group and null z memq '(!*rsqb!* !*rcbkt!*)) then symerr("Improper delimiter",nil) else if idp u and (u eq 'paren or flagp(u,'struct)) then symerr("Too few right parentheses",nil); end1: if y then symerr("Improper delimiter",nil) else if null v and null w and null x then return nil; y := 0; go to unwind; end2: if null cdr v then return car v else symerr("Improper delimiter",nil) end; %symbolic procedure getels u; % getel(car u . !*evlis cdr u); %symbolic procedure !*evlis u; % mapcar(u,function eval); flag ('(endstat retstat),'endstat); flag ('(else until),'nodel); flag ('(begin),'go); symbolic procedure xread u; progn(scan(),xread1 u); flag('(xread),'opfn); %to make it an operator; endmodule; module lpri; % Functions for printing diagnostic and error messages. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*defn !*int); global '(!*echo !*fort !*msg !*nat !*rlisp2 cursym!* erfg!* ofl!* outl!*); symbolic procedure lpri u; begin a: if null u then return nil; prin2 car u; prin2 " "; u := cdr u; go to a end; symbolic procedure lpriw (u,v); begin scalar x; u := u . if v and atom v then list v else v; if ofl!* and (!*fort or not !*nat or !*defn) then go to c; terpri(); a: lpri u; terpri(); if null x then go to b; wrs cdr x; return nil; b: if null ofl!* then return nil; c: x := ofl!*; wrs nil; go to a end; symbolic procedure lprim u; !*msg and lpriw("***",u); symbolic procedure lprie u; begin scalar x; if !*int then go to a; x:= !*defn; !*defn := nil; a: erfg!* := t; lpriw ("*****",u); if null !*int then !*defn := x end; symbolic procedure printty u; begin scalar ofl; if null !*fort and !*nat then print u; if null ofl!* then return nil; ofl := ofl!*; wrs nil; print u; wrs cdr ofl end; symbolic procedure rederr u; begin lprie u; error1() end; symbolic procedure symerr(u,v); begin scalar x; erfg!* := t; if numberp cursym!* or not(x := get(cursym!*,'prtch)) then x := cursym!*; terpri(); if !*echo then terpri(); outl!*:=car outl!* . '!$!$!$ . cdr outl!*; comm1 t; mapcar(reversip!* outl!*,function prin2); terpri(); outl!* := nil; if null v then rederr u else rederr(x . ("invalid" . (if u then list("in",u,"statement") else nil))) end; symbolic procedure typerr(u,v); rederr list(u,"invalid as",v); endmodule; module parser; % Functions for parsing RLISP expressions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*mode); global '(cursym!* letl!* nxtsym!*); %With the exception of assignment statements, which are handled by %XREAD, statements in REDUCE are introduced by a key-word, which %initiates a reading process peculiar to that statement. The key-word %is recognized (in XREAD1) by the indicator STAT on its property list. %The corresponding property is the name of the function (of no %arguments) which carries out the reading sequence. % ***** COMMENTS ***** symbolic procedure comm1 u; begin scalar bool; if u eq 'end then go to b; a: if cursym!* eq '!*semicol!* or u eq 'end and cursym!* memq '(end else then until !*rpar!* !*rsqb!*) then return nil else if u eq 'end and null bool then progn(lprim list("END-COMMENT NO LONGER SUPPORTED"), bool := t); b: scan(); go to a end; % ***** CONDITIONAL STATEMENT ***** symbolic procedure ifstat; begin scalar condx,condit; a: condx := xread t; if not cursym!* eq 'then then symerr('if,t); condit := aconc!*(condit,list(condx,xread t)); if not cursym!* eq 'else then nil else if scan() eq 'if then go to a else condit := aconc!*(condit,list(t,xread1 t)); return ('cond . condit) end; put('if,'stat,'ifstat); flag ('(then else),'delim); % ***** LAMBDA STATEMENT ***** symbolic procedure lamstat; begin scalar x,y; x:= xread 'lambda; % x := flagtype(if null x then nil else remcomma x,'scalar); if x then x := remcomma x; y := list('lambda,x,xread t); % remtype x; return y end; put ('lambda,'stat,'lamstat); % ***** GROUP STATEMENT ***** symbolic procedure mkprogn; %Expects a list of statements terminated by a >>; begin scalar lst; a: lst := aconc!*(lst,xread 'group); if null(cursym!* eq '!*rsqb!*) then go to a; scan(); return ('progn . lst) end; put('!*lsqb!*,'stat,'mkprogn); flag('(!*rsqb!*),'delim); flag('(!*rsqb!*),'nodel); % ***** END STATEMENT ***** symbolic procedure endstat; %This procedure can also be used for any key-words which take no %arguments; begin scalar x; x := cursym!*; comm1 'end; return list x end; put('end,'stat,'endstat); put('endmodule,'stat,'endstat); put('bye,'stat,'endstat); put('quit,'stat,'endstat); flag('(bye quit),'eval); put('showtime,'stat,'endstat); endmodule; module block; % Block statement and related operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(!*vars!* cursym!* nxtsym!*); % ***** GO statement ***** symbolic procedure gostat; begin scalar var; var := if eq(scan(),'to) then scan() else cursym!*; scan(); return list('go,var) end; put('go,'stat,'gostat); put('goto,'newnam,'go); % ***** Declaration Statement ***** symbolic procedure decl u; begin scalar varlis,w; a: if cursym!* eq '!*semicol!* then go to c else if not flagp!*!*(cursym!*,'type) then return varlis else if cursym!* eq 'dcl then go to dclr; w := cursym!*; if scan() eq 'procedure then return procstat1 w; varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w)); b: if not cursym!* eq '!*semicol!* then symerr(nil,t) else if null u then return list('dcl,mkquote varlis); %top level declaration; c: scan(); go to a; dclr: varlis := append(varlis,dclstat1()); go to b end; flag ('(dcl real integer scalar),'type); symbolic procedure dclstat; list('dcl,mkquote dclstat1()); symbolic procedure dclstat1; begin scalar x,y; a: x := xread nil; if not cursym!* eq '!*colon!* then symerr('dcl,t); y := append(y,pairvars(remcomma x,nil,scan())); if scan() eq '!*semicol!* then return y else if not cursym!* eq '!*comma!* then symerr('dcl,t) else go to a end; symbolic procedure dcl u; %U is a list of (id, mode) pairs, which are declared as global vars; begin scalar x; !*vars!* := append(u,!*vars!*); x := mapcar(u,function car); global x; flag(x,'share); a: if null u then return nil; set(caar u,get(cdar u,'initvalue)); u := cdr u; go to a end; put('integer,'initvalue,0); put('dcl,'stat,'dclstat); symbolic procedure decstat; %only called if a declaration occurs at the top level or not first %in a block; begin scalar x,y,z; if !*blockp then symerr('block,t); x := cursym!*; y := nxtsym!*; z := decl nil; if y neq 'procedure then rederr list(x,"invalid outside block"); return z end; put('integer,'stat,'decstat); put('real,'stat,'decstat); put('scalar,'stat,'decstat); % ***** Block Statement ***** symbolic procedure blockstat; begin scalar hold,varlis,x,!*blockp; !*blockp := t; scan(); if cursym!* memq '(nil !*rpar!*) then rederr "BEGIN invalid"; varlis := decl t; a: if cursym!* eq 'end and not nxtsym!* eq '!: then go to b; x := xread1 nil; if eqcar(x,'end) then go to c; not cursym!* eq 'end and scan(); if x then hold := aconc!*(hold,x); go to a; b: comm1 'end; c: return mkblock(varlis,hold) end; symbolic procedure mkblock(u,v); 'block . (u . v); putd('block,'macro, '(lambda (u) (cons 'prog (cons (mapcar (cadr u) (function car)) (cddr u))))); symbolic procedure formblock(u,vars,mode); 'prog . append(initprogvars cadr u, formprog1(cddr u,append(cadr u,vars),mode)); symbolic procedure initprogvars u; begin scalar x,y,z; a: if null u then return(reversip!* x . reversip!* y) else if z := get(cdar u,'initvalue) then y := mksetq(caar u,z) . y; x := caar u . x; u := cdr u; go to a end; symbolic procedure formprog(u,vars,mode); 'prog . cadr u . formprog1(cddr u,pairvars(cadr u,vars,mode),mode); symbolic procedure formprog1(u,vars,mode); if null u then nil else if atom car u then car u . formprog1(cdr u,vars,mode) else if idp caar u and flagp(caar u,'modefn) then formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode) else formc(car u,vars,mode) . formprog1(cdr u,vars,mode); put('block,'formfn,'formblock); put('prog,'formfn,'formprog); put('begin,'stat,'blockstat); % ***** Return Statement ***** symbolic procedure retstat; if not !*blockp then symerr(nil,t) else list('return, if flagp!*!*(scan(),'delim) then nil else xread1 t); put('return,'stat,'retstat); endmodule; module form; % Performs a mode analysis of parsed forms. % Author: Anthony C. Hearn. % Modifications by: Jed Marti. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*!*a2sfn !*cref !*defn !*mode current!-modulus); global '(!*argnochk !*composites !*force !*micro!-version !*vars!*); !*!*a2sfn := 'aeval; flag('(algebraic symbolic),'modefn); symbolic procedure formcond(u,vars,mode); 'cond . formcond1(cdr u,vars,mode); symbolic procedure formcond1(u,vars,mode); if null u then nil else list(formbool(caar u,vars,mode),form1(cadar u,vars,mode)) % FORMC here would add REVAL . formcond1(cdr u,vars,mode); put('cond,'formfn,'formcond); symbolic procedure formlamb(u,vars,mode); list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode)); put('lambda,'formfn,'formlamb); symbolic procedure formprogn(u,vars,mode); 'progn . formclis(cdr u,vars,mode); put('progn,'formfn,'formprogn); symbolic procedure expdrmacro u; %returns the macro form for U if expansion is permitted; begin scalar x; if null(x := getrmacro u) or flagp(u,'noexpand) then return nil else if null !*cref and (null !*defn or car x eq 'smacro) or flagp(u,'expand) or !*force then return x else return nil end; symbolic procedure getrmacro u; %returns a Reduce macro definition for U, if one exists, %in GETD format; begin scalar x; return if not idp u then nil else if (x := getd u) and car x eq 'macro then x else if (x := get(u,'smacro)) then 'smacro . x % else if (x := get(u,'nmacro)) then 'nmacro . x; else nil end; symbolic procedure applmacro(u,v,w); apply1(u,w . v); %symbolic procedure applnmacro(u,v,w); % apply(u,if flagp(w,'nospread) then list v else v); % symbolic procedure applsmacro(u,v,w); % %We could use an atom sublis here, eg SUBLA; % sublis(pair(cadr u,v),caddr u); put('macro,'macrofn,'applmacro); %put('nmacro,'macrofn,'applnmacro); put('smacro,'macrofn,'applsmacro); flag('(ed go quote),'noform); symbolic procedure set!-global!-mode u; begin !*mode := u end; symbolic procedure form1(u,vars,mode); begin scalar x,y; if atom u then return if not idp u then u else if u eq 'ed then list u else if flagp(u,'modefn) then set!-global!-mode u else if x:= get(mode,'idfn) then apply2(x,u,vars) else u else if not atom car u then if caar u eq 'lambda then return formlis(u,vars,mode) else typerr(car u,"operator") else if not idp car u then typerr(car u,"operator") else if get(car u, 'localfnname) then return form1(get(car u,'localfnname) . cdr u,vars,mode) else if flagp(car u,'noform) then return u else if arrayp car u and (mode eq 'symbolic or intexprlisp(cdr u,vars)) then return list('getel,intargfn(u,vars,mode)) else if flagp(car u,'modefn) then return convertmode(cadr u,vars,mode,car u) else if (x := get(car u,'formfn)) then return macrochk(apply(x,list(u,vars,mode)),mode) else if get(car u,'stat) eq 'rlis then return macrochk(formrlis(u,vars,mode),mode) % else if (x := getd car u) and eqcar(x, 'macro) and % not(mode eq 'algebraic) then % return << x := apply(cdr x, list(u, vars, mode)); % formc(x, vars, mode) >> ; argnochk u; x := formlis(cdr u,vars,mode); y := if x=cdr u then u else car u . x; return if mode eq 'symbolic or get(car u,'stat) or cdr u and eqcar(cadr u,'quote) and null !*micro!-version or intexprnp(y,vars) and null !*composites and null current!-modulus then macrochk(y,mode) else if not(mode eq 'algebraic) then convertmode(y,vars,mode,'algebraic) else ('list . algid(car u,vars) . x) end; symbolic procedure argnochk u; begin scalar x; if null !*argnochk then nil else if (x := argsofopr car u) and x neq length cdr u then rederr list(car u,"called with", length cdr u, if length cdr u=1 then "argument" else "arguments", "instead of",x) end; symbolic procedure argsofopr u; % This function may be optimizable in various implementations. get(u,'number!-of!-args); symbolic procedure intexprnp(u,vars); %determines if U is an integer expression; if atom u then if numberp u then fixp u else if (u := atsoc(u,vars)) then cdr u eq 'integer else nil else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars); symbolic procedure intexprlisp(u,vars); null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars); flag('(difference minus plus times),'intfn); % EXPT is not included in this list, because a negative exponent can % cause problems (i.e., result can be rational); symbolic procedure formlis(u,vars,mode); mapcar(u,function (lambda x; form1(x,vars,mode))); symbolic procedure formclis(u,vars,mode); mapcar(u,function (lambda x; formc(x,vars,mode))); symbolic procedure form u; form1(u,!*vars!*,!*mode); symbolic procedure macrochk(u,mode); begin scalar y; %expands U if CAR U is a macro and expansion allowed; if atom u then return u else if (y := expdrmacro car u) and (mode eq 'symbolic or idp car u and flagp(car u,'opfn)) then return apply(get(car y,'macrofn),list(cdr y,cdr u,car u)) else return u end; put('symbolic,'idfn,'symbid); symbolic procedure symbid(u,vars); u; % if atsoc(u,vars) or fluidp u or globalp u or u memq '(nil t) % or flagp(u,'share) then u % else <<lprim list(u,"Non-Local Identifier");% u>>; put('algebraic,'idfn,'algid); symbolic procedure algid(u,vars); if atsoc(u,vars) or flagp(u,'share) then u else mkquote u; put('integer,'idfn,'intid); symbolic procedure intid(u,vars); begin scalar x,y; return if (x := atsoc(u,vars)) then if cdr x eq 'integer then u else if y := get(cdr x,'integer) then apply2(y,u,vars) else if cdr x eq 'scalar then !*!*a2i(u,vars) else rederr list(cdr x,"not convertable to INTEGER") else !*!*a2i(mkquote u,vars) end; symbolic procedure convertmode(exprn,vars,target,source); convertmode1(form1(exprn,vars,source),vars,target,source); symbolic procedure convertmode1(exprn,vars,target,source); begin scalar x; if source eq 'real then source := 'algebraic; if target eq 'real then target := 'algebraic; if target eq source then return exprn else if idp exprn and (x := atsoc(exprn,vars)) and not(cdr x memq '(integer scalar real)) and not(cdr x eq source) then return convertmode(exprn,vars,target,cdr x) else if not (x := get(source,target)) then typerr(source,target) else return apply2(x,exprn,vars) end; put('algebraic,'symbolic,'!*!*a2s); put('symbolic,'algebraic,'!*!*s2a); symbolic procedure !*!*a2s(u,vars); % It would be nice if we could include the ATSOC(U,VARS) line, % since in many cases that would save recomputation. However, % in any sequential process, assignments or subsititution rules % can change the value of a variable, so we have to check its % value again. More comprehensive analysis could certainly % optimize this. if u = '(quote nil) then nil else if null u or constantp u and null fixp u or intexprnp(u,vars) and null !*composites and null current!-modulus or not atom u and idp car u and flagp(car u,'nochange) and not(car u eq 'getel) % or atsoc(u,vars) % means it was already evaluated then u else list(!*!*a2sfn,u); symbolic procedure !*!*s2a(u,vars); u; symbolic procedure formc(u,vars,mode); %this needs to be generalized; if mode eq 'algebraic and intexprnp(u,vars) then u else convertmode(u,vars,'symbolic,mode); symbolic procedure intargfn(u,vars,mode); % transforms array element U into expression with integer arguments. % Array name is treated as an algebraic variable; 'list . form1(car u,vars,'algebraic) . mapcar(cdr u, function (lambda x; convertmode(x,vars,'integer,mode))); put('algebraic,'integer,'!*!*a2i); symbolic procedure !*!*a2i(u,vars); if intexprnp(u,vars) then u else list('ieval,u); symbolic procedure ieval u; !*s2i reval u; flag('(ieval),'opfn); % To make it a symbolic operator. flag('(ieval),'nochange); put('symbolic,'integer,'!*!*s2i); symbolic procedure !*!*s2i(u,vars); if fixp u then u else list('!*s2i,u); symbolic procedure !*s2i u; if fixp u then u else typerr(u,"integer"); put('integer,'symbolic,'identity); symbolic procedure identity(u,vars); u; symbolic procedure formbool(u,vars,mode); if mode eq 'symbolic then form1(u,vars,mode) else if atom u then if not idp u or atsoc(u,vars) or u eq 't then u else formc!*(u,vars,mode) else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u else if idp car u and get(car u,'boolfn) then get(car u,'boolfn) . formclis(cdr u,vars,mode) else if idp car u and flagp(car u,'boolean) then car u . mapcar(cdr u,function (lambda x; if flagp(car u,'boolargs) then formbool(x,vars,mode) else formc!*(x,vars,mode))) else formc!*(u,vars,mode); symbolic procedure formc!*(u,vars,mode); begin scalar !*!*a2sfn; !*!*a2sfn := 'reval; return formc(u,vars,mode) end; % Functions with side effects must be handled carefully in this model, % otherwise they are not always evaluated within blocks. symbolic procedure formrederr(u,vars,mode); begin scalar x; x := formc!*(cadr u,vars,mode); return list('rederr,x) end; put('rederr,'formfn,'formrederr); symbolic procedure formreturn(u,vars,mode); begin scalar x; x := form1(cadr u,vars,mode); % FORMC here would add REVAL if not(mode memq '(symbolic integer real)) and eqcar(x,'setq) % Should this be more general? then x := list(!*!*a2sfn,x); return list('return,x) end; put('return,'formfn,'formreturn); symbolic procedure formsetq(u,vars,mode); begin scalar target,x,y; u := cdr u; if eqcar(cadr u,'quote) then mode := 'symbolic; if idp car u and (y := atsoc(car u,vars)) and not(cdr y eq 'scalar) then target := 'symbolic % used to be CDR Y else target := 'symbolic; % Make target always SYMBOLIC so that algebraic expressions % are evaluated before being stored. x := convertmode(cadr u,vars,target,mode); return if not atom car u then if not idp caar u then typerr(car u,"assignment") else if arrayp caar u then list('setel,intargfn(car u,vars,mode),x) else if y := get(caar u,'setqfn) then form1((y . append(cdar u,cdr u)),vars,mode) % else if y := get(caar u, 'access) % then list('m!-setf, % list(caar u, form1(cadar u, vars, mode)), % x) else list('setk,form1(car u,vars,'algebraic),x) % algebraic needed above, since SETK expects it. else if not idp car u then typerr(car u,"assignment") else if mode eq 'symbolic or y or flagp(car u,'share) or eqcar(x,'quote) then mksetq(car u,x) else list('setk,mkquote car u,x) end; put('car,'setqfn,'rplaca); put('cdr,'setqfn,'rplacd); put('setq,'formfn,'formsetq); symbolic procedure formfunc(u,vars,mode); if idp cadr u then if getrmacro cadr u then rederr list("Macro",cadr u,"Used as Function") else list('function,cadr u) else list('function,form1(cadr u,vars,mode)); put('function,'formfn,'formfunc); % RLIS is a parser function that reads a list of arguments and returns % this list as one argument. It needs to be defined in this module for % bootstrapping purposes since this definition only works with its form % function. symbolic procedure rlis; begin scalar x; x := cursym!*; return if flagp!*!*(scan(),'delim) then list(x,nil) else x . remcomma xread1 'lambda end; symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end; symbolic procedure rlistat u; begin a: if null u then return nil; put(car u,'stat,'rlis); u := cdr u; go to a end; rlistat '(flagop); symbolic procedure formrlis(u,vars,mode); if not flagp(car u,'flagop) then list(car u,'list . formlis(cdr u,vars,'algebraic)) else if not idlistp cdr u then typerr('!*comma!* . cdr u,"identifier list") else mkprog(nil,list('flag,mkquote cdr u,mkquote car u) . get(car u,'simpfg)); symbolic procedure mkarg(u,vars); % Returns the "unevaled" form of U. if null u or constantp u then u else if atom u then if atsoc(u,vars) then u else mkquote u else if car u eq 'quote then mkquote u else 'list . mapcar(u,function (lambda x; mkarg(x,vars))); endmodule; module proc; % Procedure statement. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace); global '(!*argnochk !*comp !*lose cursym!* erfg!* fname!* ftypes!*); fluid '(!*defn); !*lose := t; ftypes!* := '(expr fexpr macro); symbolic procedure putc(name,type,body); %defines a non-standard function, such as an smacro. Returns NAME; begin if !*comp and flagp(type,'compile) then compd(name,type,body) else put(name,type,body); return name end; % flag('(putc),'eval); symbolic procedure formproc(u,vars,mode); begin scalar body,name,type,varlis,x,y; u := cdr u; name := car u; if cadr u then mode := cadr u; % overwrite previous mode u := cddr u; type := car u; if flagp(name,'lose) and (!*lose or null !*defn) then return progn(lprim list(name, "not defined (LOSE flag)"), nil); varlis := cadr u; u := caddr u; x := if eqcar(u,'block) then cadr u else nil; y := pairxvars(varlis,x,vars,mode); if x then u := car u . rplaca!*(cdr u,cdr y); body:= form1(u,car y,mode); % FORMC here would add REVAL if type eq 'expr then body := list('de,name,varlis,body) else if type eq 'fexpr then body := list('df,name,varlis,body) else if type eq 'macro then body := list('dm,name,varlis,body) else if type eq 'emb then return embfn(name,varlis,body) else body := list('putc, mkquote name, mkquote type, mkquote list('lambda,varlis,body)); if not(mode eq 'symbolic) then body := list('progn, list('flag,mkquote list name,mkquote 'opfn), body); if !*argnochk and type memq '(expr smacro) then body := list('progn, list('put,mkquote name, mkquote 'number!-of!-args, length varlis), body); if !*defn and type memq '(fexpr macro smacro) then eval body; return body end; put('procedure,'formfn,'formproc); symbolic procedure pairxvars(u,v,vars,mode); %Pairs procedure variables and their modes, taking into account %the convention which allows a top level prog to change the mode %of such a variable; begin scalar x,y; a: if null u then return append(reversip!* x,vars) . v else if (y := atsoc(car u,v)) then <<v := delete(y,v); if not(cdr y eq 'scalar) then x := (car u . cdr y) . x else x := (car u . mode) . x>> else x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure procstat1 mode; begin scalar bool,u,type,x,y,z; bool := erfg!*; if fname!* then go to b else if cursym!* eq 'procedure then type := 'expr else progn(type := cursym!*,scan()); if not cursym!* eq 'procedure then go to c; x := errorset('(xread (quote proc)),nil,!*backtrace); if errorp x then go to a else if atom (x := car x) then x := list x; %no arguments; fname!* := car x; %function name; if idp fname!* %AND NOT(TYPE MEMQ FTYPES!*); then if null fname!* or (z := gettype fname!*) and not z memq '(procedure operator) then go to d else if not getd fname!* then flag(list fname!*,'fnc); %to prevent invalid use of function name in body; u := cdr x; y := u; x := car x . y; a: z := errorset('(xread t),nil,!*backtrace); if not errorp z then z := car z; if null erfg!* then z:=list('procedure,car x,mode,type,y,z); remflag(list fname!*,'fnc); fname!*:=nil; if erfg!* then progn(z := nil,if not bool then error1()); return z; b: bool := t; c: errorset('(symerr (quote procedure) t),nil,!*backtrace); go to a; d: typerr(list(z,fname!*),"procedure"); go to a end; symbolic procedure procstat; procstat1 nil; deflist ('((procedure procstat) (expr procstat) (fexpr procstat) (emb procstat) (macro procstat) (smacro procstat)), 'stat); % Next line refers to bootstrapping process. if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat); deflist('((lisp symbolic)),'newnam); endmodule; module forstat; % Definition of REDUCE FOR loops. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!* foractions!*); comment the syntax of the FOR statement is as follows: {step i3 until} {i := i1 { } i2 } { { : } } for { } <action> <expr> { { in } } { each i { } <list> } { on } In all cases, the <expr> is evaluated algebraically within the scope of the current value of i. If <action> is DO, then nothing else happens. In other cases, <action> is a binary operator that causes a result to be built up and returned by FOR. In each case, the loop is initialized to a default value. The test for the end condition is made before any action is taken. The effect of the definition here is to replace all for loops by semantically equivalent blocks. As a result, none of the mapping functions are needed in REDUCE. To declare a set of actions, one says; foractions!* := '(do collect conc product sum); remflag(foractions!*,'delim); % For bootstrapping purposes. % To associate a binary function with an action, one says: deflist('((product times) (sum plus)),'bin); % And to give these an initial value in a loop: deflist('((product 1) (sum 0)),'initval); % NB: We need to reset for and let delims if an error occurs. It's % probably best to do this in the begin1 loop. flag('(for),'nochange); symbolic procedure forstat; begin scalar !*blockp; return if scan() eq 'all then forallstat() else if cursym!* eq 'each then foreachstat() else forloop() end; put('for,'stat,'forstat); symbolic procedure forloop; begin scalar action,bool,incr,var,x; flag('(step),'delim); x := errorset('(xread1 'for),t,t); remflag('(step),'delim); if errorp x then error1() else x := car x; if not eqcar(x,'setq) or not idp(var := cadr x) then symerr('for,t); x := caddr x; if cursym!* eq 'step then <<flag('(until),'delim); incr := xread t; remflag('(until),'delim); if not cursym!* eq 'until then symerr('for,t)>> else if cursym!* eq '!*colon!* then incr := 1 else symerr('for,t); if flagp(car foractions!*,'delim) then bool := t % nested loop else flag(foractions!*,'delim); incr := list(x,incr,xread t); if null bool then remflag(foractions!*,'delim); if not((action := cursym!*) memq foractions!*) then symerr('for,t); return list('for,var,incr,action,xread t) end; symbolic procedure formfor(u,vars,mode); begin scalar action,algp,body,endval,incr,initval,var,x; %ALGP is used to determine if the loop calculation must be %done algebraically or not; var := cadr u; incr := caddr u; incr := list(formc(car incr,vars,mode), formc(cadr incr,vars,mode), formc(caddr incr,vars,mode)); if intexprnp(car incr,vars) and intexprnp(cadr incr,vars) and not atsoc(var,vars) then vars := (var . 'integer) . vars; action := cadddr u; body := formc(car cddddr u, (var . if intexprlisp(caddr u,vars) then 'integer else mode) . vars,mode); algp := algmodep car incr or algmodep cadr incr or algmodep caddr incr; initval := car incr; endval := caddr incr; incr := cadr incr; x := if algp then list('list,''difference,endval,var) else list('difference,endval,var); if incr neq 1 then x := if algp then list('list,''times,incr,x) else list('times,incr,x); % We could consider simplifying X here (via reval). x := if algp then list('aminusp!:,x) else list('minusp,x); return forformat(action,body,initval,x, list('plus2,incr),var,vars,mode) end; put('for,'formfn,'formfor); symbolic procedure algmodep u; eqcar(u,'aeval); symbolic procedure aminusp!: u; begin scalar x; u := aeval u; x := u; if fixp x then return minusp x else if not eqcar(x,'!*sq) then msgpri(nil,reval u,"invalid in FOR statement",nil,t); x := cadr x; if fixp car x and fixp cdr x then return minusp car x else if not cdr x = 1 or not (atom(x := car x) or atom car x) % Should be DOMAINP, but SMACROs not yet defined. then msgpri(nil,reval u,"invalid in FOR statement",nil,t) else return apply('!:minusp,list x) end; symbolic procedure foreachstat; begin scalar w,x,y,z; if not idp(x := scan()) or not (y := scan()) memq '(in on) then symerr("FOR EACH",t) else if flagp(car foractions!*,'delim) then w := t else flag(foractions!*,'delim); z := xread t; if null w then remflag(foractions!*,'delim); w := cursym!*; if not w memq foractions!* then symerr("FOR EACH",t); return list('foreach,x,y,z,w,xread t) end; put('foreach,'stat,'foreachstat); symbolic procedure formforeach(u,vars,mode); begin scalar action,body,lst,mod,var; var := cadr u; u := cddr u; mod := car u; u := cdr u; lst := formc(car u,vars,mode); u := cdr u; if not(mode eq 'symbolic) then lst := list('getrlist,lst); action := car u; u := cdr u; body := formc(car u,(var . mode) . vars,mode); if mod eq 'in then body := list(list('lambda,list var,body),list('car,var)) else if not(mode eq 'symbolic) then typerr(mod,'action); return forformat(action,body,lst, list('null,var),list 'cdr,var,vars,mode) end; put('foreach,'formfn,'formforeach); symbolic procedure forformat(action,body,initval, testexp,updform,var,vars,mode); begin scalar result; result := gensym(); return sublis(list('body2 . if mode eq 'symbolic or intexprnp(body,vars) then list(get(action,'bin),body,result) else list('aeval,list('list,mkquote get(action,'bin), body,result)), 'body3 . if mode eq 'symbolic then body else list('getrlist,body), 'body . body, 'initval . initval, 'nillist . if mode eq 'symbolic then nil else ''(list), 'result . result, 'initresult . get(action,'initval), 'resultlist . if mode eq 'symbolic then result else list('cons,''list,result), 'testexp . testexp, 'updfn . car updform, 'updval . cdr updform, 'var . var), if action eq 'do then '(prog (var) (setq var initval) lab (cond (testexp (return nil))) body (setq var (updfn var . updval)) (go lab)) else if action eq 'collect then '(prog (var result endptr) (setq var initval) (cond (testexp (return nillist))) (setq result (setq endptr (cons body nil))) looplabel (setq var (updfn var . updval)) (cond (testexp (return resultlist))) (rplacd endptr (cons body nil)) (setq endptr (cdr endptr)) (go looplabel)) else if action eq 'conc then '(prog (var result endptr) (setq var initval) startover (cond (testexp (return nillist))) (setq result body) (setq endptr (lastpair resultlist)) (setq var (updfn var . updval)) (cond ((atom endptr) (go startover))) looplabel (cond (testexp (return result))) (rplacd endptr body3) (setq endptr (lastpair endptr)) (setq var (updfn var . updval)) (go looplabel)) else '(prog (var result) (setq var initval) (setq result initresult) lab1 (cond (testexp (return result))) (setq result body2) (setq var (updfn var . updval)) (go lab1))) end; symbolic procedure lastpair u; % Return the last pair of the list u. if atom u or atom cdr u then u else lastpair cdr u; put('join,'newnam,'conc); % alternative for CONC endmodule; module loops; % Looping forms other than the FOR statement. % Author: Anthony C. Hearn % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!*); % ***** REPEAT STATEMENT ***** symbolic procedure repeatstat; begin scalar body,!*blockp; flag('(until),'delim); body:= xread t; remflag('(until),'delim); if not cursym!* eq 'until then symerr('repeat,t); return list('repeat,body,xread t); end; symbolic macro procedure repeat u; begin scalar body,bool,lab; body := cadr u; bool := caddr u; lab := gensym(); return mkprog(nil,list(lab,body, list('cond,list(list('not,bool),list('go,lab))))) end; put('repeat,'stat,'repeatstat); flag('(repeat),'nochange); symbolic procedure formrepeat(u,vars,mode); list('repeat,formc(cadr u,vars,mode),formbool(caddr u,vars,mode)); put('repeat,'formfn,'formrepeat); % ***** WHILE STATEMENT ***** symbolic procedure whilstat; begin scalar bool,!*blockp; flag('(do),'delim); bool := xread t; remflag('(do),'delim); if not cursym!* eq 'do then symerr('while,t); return list('while,bool,xread t) end; symbolic macro procedure while u; begin scalar body,bool,lab; bool := cadr u; body := caddr u; lab := gensym(); return mkprog(nil,list(lab,list('cond,list(list('not,bool), list('return,nil))),body,list('go,lab))) end; put('while,'stat,'whilstat); flag('(while),'nochange); symbolic procedure formwhile(u,vars,mode); list('while,formbool(cadr u,vars,mode),formc(caddr u,vars,mode)); put('while,'formfn,'formwhile); endmodule; module write; % Miscellaneous statement definitions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. % ***** DEFINE STATEMENT ***** remprop('define,'stat); symbolic procedure define u; for each x in u do if not eqcar(x,'equal) or not idp cadr x then typerr(x,"DEFINE declaration") else put(cadr x,'newnam,caddr x); put('define,'stat,'rlis); flag('(define),'eval); % ***** WRITE STATEMENT ***** symbolic procedure formwrite(u,vars,mode); begin scalar bool1,bool2,x,z; u := cdr u; bool1 := mode eq 'symbolic; while u do <<x := formc(car u,vars,mode); z := (if bool1 then list('prin2,x) else list('writepri,mkarg1(x,vars), if not cdr u then if not bool2 then ''only else ''last else if not bool2 then ''first else nil)) . z; bool2 := t; u := cdr u>>; return mkprog(nil,reversip!* z) end; symbolic procedure writepri(u,v); begin scalar x; x := assgneval u; return varpri(car x,cdr x,v) end; symbolic procedure mkarg1(u,vars); % Returns the "unevaled" form of U for the WRITE command. if null u or constantp u then u else if atom u then if atsoc(u,vars) then list('mkquote,u) else mkquote u else if car u eq 'quote then mkquote u else if car u eq 'setq then list('list,''setq,mkquote cadr u,mkarg1(caddr u,vars)) else 'list . mapcar(u,function (lambda x; mkarg1(x,vars))); put('write,'stat,'rlis); put('write,'formfn,'formwrite); endmodule; module smacro; % Support for SMACRO expansion. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure applsmacro(u,vals,name); % U is smacro body of form (lambda <varlist> <body>), VALS is % argument list, NAME is name of smacro. begin scalar body,remvars,varlist,w; varlist := cadr u; body := caddr u; if length varlist neq length vals then rederr list("Argument mismatch for SMACRO",name); if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body) then return subla!-q(pair(varlist,vals),body) else if length varlist>1 then <<w := for each x in varlist collect (x . gensym()); body := subla!-q(w,body); varlist := for each x in w collect cdr x>>; for each x in vals do <<if no!-side!-effectp x or one!-entryp(car varlist,body) then body := subla!-q(list(car varlist . x),body) else remvars := aconc(remvars,car varlist . x); varlist := cdr varlist>>; if null remvars then return body else <<w := list('lambda, for each x in remvars collect car x, body) . for each x in remvars collect cdr x; % IF NOT EQCAR(CADR W,'SETQ) % THEN <<PRIN2 "*** SMACRO: "; PRINT CDR W>>; return w>> end; symbolic procedure no!-side!-effectp u; if atom u then numberp u or idp u and not(fluidp u or globalp u) else if car u eq 'quote then t else if flagp!*!*(car u,'nosideeffects) then no!-side!-effect!-listp u else nil; symbolic procedure no!-side!-effect!-listp u; null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u; flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons),'nosideeffects); symbolic procedure one!-entryp(u,v); % determines if id U occurs less than twice in V. if atom v then t else if smemq(u,car v) then if smemq(u,cdr v) then nil else one!-entryp(u,car v) else one!-entryp(u,cdr v); symbolic procedure one!-entry!-listp(u,v); null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v); symbolic procedure subla!-q(u,v); begin scalar x; if null u or null v then return v else if atom v then return if x:= atsoc(v,u) then cdr x else v else if car v eq 'quote then return v else return(subla!-q(u,car v) . subla!-q(u,cdr v)) end; endmodule; module infix; % Functions for introducing new infix operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(preclis!*); symbolic procedure infix x; begin scalar y; a: if null x then go to b; y := car x; if !*mode eq 'algebraic then mkop y; if not(y member preclis!*) then preclis!* := y . preclis!*; x := cdr x; go to a; b: mkprec() end; symbolic procedure precedence u; begin scalar x,y,z; preclis!* := delete(car u,preclis!*); y := cadr u; x := preclis!*; a: if null x then rederr list (y,"not found") else if y eq car x then <<preclis!* := nconc!*(reversip!* z,car x . (car u . cdr x)); mkprec(); return nil>>; z := car x . z; x := cdr x; go to a end; deflist('((infix rlis) (precedence rlis)),'stat); flag('(infix precedence),'eval); endmodule; module where; % Support for a where construct. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure formwhere(u,vars,mode); begin scalar expn,equivs,y,z; expn := cadr u; equivs := caddr u; if eqcar(equivs,'!*comma!*) then equivs := cdr equivs else equivs := list equivs; for each x in equivs do if not atom x and car x memq '(equal setq) then <<y := caddr x . y; z := cadr x . z>> else rederr list(x,"invalid in WHERE statement"); return formc(list('lambda,reversip z,expn) . reversip y, vars,mode) end; put('where,'formfn,'formwhere); % infix where; % We do this explicitly to avoid changing preclis*. deflist('((where 1)),'infix); put('where,'op,'((1 1))); endmodule; module list; % Define a list as a list of expressions in curly brackets. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(cursym!* orig!* posn!*); % Add to system table. put('list,'tag,'list); put('list,'rtypefn,'(lambda (x) 'list)); % Parsing interface. symbolic procedure xreadlist; % expects a list of expressions enclosed by {, }. % also allows expressions separated by ; --- treats these as progn. begin scalar cursym,delim,lst; if scan() eq '!*rcbkt!* then <<scan(); return list 'list>>; a: lst := aconc(lst,xread1 'group); cursym := cursym!*; scan(); if cursym eq '!*rcbkt!* then return if delim eq '!*semicol!* then 'progn . lst else 'list . lst else if null delim then delim := cursym else if not(delim eq cursym) then symerr("syntax error: mixed , and ; in list",nil); go to a end; put('!*lcbkt!*,'stat,'xreadlist); newtok '((!{) !*lcbkt!*); newtok '((!}) !*rcbkt!*); flag('(!*rcbkt!*),'delim); flag('(!*rcbkt!*),'nodel); % Evaluation interface. put('list,'evfn,'listeval); symbolic procedure getrlist u; if eqcar(u,'list) then cdr u else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list"); symbolic procedure listeval(u,v); if atom u then listeval(get(u,'rvalue),v) else car u . for each j in cdr u collect reval1(j,v); % Length interface. put('list,'lengthfn,'(lambda (x) (length (cdr x)))); % Printing interface. put('list,'prifn,'listpri); symbolic procedure listpri l; % This definition is basically that of INPRINT, except that it % decides when to split at the comma by looking at the size of % the argument. begin scalar orig,split,u; u := l; l := cdr l; prin2!* get('!*lcbkt!*,'prtch); % Do it this way so table can change. orig := orig!*; orig!* := if posn!*<18 then posn!* else orig!*+3; if null l then go to b; split := treesizep(l,40); % 40 is arbitrary choice. a: maprint(negnumberchk car l,0); l := cdr l; if null l then go to b; oprin '!*comma!*; if split then terpri!* t; go to a; b: prin2!* get('!*rcbkt!*,'prtch); % terpri!* nil; orig!* := orig; return u end; symbolic procedure treesizep(u,n); % true if u has recursively more pairs than n. treesizep1(u,n)=0; symbolic procedure treesizep1(u,n); if atom u then n-1 else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n) else 0; % Definitions of operations on lists symbolic procedure rfirst u; <<argnochk ('first . u); if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list") else if null cdr u then parterr(u,1) else cadr u>>; put('first,'psopfn,'rfirst); symbolic procedure parterr(u,v); msgpri("Expression",u,"does not have part",v,t); symbolic procedure rsecond u; <<argnochk ('second . u); if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list") else if null cdr u or null cddr u then parterr(u,2) else caddr u>>; put('second,'psopfn,'rsecond); symbolic procedure rthird u; <<argnochk ('third . u); if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list") else if null cdr u or null cddr u or null cdddr u then parterr(u,3) else cadddr u>>; put('third,'psopfn,'rthird); symbolic procedure rrest u; <<argnochk ('rest . u); if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list") else if null cdr u then typerr(u,"non-empty list") else 'list . cddr u>>; put('rest,'psopfn,'rrest); symbolic procedure rappend u; begin scalar x,y; argnochk ('append . u); if null(getrtype(x := reval car u) eq 'list) then typerr(x,"list") else if null(getrtype(y := reval cadr u) eq 'list) then typerr(y,"list") else return 'list .append(cdr x,cdr y) end; put('append,'psopfn,'rappend); symbolic procedure rcons u; begin scalar x,y; argnochk ('cons . u); if (y := getrtype(x := reval cadr u)) eq 'vector then return prepsq simpdot u else if not(y eq 'list) then typerr(x,"list") else return 'list . reval car u . cdr x end; put('cons,'psopfn,'rcons); symbolic procedure rreverse u; <<argnochk ('reverse . u); if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list") else 'list . reverse cdr u>>; put('reverse,'psopfn,'rreverse); endmodule; module array; % Array statement. % Author: Anthony C. Hearn. % Modifications by: Nancy Kirkwood. % These definitions are very careful about bounds checking. Appropriate % optimizations in a given system might really speed things up. global '(erfg!*); symbolic procedure getel u; % Returns the value of the array element U. getel1(get(car u,'rvalue),cdr u,get(car u,'dimension)); symbolic procedure getel1(u,v,dims); if length v neq length dims then rederr "Incorrect array reference" else if null v then u else if car v geq car dims then rederr "Array out of bounds" else getel1(getv(u,car v),cdr v,cdr dims); symbolic procedure setel(u,v); % Sets array element U to V and returns V. setel1(get(car u,'rvalue),cdr u,v,get(car u,'dimension)); symbolic procedure setel1(u,v,w,dims); if length v neq length dims then rederr "Incorrect array reference" else if car v geq car dims then rederr "Array out of bounds" else if null cdr v then putv(u,car v,w) else setel1(getv(u,car v),cdr v,w,cdr dims); symbolic procedure dimension u; get(u,'dimension); comment further support for REDUCE arrays; symbolic procedure typechk(u,v); begin scalar x; if (x := gettype u) eq v or x eq 'parameter then lprim list(v,u,"REDEFINED") else if x then typerr(list(x,u),v) end; symbolic procedure arrayfn(u,v); % U is the defining mode, V a list of lists, assumed syntactically % correct. ARRAYFN declares each element as an array unless a % semantic mismatch occurs. begin scalar y; for each x in v do <<typechk(car x,'array); y := add1lis for each z in cdr x collect eval z; if null erfg!* then <<put(car x,'rtype,'array); put(car x,'rvalue,mkarray(y,u)); put(car x,'dimension,y)>>>> end; symbolic procedure add1lis u; if null u then nil else (car u+1) . add1lis cdr u; symbolic procedure mkarray(u,v); %U is a list of positive integers representing array bounds, V %the defining mode. Value is an array structure; if null u then if v eq 'symbolic then nil else 0 else begin integer n; scalar x; n := car u-1; x := mkvect n; for i:=0:n do putv(x,i,mkarray(cdr u,v)); return x end; rlistat '(array); flag ('(array arrayfn),'eval); symbolic procedure formarray(u,vars,mode); begin scalar x; x := cdr u; while x do <<if atom x then typerr(x,"Array List") else if atom car x or not idp caar x or not listp cdar x then typerr(car x,"Array declaration"); x := cdr x>>; u := for each z in cdr u collect intargfn(z,vars,mode); %ARRAY arguments must be returned as quoted structures; return list('arrayfn,mkquote mode,'list . u) end; symbolic procedure listp u; % Returns T if U is a top level list. null u or not atom u and listp cdr u; put('array,'formfn,'formarray); put('array,'rtypefn,'arraychk); symbolic procedure arraychk u; % If arraychk receives NIL, it means that array name is being used % as an identifier. We no longer permit this. if null u then 'array else nil; % nil; put('array,'evfn,'arrayeval); symbolic procedure arrayeval(u,v); % Eventually we'll support this. rederr "Array arithmetic not defined"; put('array,'lengthfn,'arraylength); symbolic procedure arraylength u; 'list . get(u,'dimension); endmodule; module switch; % Support for switches and ON and OFF statements. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*switchcheck switchlist!*); % No references to RPLAC-based functions in this module. symbolic procedure on u; onoff(u,t); symbolic procedure off u; onoff(u,nil); symbolic procedure onoff(u,bool); for each j in u do begin scalar x,y; if not idp j then typerr(j,"switch") else if not flagp(j,'switch) then if !*switchcheck then rederr list(j,"not defined as switch") else lpriw("*****",list(j,"not defined as switch")); x := intern compress append(explode '!*,explode j); if !*switchcheck and eval x eq bool then return nil else if y := atsoc(bool,get(j,'simpfg)) then eval mkprog(nil,cdr y); set(x,bool) end; symbolic procedure switch u; % Declare list u as switches. for each x in u do begin scalar y; if not idp x then typerr(x,"switch"); if not u memq switchlist!* then switchlist!* := x . switchlist!*; flag(list x,'switch); y := intern compress append(explode '!*,explode x); if not fluidp y and not globalp y then fluid list y end; deflist('((switch rlis)),'stat); % we use deflist since it's flagged % eval rlistat '(off on); flag ('(off on),'ignore); % Symbolic mode switches: switch backtrace,comp,defn,demo,echo,errcont,int,msg,output,pret, quotenewnam,raise,time; % switchcheck. % The following are compiler switches that may not be supported in all % versions: switch pgwd,plap,pwrds; % flag('(switch),'eval); endmodule; module io; % Reduce functions for handling input and output of files. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*int semic!*); global '(!*echo contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!* techo!*); symbolic procedure file!-transform(u,v); % Performs a transformation on the file u. V is name of function % used for the transformation; begin scalar echo,ichan,oldichan,val; echo := !*echo; !*echo := nil; ichan := open(u,'input); oldichan := rds ichan; val := errorset(list v,t,!*backtrace); !*echo := echo; close ichan; rds oldichan; if not errorp val then return car val end; symbolic procedure infile u; % loads the single file u into REDUCE without echoing; begin scalar !*int; return file!-transform(u,function begin1) end; symbolic procedure in u; begin scalar chan,echo,echop,type; echop := semic!* eq '!;; %record echo character from input; echo := !*echo; %save current echo status; if null ifl!* then techo!* := !*echo; %terminal echo status; for each fl in u do <<if fl eq 't then fl := nil; if null fl then <<!*echo := techo!*; rds nil; ifl!* := nil>> else <<chan := open(fl := mkfil fl,'input); rds chan; % if assoc(fl,linelist!*) then nil; curline!* := 1; ifl!* := list(fl,chan,1)>>; ipl!* := ifl!* . ipl!*; %add to input file stack; !*echo := echop; type := filetype fl; if type and (type := get(type,'action)) then eval list type else begin1(); if chan then close chan; if fl eq caar ipl!* then ipl!* := cdr ipl!* else errach list("FILE STACK CONFUSION",fl,ipl!*)>>; !*echo := echo; %restore echo status; if ipl!* and null contl!* then ifl!* := car ipl!* else ifl!* := nil; if ifl!* then <<rds cadr ifl!*; curline!* := caddr ifl!*>> else rds nil end; symbolic procedure out u; %U is a list of one file; begin integer n; scalar chan,fl,x; n := linelength nil; if null u then return nil else if car u eq 't then return <<wrs(ofl!* := nil); nil>>; fl := mkfil car u; if not (x := assoc(fl,opl!*)) then <<chan := open(fl,'output); if chan then <<ofl!*:= fl . chan; opl!*:= ofl!* . opl!*>>>> else ofl!* := x; wrs cdr ofl!*; linelength n end; symbolic procedure shut u; %U is a list of names of files to be shut; begin scalar fl1; for each fl in u do <<if fl1 := assoc((fl := mkfil fl),opl!*) then <<opl!* := delete(fl1,opl!*); if fl1=ofl!* then <<ofl!* := nil; wrs nil>>; close cdr fl1>> else if not (fl1 := assoc(fl,ipl!*)) then rederr list(fl,"not open") else if fl1 neq ifl!* then <<close cadr fl1; ipl!* := delete(fl1,ipl!*)>> else rederr list("Cannot shut current input file",car fl1)>> end; deflist ('((in rlis) (out rlis) (shut rlis)),'stat); flag ('(in out shut),'eval); flag ('(in out shut),'ignore); endmodule; module inter; % Functions for interactive support. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*int); global '(!$eof!$ !*echo !*lessspace cloc!* contl!* curline!* edit!* eof!* erfg!* flg!* ifl!* ipl!* key!* ofl!* opl!* techo!*); symbolic procedure pause; %Must appear at the top-most level; if null !*int then nil else if key!* eq 'pause then pause1 nil else %typerr('pause,"lower level command"); pause1 nil; %Allow at lower level for now; symbolic procedure pause1 bool; begin if bool then if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?" then return <<contl!* := nil; if ofl!* then <<lprim list(car ofl!*,'shut); close cdr ofl!*; opl!* := delete(ofl!*,opl!*); ofl!* := nil>>; edit1(cloc!*,nil)>> else if flg!* then return (edit!* := nil); if null ifl!* or yesp "Cont?" then return nil; ifl!* := list(car ifl!*,cadr ifl!*,curline!*); contl!* := ifl!* . !*echo . contl!*; rds (ifl!* := nil); !*echo := techo!* end; symbolic procedure yesp u; begin scalar bool,ifl,ofl,x,y,z; if ifl!* then <<ifl := ifl!* := list(car ifl!*,cadr ifl!*,curline!*); rds nil>>; if ofl!* then <<ofl:= ofl!*; wrs nil>>; if null !*lessspace then terpri(); if atom u then prin2 u else lpri u; prin2t " (Y or N)"; if null !*lessspace then terpri(); z := setpchar '!?; a: x := read(); % Assume an end-of-file is the same as "yes". if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b; if null bool then prin2t "TYPE Y OR N"; bool := t; go to a; b: setpchar z; if ofl then wrs cdr ofl; if ifl then rds cadr ifl; cursym!* := '!*semicol!*; return y end; symbolic procedure cont; begin scalar fl,techo; if ifl!* then return nil %CONT only active from terminal; else if null contl!* then rederr "No file open"; fl := car contl!*; techo := cadr contl!*; contl!* := cddr contl!*; if car fl=caar ipl!* and cadr fl=cadar ipl!* then <<ifl!* := fl; if fl then <<rds cadr fl; curline!* := caddr fl>> else rds nil; !*echo := techo>> else <<eof!* := 1; lprim list(fl,"not open"); error1()>> end; deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat); flag ('(cont),'ignore); endmodule; end; |
Added r33/rsltnt.red version [36bcb268c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module resultant; % Author: Eberhard Schruefer. %********************************************************************** % * % The resultant function defined here has the following properties: * % * % degr(p1,x)*degr(p2,x) * % resultant(p1,p2,x) = (-1) *resultant(p2,p1,x) * % * % degr(p2,x) * % resultant(p1,p2,x) = p1 if p1 free of x * % * % resultant(p1,p2,x) = 1 if p1 free of x and p2 free of x * % * %********************************************************************** %exports resultant; %imports reorder,setkorder,degr,addf,negf,multf,multpf; fluid '(!*exp kord!*); symbolic procedure resultant(u,v,w); %u and v are standard forms. Result is resultant of u and v %w.r.t. kernel w. Method is Bezout's determinant using exterior %multiplication for its calculation. begin scalar ap,ep,uh,ut,vh,vt; integer n,nm; if domainp u and domainp v then return 1; kord!* := w . kord!*; if null domainp u and null(mvar u eq w) then u := reorder u; if null domainp v and null(mvar v eq w) then v := reorder v; if domainp u or null(mvar u eq w) then <<setkorder cdr kord!*; return if not domainp v and mvar v eq w then exptf(u,ldeg v) else 1>> else if domainp v or null(mvar v eq w) then <<setkorder cdr kord!*; return if mvar u eq w then exptf(v,ldeg u) else 1>>; n := ldeg u - ldeg v; ep := 1; if n<0 then <<for j := (-n-1) step -1 until 1 do ep := b!:extmult(!*sf2exb(multpf(w to j,u),w),ep); ep := b!:extmult(!*sf2exb(multd((-1)**(-n*ldeg u),u), w), ep)>> else if n>0 then <<for j := (n-1) step -1 until 1 do ep := b!:extmult(!*sf2exb(multpf(w to j,v),w),ep); ep := b!:extmult(!*sf2exb(v,w),ep)>>; nm := max(ldeg u,ldeg v); uh := lc u; vh := lc v; ut := if n<0 then multpf(w to -n,red u) else red u; vt := if n>0 then multpf(w to n,red v) else red v; ap := addf(multf(uh,vt),negf multf(vh,ut)); ep := if null ep then !*sf2exb(ap,w) else b!:extmult(!*sf2exb(ap,w),ep); for j := (nm - 1) step -1 until (abs n + 1) do <<if degr(ut,w) = j then <<uh := addf(lc ut,multf(!*k2f w,uh)); ut := red ut>> else uh := multf(!*k2f w,uh); if degr(vt,w) = j then <<vh := addf(lc vt,multf(!*k2f w,vh)); vt := red vt>> else vh := multf(!*k2f w,vh); ep := b!:extmult(!*sf2exb(addf(multf(uh,vt), negf multf(vh,ut)),w),ep)>>; setkorder cdr kord!*; return if null ep then nil else lc ep end; put('resultant,'simpfn,'simpresultant); symbolic procedure simpresultant u; begin scalar !*exp; if length u neq 3 then rederr "RESULTANT called with wrong number of arguments"; !*exp := t; return resultant(!*q2f simp!* car u, !*q2f simp!* cadr u, !*a2k caddr u) ./ 1 end; symbolic procedure !*sf2exb(u,v); %distributes s.f. u with respect to powers in v. if degr(u,v)=0 then if null u then nil else list 0 .* u .+ nil else list ldeg u .* lc u .+ !*sf2exb(red u,v); %**** Support for exterior multiplication **** % Data structure is lpow ::= list of degrees in exterior product % lc ::= standard form symbolic procedure b!:extmult(u,v); %Special exterior multiplication routine. Degree of form v is %arbitrary, u is a one-form. if null u or null v then nil else if v = 1 then u else (if x then cdr x .* (if car x then negf multf(lc u,lc v) else multf(lc u,lc v)) .+ b!:extadd(b!:extmult(!*t2f lt u,red v), b!:extmult(red u,v)) else b!:extadd(b!:extmult(red u,v), b!:extmult(!*t2f lt u,red v))) where x = b!:ordexn(car lpow u,lpow v); symbolic procedure b!:extadd(u,v); if null u then v else if null v then u else if lpow u = lpow v then (lambda x,y; if null x then y else lpow u .* x .+ y) (addf(lc u,lc v),b!:extadd(red u,red v)) else if b!:ordexp(lpow u,lpow v) then lt u .+ b!:extadd(red u,v) else lt v .+ b!:extadd(u,red v); symbolic procedure b!:ordexp(u,v); if null u then t else if car u > car v then t else if car u = car v then b!:ordexp(cdr u,cdr v) else nil; symbolic procedure b!:ordexn(u,v); %u is a single integer, v a list. Returns nil if u is a member %of v or a dotted pair of a permutation indicator and the ordered %list of u merged into v. begin scalar s,x; a: if null v then return(s . reverse(u . x)) else if u = car v then return nil else if u and u > car v then return(s . append(reverse(u . x),v)) else <<x := car v . x; v := cdr v; s := not s>>; go to a end; endmodule; end; |
Added r33/solve.red version [fa45947530].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module solve; % Solve one or more algebraic equations. % Author: David R. Stoutemyer. % Modifications by: Anthony C. Hearn and Donald R. Morrison. fluid '(!*exp asymplis!*); global '(!!arbint !!gcd !*allbranch !*micro!-version !*nonlnr !*ppsoln !*solveinterval !*solvesingular multiplicities!*); switch allbranch,solvesingular; % solveinterval. flag('(multiplicities!*),'share); % ***** Global Declarations ***** array !!cf(12), !!interval(10,2), !!exact(10); !*allbranch := t; % Returns all branches of solutions if T; %!*solveinterval = nil;% Attempts to isolate insoluble, real roots if T; !*solvesingular := t; % Default value. % !!gcd SOLVECOEFF returns GCD of powers of its arg in this % !!cf : Array of coeffs from SOLVECOEFF algebraic operator arbint, arbreal, intervl, list; % algebraic operator arbcomplex; % Done this way since it's also defined in the glmat module. deflist('((arbcomplex simpiden)),'simpfn); % ***** Utility Functions ***** symbolic procedure freeofl(u,v); null v or freeof(u,car v) and freeofl(u,cdr v); symbolic procedure ratnump x; % Returns T iff any prefix expression x is a rational number. atom numr(x := simp!* x) and atom denr x; flag ('(ratnump), 'direct); symbolic procedure allkern elst; % Returns list of all top-level kernels in the list of standard % forms elst. if null elst then nil else union(kernels car numr elst, allkern cdr elst); symbolic procedure topkern(u,x); % Returns list of top level kernels in the standard form u that % contain the kernel x; for each j in kernels u conc if not freeof(j,x) then list j else nil; symbolic procedure coeflis ex; % Ex is a standard form. Returns a list of the coefficients of the % main variable in ex in the form ((expon . coeff) (expon . coeff) % ... ), where the expon's occur in increasing order, and entries do % not occur of zero coefficients. begin scalar ans,var; if domainp(ex) then return (0 . ex); var := mvar(ex); while (not domainp(ex)) and mvar(ex)=var do <<ans := (ldeg(ex) . lc(ex)) . ans; ex := red(ex) >>; if ex then ans := (0 . ex) . ans; return ans end; % ***** Evaluation Interface ***** symbolic procedure solveeval u; begin scalar arglist; integer nargs; arglist := u; nargs := length(arglist); u := if nargs=1 then solve0(car arglist,nil) else if nargs=2 then solve0(car arglist, cadr arglist) else solve0(car arglist,'list . cdr arglist); return !*solvelist2solveeqlist u end; put('solve,'psopfn,'solveeval); symbolic procedure !*solvelist2solveeqlist u; begin scalar x,y,z; for each j in u do <<if caddr j=0 then rederr "zero multiplicity" else if null cadr j then x := for each k in car j collect list('equal,mk!*sq k,0) else x := for each k in pair(cadr j,car j) collect list('equal,car k,mk!*sq cdr k); if length x > 1 then z := ('list . x) . z else z := car x . z; y := caddr j . y>>; multiplicities!* := 'list . y; return 'list . z end; % ***** Fundamental SOLVE Procedures ***** comment these procedures return the solution of a list of equations as a list of elements with three fields: the solutions, the variables (or NIL if the equations could not be solved) and the multiplicity; symbolic procedure solve0(elst, xlst); % elst is any prefix expression, including the kernel named LST with % any number of arguments. XLST is a kernel, perhaps named LIST with % any number of arguments. Solves eqns in ELST for vars in XLST, % returning either a list of solutions, or a single solution; begin scalar !*exp,vars; integer neqn; !*exp := t; elst := for each j in solveargchk elst collect simp!* if eqexpr j then !*eqn2a j else j; neqn := length elst; if neqn = 0 then rederr "SOLVE called with no equations"; if null xlst then <<vars := allkern elst; terpri(); if null vars then nil else if cdr vars then <<prin2!* "Unknowns: "; maprin('list . vars)>> else <<prin2!* "Unknown: "; maprin car vars>>; terpri!* nil>> else <<xlst := solveargchk xlst; vars := for each j in xlst collect !*a2k j>>; if length vars = 0 then rederr "SOLVE called with no variables" else if neqn = 1 then if null numr car elst then return if !*solvesingular then list list(list (makearbcomplex() ./ 1), vars,1) else nil else if length vars=1 then return solvesq(car elst,car vars,1); % more than one equation or variable. elst := solvesys(for each j in elst collect numr j,vars); return if null elst then nil else if null cdr elst then list list(car elst,vars,1) else if null !*nonlnr then rederr "Unbalanced SOLVE equations" else elst end; symbolic procedure solveargchk u; if getrtype u eq 'list then cdr reval u else if atom u or not(car u eq 'lst) then list u else cdr u; % ***** Procedures for solving a single eqn ***** symbolic procedure solvesq (ex,var,mul); % Attempts to find solutions for standard quotient ex with respect to % top level occurrences of var and kernels containing variable var. % Solutions containing more than one such kernel are returned % unsolved, and solve1 is applied to the other solutions. Integer % mul is the multiplicity passed from any previous factorizations. % Returns a list of triplets consisting of solutions, variables and % multiplicity. begin scalar e1,x1,y,z; integer mu; ex := numr ex; if null topkern(ex,var) then return nil; ex := fctrf ex; % now process monomial. if domainp car ex then ex := cdr ex else ex := (car ex . 1) . cdr ex; for each j in ex do <<e1 := car j; x1 := topkern(e1,var); mu := mul*cdr j; if x1 then z := append( if null cdr x1 then solve1(e1,car x1,var,mu) else if (y := principal!-of!-powers!-soln(e1,x1,var,mu)) neq 'unsolved then y else if not smemq('sol, (x1:=simp!* list('sol,mk!*sq(e1 ./ 1), var))) then solvesq(x1,var,mu) else list list(list(e1 ./ 1),nil,mu), z)>>; return z end; symbolic procedure principal!-of!-powers!-soln(ex,x1,var,mu); % Finds solutions of ex=0 by the principal of powers method, or % NIL if no such solutions exist. begin scalar z; if null !*ppsoln then return 'unsolved; a: if null x1 then return 'unsolved else if suitable!-expt car x1 and not((z := pr!-pow!-soln1(ex,car x1,var,mu)) eq 'unsolved) then return z; x1 := cdr x1; go to a end; symbolic procedure pr!-pow!-soln1(ex,y,var,mu); begin scalar oldkord,z; oldkord := setkorder list y; z := reorder ex; setkorder oldkord; if ldeg z neq 1 then return 'unsolved; z := coeflis z; if length z neq 2 or caar z neq 0 then errach list("solve confused",ex,z); z := exptsq(quotsq(negsq(cdar z ./ 1),cdadr z ./ 1), caddr caddr y); z := solvesq(subs2 addsq(simp!* cadr y,negsq z),var,mu); z := check!-solutions(z,ex); return z end; symbolic procedure check!-solutions(z,ex); begin scalar x,y; while z do if null cadar z then <<z := nil; x := 'unsolved>> else if null (y := numr subf(ex,list(caadar z . mk!*sq caaar z))) or null numvalue y then <<x := car z . x; z := cdr z>> else z := cdr z; return x end; symbolic procedure numvalue u; % Find floating point value of sf u. begin scalar !*numval,x; !*numval := t; x := setdmode('float,t); u := numr simp prepf u; if x then setdmode(x,t) else setdmode('float,nil); return if eqcar(u,'!:ft!:) and 1000000*abs cdr u < 1 then nil else u end; symbolic procedure suitable!-expt u; eqcar(u,'expt) and eqcar(caddr u,'quotient) and cadr caddr u = 1 and fixp caddr caddr u; symbolic procedure solve1(e1,x1,var,mu); comment e1 is a standard form, non-trivial in the kernel x1, which is itself a function of var, mu is an integer. Uses roots of unity, known solutions, inverses, together with quadratic, cubic and quartic formulas, treating other cases as unsolvable. Returns nil; begin scalar b,c,coeffs,hipow; integer n; hipow := errorset(solvecoeff(e1, x1),nil,nil); if atom hipow then return list list(list(e1 . 1),nil,mu); % solvecoeff problem - no soln. hipow := car hipow; n:= !!gcd; % numerical gcd of powers. for i := 0:hipow do coeffs := nilchk getelv list('!!cf,i) . coeffs; if hipow = 1 then return begin scalar lincoeff,y,z; b:=prepsq quotsq(negsq cadr coeffs,car coeffs); if n neq 1 then b := list('expt,b,list('quotient,1,n)); % We may need to merge more solutions in the following if % there are repeated roots. for k := 0:n-1 do % equation in power of var. <<lincoeff := simp!* list('times,b, mkexp list('quotient,list('times,k,2,'pi),n)); if x1=var then y := solnmerge(list lincoeff,list var,mu,y) else if not idp (z := car x1) then typerr(z,"solve operator") else if z := get(z,'solvefn) then y := append(apply1(z,list(cdr x1,var,mu,lincoeff)) ,y) else if (z := get(car x1,'inverse)) % known inverse then y := append(solvesq(subtrsq(simp!* cadr x1, simp!* list(z,mk!*sq lincoeff)), var,mu),y) else y := list(list subtrsq(simp!* x1,lincoeff),nil,mu) . y>>; return y end else if hipow=2 then return <<x1 := exptsq(simp!* x1,n); % allows for power variable for each j in apply('solvequadratic,coeffs) conc solvesq(subtrsq(x1,j),var,mu)>> else return begin scalar d,f,rcoeffs; % At this point, we cannot write down the solution directly, so % we look for various forms that we know how to solve. f:=(hipow+1)/2; d:=exptsq(simp!* x1,n); rcoeffs := reverse coeffs; return if solve1test1(coeffs,rcoeffs,f) % coefficients symmetric then if f+f=hipow+1 % odd then <<c:=addsq(d, 1 ./ 1); append(solvesq(c,var,mu), solvesq(quotsq(e1 ./ 1, c),var,mu))>> else <<setelv(list('!!cf,0),2 ./ 1); setelv(list('!!cf, 1), simp!* '!!x); c:=addsq(multsq(getelv(list('!!cf,f+1)), getelv(list('!!cf,1))), getelv(list('!!cf,f))); for j:=2:f do << setelv(list('!!cf, j), subtrsq(multsq(getelv(list('!!cf,1)), getelv(list('!!cf,j-1))), getelv(list('!!cf,j-2)))); c:=addsq(c,multsq(getelv(list('!!cf,j)), getelv(list('!!cf,f+j))))>>; for each j in solvesq(c,'!!x,mu) conc solvesq(addsq(1 ./ 1,multsq(d,subtrsq(d,caar j))), var,caddr j)>> else if solve1test2(coeffs,rcoeffs,f) % coefficients antisymmetric then <<c:=addsq(d,(-1 ./1)); b := solvesq(c,var,mu); e1 := quotsq(e1 ./ 1, c); if f+f = hipow then <<c := addsq(d,(1 ./ 1)); b := append(solvesq(c,var,mu),b); e1 := quotsq(e1,c)>>; append(solvesq(e1,var,mu),b)>> % equation has no symmetry else if hipow=3 and null !*micro!-version then for each j in apply('solvecubic,coeffs) conc solvesq(subtrsq(d,j),var,mu) else if hipow=4 and null !*micro!-version then for each j in apply('solvequartic,coeffs) conc solvesq(subtrsq(d,j),var,mu) else if !*solveinterval and univariatep e1 then solveinterval(e1,var,mu) else list list(list(e1 ./ 1),nil,mu) % We can't solve quintic and higher end end; symbolic procedure solnmerge(u,varlist,mu,y); % Merge solutions in case of multiplicities. It may be that this is % only needed for the trivial solution x=0. if null y then list list(u,varlist,mu) else if u = caar y and varlist = cadar y then list(caar y,cadar y,mu+caddar y) . cdr y else car y . solnmerge(u,varlist,mu,cdr y); symbolic procedure nilchk u; if null u then !*f2q u else u; symbolic procedure solve1test1(coeffs,rcoeffs,f); % True if equation is symmetric in its coefficients. f is midpoint. begin integer j; a: if j>f then return t else if car coeffs neq car rcoeffs then return nil; coeffs := cdr coeffs; rcoeffs := cdr rcoeffs; j := j+1; go to a end; symbolic procedure solve1test2(coeffs,rcoeffs,f); % True if equation is antisymmetric in its coefficients. f is % midpoint. begin integer j; a: if j>f then return t else if numr addsq(car coeffs,car rcoeffs) then return nil; coeffs := cdr coeffs; rcoeffs := cdr rcoeffs; j := j+1; go to a end; symbolic procedure solveabs u; begin scalar mu,var,lincoeff; var := cadr u; mu := caddr u; lincoeff := cadddr u; u := simp!* caar u; return append(solvesq(addsq(u,lincoeff),var,mu), solvesq(subtrsq(u,lincoeff),var,mu)) end; put('abs,'solvefn,'solveabs); symbolic procedure solveexpt u; begin scalar c,mu,var,lincoeff; var := cadr u; mu := caddr u; lincoeff := cadddr u; u := car u; return if freeof(car u,var) % c**(...) = b. then <<if !*allbranch then <<!!arbint:=!!arbint+1; c:=list('times,2,'i,'pi, list('arbint,!!arbint))>> else c:=0; solvesq(subtrsq(simp!* cadr u, quotsq(addsq(simp!* list('log,mk!*sq lincoeff), simp!* c), simp!* list('log,car u))),var,mu)>> else if freeof(cadr u,var) % (...)**(m/n) = b; then if ratnump cadr u then solve!-fractional!-power(u,lincoeff,var,mu) else << % (...)**c = b. if !*allbranch then <<!!arbint:=!!arbint+1; c := mkexp list('times, list('arbreal,!!arbint))>> else c:=1; solvesq(subtrsq(simp!* car u, multsq(simp!* list('expt, mk!*sq lincoeff, mk!*sq invsq simp!* cadr u), simp!* c)),var,mu)>> % (...)**(...) = b : transcendental. else list list(list subtrsq(simp!*('expt . u),lincoeff),nil,mu) end; symbolic procedure solve!-fractional!-power(u,x,var,mu); % attempts solution of equation car u**cadr u=x with respect to % kernel var and with multiplicity mu, where cadr u is a rational % number. begin scalar v,w,z; v := simp!* car u; w := simp!* cadr u; z := solvesq(subs2 subtrsq(exptsq(v,numr w),exptsq(x,denr w)), var,mu); w := subtrsq(simp('expt . u),x); z := check!-solutions(z,numr w); return if z eq 'unsolved then list list(list w,nil,mu) else z end; put('expt,'solvefn,'solveexpt); symbolic procedure solvelog u; solvesq(subtrsq(simp!* caar u,simp!* list('expt,'e,mk!*sq cadddr u)), cadr u,caddr u); put('log,'solvefn,'solvelog); symbolic procedure solvecos u; begin scalar c,d,z; if !*allbranch then <<!!arbint:=!!arbint+1; c:=list('times,2,'pi,list('arbint,!!arbint))>> else c:=0; c:=subtrsq(simp!* caar u,simp!* c); d:=simp!* list('acos,mk!*sq cadddr u); z := solvesq(subtrsq(c,d), cadr u,caddr u); if !*allbranch then z := append(solvesq(addsq(c,d), cadr u,caddr u),z); return z end; put('cos,'solvefn,'solvecos); symbolic procedure solvesin u; begin scalar c,d,f,z; if !*allbranch then <<!!arbint:=!!arbint+1; f:=list('times,2,'pi,list('arbint,!!arbint))>> else f:=0; c:=simp!* caar u; d:=list('asin,mk!*sq cadddr u); z := solvesq(subtrsq(c,simp!* list('plus,d,f)),cadr u,caddr u); if !*allbranch then z := append(solvesq(subtrsq(c,simp!* list('plus,'pi, mk!*sq subtrsq(simp!* f,simp!* d))), cadr u,caddr u),z); return z end; put('sin,'solvefn,'solvesin); symbolic procedure mkexp u; list('plus,list('cos,x),list('times,'i,list('sin,x))) where x = reval u; symbolic procedure solvecoeff(ex,var); % ex is a standard form and var a kernel. Puts the coefficients % (as standard quotients) of var in ex into the elements of !!cf, % with index equal to the exponent divided by the gcd of all the % exponents. This GCD is put into !!GCD, and the highest power % divided by the gcd is put into hipow. Returns hipow. Note that % !!cf (an array), !!gcd a global. begin scalar clist,hipow,oldkord; oldkord := setkorder list var; clist := reorder ex; setkorder oldkord; hipow := ldeg clist; clist := coeflis clist; !!gcd := caar clist; for each x in cdr clist do !!gcd := gcdn(car x, !!gcd); for i := 0:(car(dimension('!!cf))-1) do setelv(list('!!cf, i), nil); for each x in clist do setelv(list('!!cf, car x/!!gcd),cdr x ./ 1); hipow := hipow/!!gcd; return hipow end; symbolic procedure solveinterval(ex,var,mu); % ex is a standard form, var the relevant variable and mu the root % multiplicity. Isolates insoluble, real roots of EX in rational % intervals, returning solutions in terms of INTERVL(Lowlim,Highlim). begin scalar z; realroot(prepf ex,prepsq !*k2q mvar ex,'!!interval,'!!exact); for i := 1:getelv list('!!exact,0) do z := list(list simp!* getelv list('!!exact,i),list var,mu) . z; for i := 1:getelv list('!!interval,0,0) do z := list(list simp!* list('intervl, getelv list('!!interval,i,1), getelv list('!!interval,i,2)), list var,mu). z; return z end; symbolic procedure realroot(u,v,w,x); rederr("Real root finding not yet implemented"); % ***** Procedures for solving a system of eqns ***** symbolic procedure solvesys(exlist,varlis); % exlist is a list of standard forms, varlis a list of kernels. If % the elements of varlis are linear in the elements of exlist, and % further the system of linear eqns so defined is non-singular, then % SOLVESYS returns a list of a list of standard quotients which are % solutions of the system, ordered as in varlis. Otherwise an error % results. begin scalar eqtype,oldkord; oldkord := setkorder varlis; exlist := for each j in exlist collect reorder j; % See if equations are linear or non-linear. eqtype := 'solvelnrsys; for each ex in exlist do for each var in varlis do if not domainp ex and mvar ex=var then if ldeg ex>1 or not freeofl(lc ex,varlis) then eqtype := 'solvenonlnrsys else ex := red ex; if eqtype eq 'solvenonlnrsys and null !*nonlnr then rederr "Non linear equation solving not yet implemented"; exlist:=errorset(list(eqtype,mkquote exlist,mkquote varlis),t,t); setkorder oldkord; if errorp exlist then error1() else return car exlist end; endmodule; module glsolve; % Routines for solving a general system of linear eqns. % Author: Eberhard Schruefer. %********************************************************************** %*** The number of equations and the number of unknowns are *** %*** arbitrary i.e. the system can be under- or overdetermined. *** %*** Method used is Cramer's rule, realized through exterior *** %*** multiplication. *** %********************************************************************** fluid '(kord!*); global '(!!arbint !*solvesingular); % algebraic operator arbcomplex; % Already defined in main solve module. symbolic procedure glsolve!-eval(u,bool); % This allows glsolve to be called at the user level. I'm not % sure this is now a good idea, since this code does not check % for non-linear equations and so on. begin scalar unknowns,equations,okord,solutions; if cdr u then unknowns := for each j in cdadr u collect !*a2k j; okord := setkorder append(unknowns,kord!*); equations := for each j in cdar u collect reorder numr simp!* j; if null unknowns then unknowns := allkernf equations; solutions := glnrsolve(equations,unknowns); setkorder okord; if null solutions then return '(list); % empty list. solutions := nil . solutions; return 'list . for each j in unknowns collect list('equal,j,mk!*sq car(solutions := cdr solutions)) end; symbolic procedure allkernf u; if null u then nil else union(kernels car u,allkernf cdr u); put('glsolve,'psopfn,'glsolve!-eval); symbolic procedure solvelnrsys(u,v); % This is hook to general solve package. u is a list of polynomials % (s.f.'s) linear in the kernels of list v. Result is a matrix % standard form for the solutions. list glnrsolve(u,v); symbolic procedure glnrsolve(u,v); %u is a list of polynomials (s.f.'s) linear in the kernels %of list v. Result is an untagged list of solutions. begin scalar arbvars,sgn,x,y; x := !*sf2ex(car u,v); u := cdr u; for each j in u do if y := extmult(!*sf2ex(j,v),x) then x := y; if inconsistency!-chk x then rederr "SOLVE given inconsistent equations"; arbvars := for each j in setdiff(v,lpow x) collect j . makearbcomplex(); if arbvars and null !*solvesingular then rederr "SOLVE given singular equations"; if null red x then return for each j in v collect if y := atsoc(j,arbvars) then !*f2q cdr y else nil ./ 1; sgn := evenp length lpow x; return for each j in v collect if y := atsoc(j,arbvars) then !*f2q cdr y else mkglsol(j,x,sgn := not sgn,arbvars) end; symbolic procedure inconsistency!-chk u; null u or ((nil memq lpow u) and inconsistency!-chk red u); symbolic procedure mkglsol(u,v,sgn,arbvars); begin scalar s,x,y; x := nil ./ 1; y := lpow v; for each j on red v do if s := glsolterm(u,y,j,arbvars) then x := addsq(cancel(s ./ lc v),x); return if sgn then negsq x else x end; symbolic procedure glsolterm(u,v,w,arbvars); begin scalar x,y,sgn; x := lpow w; a: if null x then return if null car y then lc w else multf(cdr atsoc(car y,arbvars), if sgn then negf lc w else lc w); if car x eq u then return nil else if car x memq v then <<x := cdr x; if y then sgn := not sgn>> else if y then return nil else <<y := list car x; x := cdr x>>; go to a end; %**** Support for exterior multiplication **** % Data structure is lpow ::= list of variables in exterior product % lc ::= standard form symbolic procedure !*sf2ex(u,v); %Converts standardform u into a form distributed w.r.t. v %*** Should we check here if lc is free of v? if null u then nil else if domainp u or null(mvar u memq v) then list nil .* u .+ nil else list mvar u .* lc u .+ !*sf2ex(red u,v); symbolic procedure extmult(u,v); %Special exterior multiplication routine. Degree of form v is %arbitrary, u is a one-form. if null u or null v then nil else (if x then cdr x .* (if car x then negf multf(lc u,lc v) else multf(lc u,lc v)) .+ extadd(extmult(!*t2f lt u,red v), extmult(red u,v)) else extadd(extmult(red u,v),extmult(!*t2f lt u,red v))) where x = ordexn(car lpow u,lpow v); symbolic procedure extadd(u,v); if null u then v else if null v then u else if lpow u = lpow v then (lambda x,y; if null x then y else lpow u .* x .+ y) (addf(lc u,lc v),extadd(red u,red v)) else if ordexp(lpow u,lpow v) then lt u .+ extadd(red u,v) else lt v .+ extadd(u,red v); symbolic procedure ordexp(u,v); if null u then t else if car u eq car v then ordexp(cdr u,cdr v) else if null car u then nil else if null car v then t else ordop(car u,car v); symbolic procedure ordexn(u,v); %u is a single variable, v a list. Returns nil if u is a member %of v or a dotted pair of a permutation indicator and the ordered %list of u merged into v. begin scalar s,x; a: if null v then return(s . reverse(u . x)) else if u eq car v then return nil else if u and ordop(u,car v) then return(s . append(reverse(u . x),v)) else <<x := car v . x; v := cdr v; s := not s>>; go to a end; endmodule; module quartic; % Procedures for solving cubic, quadratic and quartic % eqns. % Author: Anthony C. Hearn. fluid '(!*sub2); symbolic procedure multfq(u,v); % Multiplies standard form U by standard quotient V. begin scalar x; x := gcdf(u,denr v); return multf(quotf(u,x),numr v) ./ quotf(denr v,x) end; symbolic procedure quotsqf(u,v); % Forms quotient of standard quotient U and standard form V. begin scalar x; x := gcdf(numr u,v); return quotf(numr u,x) ./ multf(quotf(v,x),denr u) end; symbolic procedure cubertq u; simpexpt list(mk!*sq subs2!* u,'(quotient 1 3)); % SIMPRAD(U,3); symbolic procedure sqrtq u; simpexpt list(mk!*sq subs2!* u,'(quotient 1 2)); % SIMPRAD(U,2); symbolic procedure subs2!* u; <<!*sub2 := t; subs2 u>>; symbolic procedure solvequadratic(a2,a1,a0); % a2, a1 and a0 are standard quotients. % solves a2*x**2+a1*x+a0=0 for x. % returns a list of standard quotient solutions. begin scalar d; d := sqrtq subtrsq(quotsqf(exptsq(a1,2),4),multsq(a2,a0)); a1 := quotsqf(negsq a1,2); return list(subs2!* quotsq(addsq(a1,d),a2), subs2!* quotsq(subtrsq(a1,d),a2)) end; symbolic procedure solvecubic(a3,a2,a1,a0); % a3, a2, a1 and a0 are standard quotients. % solves a3*x**3+a2*x**2+a1*x+a0=0 for x. % returns a list of standard quotient solutions. % See Abramowitz and Stegun, Sect. 3.8.2, for details. begin scalar q,r,sm,sp,s1,s2,x; a2 := quotsq(a2,a3); a1 := quotsq(a1,a3); a0 := quotsq(a0,a3); q := subtrsq(quotsqf(a1,3),quotsqf(exptsq(a2,2),9)); r := subtrsq(quotsqf(subtrsq(multsq(a1,a2),multfq(3,a0)),6), quotsqf(exptsq(a2,3),27)); x := sqrtq addsq(exptsq(q,3),exptsq(r,2)); s1 := cubertq addsq(r,x); s2 := if numr s1 then negsq quotsq(q,s1) else cubertq subtrsq(r,x); % This optimization only works if s1 is non zero. sp := addsq(s1,s2); sm := quotsqf(multsq(simp '(times i (sqrt 3)),subtrsq(s1,s2)),2); x := subtrsq(sp,quotsqf(a2,3)); sp := negsq addsq(quotsqf(sp,2),quotsqf(a2,3)); return list(subs2!* x,subs2!* addsq(sp,sm), subs2!* subtrsq(sp,sm)) end; symbolic procedure solvequartic(a4,a3,a2,a1,a0); % Solve the quartic equation a4*x**4+a3*x**3+a2*x**2+a1*x+a0 = 0, % where the ai are standard quotients, using technique described in % Section 3.8.3 of Abramowitz and Stegun; begin scalar x,y,z; % Convert equation to monomial form. a3 := quotsq(a3,a4); a2 := quotsq(a2,a4); a1 := quotsq(a1,a4); a0 := quotsq(a0,a4); % Build and solve the resultant cubic equation. We select an % arbitrary member of its set of solutions. Ideally we should % only generate one solution, which should be the simplest. y := subtrsq(exptsq(a3,2),multfq(4,a2)); % note that only first cubic solution is used here. We could save % computation by using this fact. x := car solvecubic(!*f2q 1, negsq a2, subs2!* subtrsq(multsq(a1,a3),multfq(4,a0)), subs2!* negsq addsq(exptsq(a1,2), multsq(a0,y))); % Now solve the two equivalent quadratic equations. y := sqrtq addsq(quotsqf(y,4),x); z := sqrtq subtrsq(quotsqf(exptsq(x,2),4),a0); a3 := quotsqf(a3,2); x := quotsqf(x,2); return append(solvequadratic(!*f2q 1,addsq(a3,y),subtrsq(x,z)), solvequadratic(!*f2q 1,subtrsq(a3,y),addsq(x,z))) end; endmodule; module solvetab; % Simplification rules for SOLVE. % Author: David R. Stoutemyer. % Modifications by: Anthony C. Hearn and Donald R. Morrison; algebraic operator sol; put('asin, 'inverse, 'sin); put('acos, 'inverse, 'cos); algebraic; comment Rules for reducing the number of distinct kernels in an equation; for all a,b,x such that ratnump c and ratnump d let sol(a**c-b**d, x) = a**(c*lcm(c,d)) - b**(d*lcm(c,d)); for all a,b,c,d,x such that a freeof x and c freeof x let sol(a**b-c**d, x) = e**(b*log a - d*log c); for all a,b,c,d,x such that a freeof x and c freeof x let sol(a*log b + c*log d, x) = b**a*d**c - 1, sol(a*log b - c*log d, x) = b**a - d**c; for all a,b,c,d,f,x such that a freeof x and c freeof x let sol(a*log b + c*log d + f, x) = sol(log(b**a*d**c) + f, x), sol(a*log b + c*log d - f, x) = sol(log(b**a*d**c) - f, x), sol(a*log b - c*log d + f, x) = sol(log(b**a/d**c) + f, x), sol(a*log b - c*log d - f, x) = sol(log(b**a/d**c) - f, x); for all a,b,d,f,x such that a freeof x let sol(a*log b + log d + f, x) = sol(log(b**a*d) + f, x), sol(a*log b + log d - f, x) = sol(log(b**a*d) - f, x), sol(a*log b - log d + f, x) = sol(log(b**a/d) + f, x), sol(a*log b - log d - f, x) = sol(log(b**a/d) - f, x), sol(log d - a*log b + f, x) = sol(log(d/b**a) + f, x), sol(log d - a*log b - f, x) = sol(log(d/b**a) - f, x); for all a,b,c,d,x such that a freeof x and c freeof x let sol(a*log b + c*log d, x) = b**a*d**c - 1, sol(a*log b - c*log d, x) = b**a - d**c; for all a,b,d,x such that a freeof x let sol(a*log b + log d, x) = b**a*d - 1, sol(a*log b - log d, x) = b**a - d, sol(log d - a*log b, x) = d - b**a; for all a,b,c,x let sol(log a + log b + c, x) = sol(log(a*b) + c, x), sol(log a - log b + c, x) = sol(log(a/b) + c, x), sol(log a + log b - c, x) = sol(log(a*b) - c, x), sol(log a - log b - c, x) = sol(log(a/b) - c, x); for all a,c,x such that c freeof x let sol(log a + c, x) = a - e**c, sol(log a - c, x) = a - e**(-c); for all a,b,x let sol(log a + log b, x) = a*b - 1, sol(log a - log b, x) = a - b, sol(cos a - sin b, x) = sol(cos a - cos(pi/2-b), x), sol(sin a + cos b, x) = sol(sin a - sin(b-pi/2), x), sol(sin a - cos b, x) = sol(sin a - sin(pi/2-b), x), sol(sin a + sin b, x) = sol(sin a - sin(-b), x), sol(sin a - sin b, x) = if !*allbranch then sin((a-b)/2)* cos((a+b)/2) else a-b, sol(cos a + cos b, x) = if !*allbranch then cos((a+b)/2)* cos((a-b)/2) else a+b, sol(cos a - cos b, x) = if !*allbranch then sin((a+b)/2)* sin((a-b)/2) else a-b, sol(asin a - asin b, x) = a-b, sol(asin a + asin b, x) = a+b, sol(acos a - acos b, x) = a-b, sol(acos a + acos b, x) = a+b; symbolic; endmodule; end; |
Added r33/spde.red version [8930c2efb4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module spde; % Determine Lie symmetries of partial differential eqns. % Author: Fritz Schwarz. %*******************************************************************$ % $ % This is the REDUCE package SPDE for determining $ % Lie symmetries of partial differential equations $ % Version of November 1986 $ % $ % $ % Fritz Schwarz $ % GMD Institut F1 $ % Postfach 1240 $ % 5205 St. Augustin $ % West Germany $ % $ % Tel. 02241-142782 $ % EARN Id. DBNGMD21.GF1002 $ %*******************************************************************$ algebraic operator x,u,xi,eta,c,xi!*,eta!*$ algebraic operator deq,dx,du,gl,gen,sder,rule$ share pclass,mm,nn$ global'(pclass mm nn depl!* num!-cgen num!-dgen)$ lisp(pclass:=mm:=nn:=num!-cgen:=num!-dgen:=0)$ lisp(operator simpsys,result,prsys,prsys!*)$ fluid '(!*list kord!*)$ fluid'(uhf dfsub csub czero rdep !*rational)$ fluid'(list!-m list!-deq list!-pq)$ %symbolic procedure prload$ % begin % if not getd 'solve1 then load solve1,solvetab,quartic; % if not getd 'depend1 then load depend; % if not getd 'ratfunpri then load ratprin; % end$ symbolic procedure prload; nil; %*******************************************************************$ % Auxiliary RLISP procedures $ %*******************************************************************$ symbolic procedure ordp(u,v)$ %Modified ordering function which orders kernels with CAR parts; %DF, ETA, XI and C ahead of anything else; if null u then null v else if null v then t else if eq(u,'df) or eq(u,'eta) and not eq(v,'df) or eq(u,'xi) and not(eq(v,'df) or eq(v,'eta)) or eq(u,'c) and not(eq(v,'df) or eq(v,'eta) or eq(v,'xi)) then t else if eq(u,'eta) and eq(v,'df) or eq(u,'xi) and (eq(v,'df) or eq(v,'eta)) or eq(u,'c) and (eq(v,'df) or eq(v,'eta) or eq(v,'xi)) or eq(v,'df) or eq(v,'eta) or eq(v,'xi) or eq(v,'c) then nil else if atom u then if atom v then if numberp u then numberp v and not u<v else if numberp v then t else orderp(u,v) else nil else if atom v then t else if car u=car v then ordp(cdr u,cdr v) else ordp(car u,car v)$ symbolic procedure makeset u$ if not u then nil else if member(car u,cdr u) then makeset cdr u else car u . makeset cdr u$ symbolic procedure lastmem u$ if cdr u then lastmem cdr u else car u$ symbolic procedure xmember(u,v)$ reverse member(u,reverse v)$ symbolic procedure sacar(a,u)$ if atom u then nil else if eq(a,car u) and cdr u then list u else append(sacar(a,car u),sacar(a,cdr u))$ symbolic procedure scar(a,u)$ if atom u then nil else if a=car u then u else scar(a,car u) or scar(a,cdr u)$ symbolic procedure inter(u,v); if not u then nil else if member(car u,v) then (car u) . inter(cdr u,v) else inter(cdr u,v)$ symbolic procedure compl(u,v)$ if not u then nil else if member(car u,v) then compl(cdr u,v) else car u . compl(cdr u,v)$ symbolic procedure vlist u$ %U is list of items, returns U with all integers omitted; if not u then nil else if numberp car u then vlist cdr u else (car u) . vlist cdr u$ symbolic procedure delnil u$ %U is list, returns U with all occurences of nil deleted; if not u then nil else if car u then (car u) . delnil cdr u else delnil cdr u$ symbolic procedure prlist u$ %U is list of items, returns list of all pairs in U; if not u then nil else if pairp car u then (car u) . prlist cdr u else prlist cdr u$ symbolic procedure appends(u,v,w)$ append(u,append(v,w))$ symbolic procedure propa(fn,u)$ %FN is predicate of a single argument, U a list; %Returns T if predicate is true for all elements of U; begin scalar ind; ind:=t; while ind and u do <<ind:=apply(fn,list car u); u:=cdr u>>; return ind; end$ symbolic procedure sortx(fn,u)$ begin scalar v,w; while u do<<v:=maxmem(fn,u); u:=delete(v,u); w:=v . w>>; return w; end$ symbolic procedure maxmem(fn,u)$ %FN is function of a single argument, U a list; %Returns element of U for which FN is maximal; begin scalar v; v:=car u; foreach x in cdr u do if greaterp(apply(fn,list x),apply(fn,list v)) then v:=x; return v; end$ symbolic procedure maxl u$ %U is list of integers, returns largest element of U; if not u then -10000 else max(car u,maxl cdr u)$ symbolic procedure suml u$ %U is list of integers, returns sum of all elements; if not u then 0 else plus2(car u,suml cdr u)$ symbolic procedure spde!-subsetp(u,v)$ %U and V are list representing sets; %Returns T if set U is subset of V; if not u then t else member(car u,v) and spde!-subsetp(cdr u,v)$ symbolic procedure product!-set2(u,v)$ %U and V are lists representing sets, returns list representing; %product set of sets represented by U and V; begin scalar w; foreach x in u do foreach y in v do w:=list(x,y) . w; return w; end$ symbolic procedure leqgrt(l,i,j)$ i leq j and eqn(l,i) or i geq add1 j$ symbolic procedure fidep u$ assoc(u,depl!*) and cdr assoc(u,depl!*)$ symbolic procedure mkdep u$ foreach x in cdr u do depend1(car u,x,t)$ symbolic procedure rmdep u$ <<rmsubs(); foreach x in cdr u do depend1(car u,x,nil)>>$ symbolic procedure blanks l; begin scalar u; u := '(!"); for k:=1:l do u:='! . u; return compress('!" . u) end$ symbolic procedure terpri2$ <<terpri(); terpri()>>$ %*******************************************************************$ % Auxiliary procedures for manipulating standard forms $ %*******************************************************************$ symbolic procedure lcf u$ not domainp u and lc u$ symbolic procedure minus!-f u$ %U is s.f., returns T if lnc U is negative; minusf numr simp reval u$ lisp operator minus!-f$ symbolic procedure lengthn u$ if not u then 0 else if numberp car u then plus(sub1 car u,lengthn cdr u) else plus(1,lengthn cdr u)$ symbolic procedure degreef(u,v)$ %U is s.f., V kernel, returns degree of V in U; if domainp u then 0 else if mvar u=v then ldeg u else max(degreef(lc u,v),degreef(red u,v))$ symbolic procedure lengthf u$ %U is prefix s.f., returns printlength for U; if not u then 0 else if atom u then flatsizec u else if eqcar(u,'plus) then plus(times(3,sub1 length cdr u),lengthf cdr u) else if eqcar(u,'times) or eqcar(u,'minus) then plus(sub1 length cdr u,lengthf cdr u) else if eqcar(u,'quotient) then if !*rational then add1 add1 max(flatsizec cadr u,flatsizec caddr u) else add1 plus(flatsizec cadr u,flatsizec caddr u) else if eqcar(u,'expt) then add1 flatsizec cadr u else if eqcar(u,'dx) or eqcar(u,'du) then plus(flatsizec cadr u,4) else if eqcar(u,'xi) or eqcar(u,'eta) or eqcar(u,'c) or eqcar(u,'x) or eqcar(u,'u) then times(2,length u) else if eqcar(u,'df) then plus(4,lengthf cadr u,lengthf cddr u) else plus(lengthf car u,lengthf cdr u)$ lisp operator lengthf$ symbolic procedure diford u$ lengthn cddr u$ symbolic procedure adiff(u,v)$ %U is kernel with CAR part DF, V is kernel; %Returns U integrated with respect to V; if not member(v,u) then u else if length u=3 and member(v,u) then cadr u else if not cdr member(v,u) or not numberp cadr member(v,u) then delete(v,u) else if cadr member(v,u)=2 then append(xmember(v,u),cddr member(v,u)) else append(xmember(v,u),(sub1 cadr member(v,u)) . cddr member(v,u))$ symbolic procedure sub!-int!-df u$ %U is kernel with CAR part INT, returns integrated kernel if CADR; %part of U is DF and integration variable occurs as argument of DF; if eqcar(cadr u,'df) and member(lastmem u,cadr u) then adiff(cadr u,lastmem u) else u$ symbolic procedure subintf u$ %U is s.f., performs all integrations which may be done; %by cancellation of corresponding differentiation; begin foreach x in makeset sacar('int,u) do u:=subst(sub!-int!-df x,x,u); return numr simp prepf u; end$ symbolic procedure monop u$ %Returns T if u is monomial; domainp u or not red u and monop lc u$ symbolic procedure solvef(u,v)$ car solve0(prepf u,v)$ symbolic procedure comfacn u$ lnc ckrn u$ symbolic procedure remfacn u$ quotf(u,lnc ckrn u)$ %*******************************************************************$ % Procedures for manipulating l.d.f.'s, U is always l.d.f. $ % in this section $ %*******************************************************************$ symbolic procedure ldf!-mvar u$ %Returns function argument of mvar U; (if eqcar(x,'df) then cadr x else x) where x=mvar u; symbolic procedure ldf!-fvar u$ %Returns all function arguments occuring in U; makeset foreach x in u collect ldt!-tvar x$ symbolic procedure ldf!-fvar!-part(u,v)$ %V is function xi(i), eta(alpha) or c(k), returns l.d.f. of those; %terms in U with ldt-tvar x equal to V, overall factors not removed; begin scalar w; foreach x in u do if eq(ldt!-tvar x,v) then w:=x . w; return reverse w; end$ symbolic procedure ldf!-dep!-var u$ %Returns all variables x(i) or u(alpha) which occur as; %arguments of XI, ETA or C; begin scalar v; foreach x in u do if assoc(ldt!-tvar x,depl!*) then v:=append(cdr assoc(ldt!-tvar x,depl!*),v); return makeset v; end$ symbolic procedure ldf!-pow!-var u$ %Returns all variables x(i) or u(alpha) which occur as powers; begin scalar v,z; foreach x in u do v:=append(v,kernels tc x); foreach y in prlist makeset v do if eqcar(y,'x) or eqcar(y,'u) then z:=y . z; return makeset z; end$ symbolic procedure ldf!-deg(u,v)$ %V is kernel x(i) or u(alpha), returns degree of U in V; maxl foreach x in u collect degreef(tc x,v)$ symbolic procedure ldf!-spf!-var u$ %Returns all variables x(i) or u(alpha) which occur as; %arguments of any other kernel than xi, eta or c; begin scalar v,z; foreach x in u do v:=append(v,kernels tc x); foreach y in prlist makeset v do if not eqcar(y,'x) and not eqcar(y,'u) then z:=appends(sacar('x,cdr y),sacar('u,cdr y),z); return makeset z; end$ symbolic procedure ldf!-all!-var u$ %Returns all variables x(i) or u(alpha) which occur in U; makeset appends(ldf!-dep!-var u,ldf!-pow!-var u,ldf!-spf!-var u)$ symbolic procedure ldf!-sep!-var u$ %Returns all variables w.r.t. which U may be separated; compl(compl(ldf!-pow!-var u,ldf!-dep!-var u),ldf!-spf!-var u)$ symbolic procedure ldf!-int!-var u$ %Returns all variables w.r.t. which U may be integrated; if eqcar(mvar u,'df) then begin scalar v; v:=ldf!-all!-var u; while v and u do <<v:=compl(v,compl(ldt!-dep car u,ldt!-dfvar car u)); u:=cdr u>>; return v; end$ symbolic procedure ldf!-int u$ %U is l.d.f, returns U with all possible integrations performed; %or unchanged if integration is not possible; begin scalar v,w,z,test; integer nfun; a: test:=nil; w:=ldf!-int!-var u; nfun:=find!-nfun(); foreach x in w do if not smember('int,z:=caadr algebraic int(lisp prepf u,x)) or not smember('int,z:=subintf z) then <<v:=!*a2k list('c,nfun:=nfun+1); test:=t; mkdep(v . delete(x,ldf!-all!-var u)); u:=addf(z,!*k2f v)>>; if test then go to a; return u; end$ symbolic procedure ldf!-df!-diff u$ %Returns list of all df-kernels which may be obtained; %from U by differentiation or nil; begin scalar dfvar,dfsub,v,w,z0,z; integer n0,nmax; v:=compl(ldf!-dep!-var u,ldf!-spf!-var u); if not v then return; w:=foreach x in v collect list(x,add1 ldf!-deg(u,x)); nmax:=maxl foreach x in w collect cadr x; while (n0:=n0+1) leq nmax and not(z0:=nil) do <<foreach x in w do if cadr x geq n0 then z0:=(car x) . z0; z:=z0 . z>>; z:=reverse z; dfvar:=foreach x in car z collect list x; foreach x in cdr z do dfvar:= append(dfvar,foreach y in dfvar collect car product!-set2(x,y)); foreach x in dfvar do begin scalar p,q; p:=x; q:=u; while p and q and red q do <<q:=ldf!-simp numr difff(q,car p); p:=cdr p>>; if pairp q and not red q and eqcar(mvar q,'df) then dfsub:=(mvar q) . dfsub; end; return makeset dfsub; end$ symbolic procedure ldf!-sub!-var u$ %Returns function w.r.t. which U may be resolved; begin scalar v,w,z; w:=ldf!-all!-var u; foreach x in u do if not v and not eqcar(z:=tvar x,'df) and monop tc x and spde!-subsetp(w,ldt!-dep x) and not smember(z,delete(x,u)) then v:=z; return v; end$ symbolic procedure ldf!-simp u$ %Returns l.d.f. form of U; if not u then nil else if not red u then numr simp prepf !*k2f mvar u else begin scalar v; v:=numr simp prepf u; if not domainp v then v := quotf(v,cdr comfac v); return absf v end$ symbolic procedure ldf!-sep u$ %Returns list of l.d.f. into which U has been separated; begin scalar v; integer k; if not(v:=ldf!-sep!-var u) then return list u; foreach x in v do u:=subst(list('ux,1,k:=k+1),x,u); return foreach x in coeff!-all(u,'ux) collect ldf!-simp numr simp prepf x; end$ symbolic procedure ldf!-subf0 u$ %Returns U with CZERO substituted; ldf!-simp delnil foreach x in u collect ldt!-subt0 x$ %*******************************************************************$ % Procedures for manipulating l.d.t.'s, U is always l.d.t. $ % in this section $ %*******************************************************************$ symbolic procedure ldt!-tvar u$ %U is l.d.t., returns function argument of tvar U; (if eqcar(x,'df) then cadr x else x) where x=tvar u$ symbolic procedure ldt!-dfvar u$ %U is l.d.t., returns variables w.r.t. which tvar u is derived or nil; (if eqcar(x,'df) then vlist cddr x else nil) where x=tvar u$ symbolic procedure ldt!-dep u$ %U is l.d.t., returns list of variables x or y which occur as; %arguments LDT-tvar u; (if x then cdr x else nil) where x=assoc(ldt!-tvar u,depl!*)$ symbolic procedure ldt!-subt0 u$ %U is l.d.t., returns U if LDT-tvar u is not on czero; if not member(ldt!-tvar u,czero) then u else nil$ %*******************************************************************$ % Procedures for constructing the determining system $ %*******************************************************************$ symbolic procedure cresys u$ begin scalar r,v,w,lgl,lsub,depl!*!*,list!-sder; remprop('df,'kvalue); remprop('df,'klist); remprop('c,'kvalue); remprop('c,'klist); prload(); rmsubs(); depl!*:=nil; if car u then list!-deq:=foreach x in u collect assoc(x,get(car x,'kvalue)) else list!-deq:=get('deq,'kvalue); if eqn(length list!-deq,1) then begin scalar p; p:=maxmem(function length,makeset sacar('u,list!-deq)); p:=mk!*sq !*k2q p; list!-sder:=list list(list('sder, cadaar list!-deq),p); end else if car u then list!-sder:=foreach x in list!-deq collect assoc(list('sder,cadar x),get('sder,'kvalue)) else list!-sder:=get('sder,'kvalue); if not list!-deq then rederr "Differential equations not defined"; if not list!-sder then rederr "Substitutions for derivatives not defined"; mm:=find!-m list!-deq; nn:=find!-n list!-deq; list!-m:= makeset foreach x in sacar('u,list!-deq) collect cadr x; for k:=1:nn do<<w:=!*a2k list('xi,k) . w; v:=!*a2k list('x,k) . v>>; for k:=1:mm do if member(k,list!-m) then <<w:=!*a2k list('eta,k) . w; v:=!*a2k list('u,k) . v>>; for k:=1:nn do r:=(!*a2k list('dx,k)) . r; for k:=1:mm do r:=(!*a2k list('du,k)) . r; for k:=1:mm do depl!*!*:=(!*a2k list('eta,k) . v) . depl!*!*; for k:=1:nn do depl!*!*:=(!*a2k list('xi,k) . v) . depl!*!*; depl!*:=depl!*!*; kord!*:=reverse r; foreach x in list!-sder do lsub:=((mvar caadr cadr x) . prepsq caar solvef(caadr cadr assoc (list('deq,cadar x),list!-deq),mvar caadr cadr x)) . lsub; foreach x in list!-deq do begin scalar s,z,lx,lu; z:=caadr cadr x; lx:=makeset sacar('x,z); lu:=makeset sacar('u,z); foreach y in lx do s:=addf(s, multf(!*k2f !*a2k list('xi,cadr y),numr simp prepsq difff(z,y))); foreach y in lu do if length y=2 then s:=addf(s,multf (!*k2f !*a2k list('eta,cadr y),numr simp prepsq difff(z,y))) else s:=addf(s, multf(numr zeta!* cdr y,numr simp prepsq difff(z,y))); s:=numr subf(s,lsub); s:=numr subf(s,lsub); lgl:=append(coeff!-all(s,'u),lgl); end; uhf:=list(makeset lgl,foreach x in reverse w collect !*k2q x); end$ lisp rlistat'(cresys)$ symbolic procedure totder(u,i)$ begin scalar z,v,w; v:=car difff(u,!*a2k list('x,i)); z:=makeset sacar('u,u); for k:=1:mm do if member(k,list!-m) then z:=(!*a2k list('u,k)) . z; foreach x in makeset z do w:=addf(w, multf(!*k2f !*a2k append(x,list i),car difff(u,x))); return numr simp prepf addf(v,w); end$ symbolic procedure zeta!* u$ if not get('deq,'kvalue) and (eqn(mm,0) or eqn(nn,0)) then rederr"Number of variables not defined" else if length u geq 3 then begin scalar v,w; prload(); if eqn(nn,0) then nn:=find!-n list!-deq; v:=totder(numr zeta!* reverse cdr reverse u,car reverse u); for s:=1:nn do w:=addf(w, multf(!*k2f !*a2k('u . append(reverse cdr reverse u,list s)), totder(!*k2f !*a2k list('xi,s),car reverse u))); return simp prepsq(addf(v,negf w) ./ 1); end else begin scalar v,w; prload(); if eqn(nn,0) then <<nn :=find!-n list!-deq; mm:=find!-m list!-deq>> else begin scalar p,z; for k:=1:mm do z:=cons(k,z); for k:=1:nn do p:=(!*a2k list('x,k)) . p; for k:=1:mm do p:=(!*a2k list('u,k)) . p; for k:=1:nn do mkdep((!*a2k list('xi,k)) . p); for k:=1:mm do mkdep((!*a2k list('eta,k)) . p); list!-m:=z; end; v:=totder(!*k2f !*a2k list('eta,car u),cadr u); for s:=1:nn do w:=addf(w, multf(!*k2f !*a2k list('u,car u,s), totder(!*k2f !*a2k list('xi,s),car reverse u))); return simp prepsq(addf(v,negf w) ./ 1); end$ symbolic procedure simpu u$ !*p2q mksp(('u . (car u . reverse ordn cdr u)),1)$ put('u,'simpfn,'simpu)$ put('zeta,'simpfn,'zeta!*)$ symbolic procedure coeff!-all(u,v)$ begin scalar z; list!-pq:=nil; splitrec(u,v,1,nil); foreach x in list!-pq do z:=(ldf!-simp numr simp prepf cdr x) . z; return makeset z; end$ symbolic procedure splitrec(u,v,p,q)$ if domainp u then begin scalar y; p:=multf(u,p); if y:=assoc(q,list!-pq) then rplacd(y,addf(cdr y,p)) else list!-pq:=(q . p) . list!-pq; end else begin if eqcar(mvar u,v) and length mvar u greaterp 2 then splitrec(lc u,v,p,(lpow u) . q) else splitrec(lc u,v,!*t2f(lpow(u) .* p),q); if red u then splitrec(red u,v,p,q); end$ symbolic procedure find!-m u$ maxl makeset foreach x in sacar('u,u) collect cadr x$ symbolic procedure find!-n u$ begin scalar vx,vu,wx,wu; vx:=makeset sacar('x,u); vu:=makeset sacar('u,u); foreach x in vx do wx:=(cadr x) . wx; foreach x in vu do if length x geq 3 then wu:=append(cddr x,wu); return max(maxl wx,maxl wu); end$ %*******************************************************************$ % Procedures for solving the determining system $ %*******************************************************************$ symbolic procedure rule0$ %Searches for equations of the form C(I)=0 and stores them on CZERO; if uhf then foreach x in car uhf do if not red x and not eqcar(mvar x,'df) then czero:=(mvar x) . czero$ symbolic procedure rule1$ %Searches for equations of the form DF(function,variable)=0; %and stores it on the list RDEP; if uhf and car uhf then begin scalar dfsub; foreach x in car uhf do if not red x and eqcar(mvar x,'df) and eqn(diford mvar x,1) then rdep:=(mvar x) . rdep; if rdep then return t; end$ symbolic procedure rule1!-diff$ %Searches for equations of the form DF(function,variable)=0; %which may be obtained by a single differentiation and stores it on; %the list RDEP; if uhf and car uhf then begin scalar u,v,z; foreach x in car uhf do if(z:=ldf!-df!-diff x) then u:=append(z,u); foreach x in u do if eqn(diford x,1) then v:=x . v; rdep:=makeset v; if rdep then return t; end$ symbolic procedure rulec l$ %Searches for equations of length L which may be solved for a; %function and stores the corresponding rules on CSUB; if uhf and car uhf then begin scalar v; foreach u in car uhf do if leqgrt(length u,l,4) and (v:=ldf!-sub!-var u) and not smember(v,csub) and not inter(foreach x in csub collect car x,ldf!-fvar u) then csub:=(v . prepsq caar solvef(u,v)) . csub; if csub then return t; end$ symbolic procedure ruledf l$ %Searches for equations of the form DF(function,derivative list)=0; %the derivative beeing of order L and stores the resulting; %substitution polynomial on CSUB; if uhf and car uhf then begin scalar dfsub; foreach x in car uhf do if not red x and eqcar(mvar x,'df) and eqn(diford mvar x,l) and not smember(ldf!-mvar x,dfsub) then dfsub:=(mvar x) . dfsub; csub:=foreach x in dfsub collect(cadr x) . crepol x; if csub then return t; end$ symbolic procedure ruledf!-diff l$ %Searches for all equations of the form; %DF(function,derivative list)=0 which may be obtained by; %differentiation, picks out those of order L and stores; %the corresponding substitution polynomial on CSUB; if uhf and car uhf then begin scalar v,dfsub; foreach u in car uhf do v:=append(v,ldf!-df!-diff u); if not(v:=makeset v) then return; foreach x in v do if eqn(diford x,l) then dfsub:=x . dfsub; if not dfsub then return; csub:=((cadar dfsub) . crepol car dfsub) . csub; if csub then return t; end$ symbolic procedure rule!-int l$ %Searches for an equation of length L which may be solved for a; %function after beeing integrated and stores the corresponding; %rule on CSUB; if uhf and car uhf then begin scalar v,w; foreach u in car uhf do if not csub and leqgrt(length u,l,4) and (v:=ldf!-sub!-var(w:=ldf!-int u)) then csub:=list(v . prepsq caar solvef(w,v)); if csub then return t; end$ symbolic procedure simpsys0$ %Removes variable which are stored on list CZERO; begin scalar u,v; if pclass=2 then<<write"Entering SIMPSYS0"; terpri2()>>; u:=delnil foreach x in car uhf collect ldf!-subf0 x; v:=foreach x in cadr uhf collect ldf!-subf0 numr x ./ denr x; uhf:=list(makeset u,v); if pclass=1 then begin terpri2(); if eqn(length czero,1) then write"Substitution" else write"Substitutions"; terpri(); foreach x in czero do algebraic write (lisp aeval x),":=0"; terpri(); end; if pclass=2 then<<write"CZERO:="; prettyprint czero; terpri()>>; czero:=nil; if pclass=2 then<<write"Leaving SIMPSYS0"; terpri2()>>; end$ symbolic procedure simpsys!-rdep$ %Removes dependencies which are stored on list RDEP; begin scalar u,v; if pclass=2 then<<write"Entering SIMPSYS!-RDEP"; terpri2()>>; foreach x in rdep do rmdep cdr x; u:=makeset delnil foreach x in car uhf collect ldf!-simp x; v:=foreach x in cadr uhf collect simp prepsq x; uhf:=list(u,v); if pclass=1 then begin terpri(); write"Dependencies removed"; terpri2(); foreach x in rdep do <<maprin cadr x; prin2!*" independent of "; maprin caddr x; terpri!* t;>>; terpri(); end; if pclass=2 then<<write"RDEP:='"; prettyprint rdep; terpri()>>; if pclass=2 then<<write"Leaving SIMPSYS!-RDEP"; terpri2()>>; end$ symbolic procedure simpsys!-sep$ %Performs all possible separations; if uhf and car uhf then begin scalar u,v,test; if pclass=2 then<<write"Entering SIMPSYS!-SEP"; terpri2()>>; foreach x in car uhf do if eqn(length(v:=ldf!-sep x),1) then u:=x . u else begin u:=append(v,u); if pclass=1 or pclass=2 then begin scalar z; integer l; terpri(); l:=length car uhf-length member(x,car uhf)+1; write"Equation ",l," separated into the terms"; terpri(); if pclass=1 then for k:=1:length v do begin z:=prepf nth(v,k); !*list := lengthf z geq 50; algebraic write"Term ",k," ",z; end; if pclass=2 then foreach y in v do prettyprint y; end; test:=t; end; !*list := nil; if test then uhf:=list(reverse makeset u,cadr uhf); if pclass=2 then<<write"Leaving SIMPSYS!-SEP"; terpri2()>>; end$ symbolic procedure simpsys!-sub$ %Performs all substitutions which are stored on CSUB; if uhf and car uhf then begin scalar u,v; if pclass=2 then<<write"Entering SIMPSYS!-SUB"; terpri2()>>; if pclass=1 then prrule csub; if pclass=2 then<<write"CSUB:='"; prettyprint csub; terpri()>>; u:=makeset delnil foreach x in car uhf collect ldf!-simp numr subf(x,csub); v:=foreach x in cadr uhf collect subsq(x,csub); uhf:=list(u,v); csub:=nil; if pclass=2 then<<write"Leaving SIMPSYS!-SUB"; terpri2()>>; end$ symbolic procedure simpsys$ if not uhf then rederr"The determining system is not defined" else if not car uhf then rederr"The determining system completely solved" else begin scalar u,v; integer nfun; prload(); u:=makeset delnil foreach x in car uhf collect ldf!-simp x; v:=foreach x in cadr uhf collect simp prepsq x; uhf:=list(u,v); mark0: if pclass=1 then<<prsys!*"Entering main loop">> else if pclass=2 then prtlist"Entering main loop"; czero:=csub:=rdep:=nil; simpsys!-sep(); rule0(); if czero then<<simpsys0(); go to mark0>>; if rule1() or rule1!-diff() then<<simpsys!-rdep(); go to mark0>>; if ruledf 2 or rulec 2 or rule!-int 2 or ruledf!-diff 2 or ruledf 3 or rulec 3 or rule!-int 3 or ruledf!-diff 3 or ruledf 4 or rulec 4 or rule!-int 4 or ruledf!-diff 4 or ruledf 5 or rulec 5 or rule!-int 5 or ruledf!-diff 5 then <<simpsys!-sub(); go to mark0>>; if car uhf then <<write"Determining system is not completely solved"; terpri2(); prsys!*"The remaining equations are"; if not zerop(nfun:=find!-nfun()) then write"Number of functions is ",nfun>>; end$ symbolic procedure crepol u$ begin scalar l1,f; integer pow,nfun; nfun:=find!-nfun(); l1:=cdr assoc(car(u:=cdr u),depl!*); while (u:=cdr u) do begin scalar v; v:=car u; if length u=1 or not numberp cadr u then pow:=1 else <<pow:=cadr u; u:=delete(pow,u);>>; for k:=1:pow do begin scalar w; w:=!*a2k list('c,nfun:=nfun+1); mkdep(w . delete(v,l1)); if k=1 then f:=w . f; if k=2 then f:=list('times,w,v) . f; if k geq 3 then f:=list('times,w,list('expt,v,k-1)) . f; end; end; return append('(plus),f); end$ %*************************************************************$ % Procedures for analysing the result $ %*************************************************************$ symbolic procedure cpar u$ begin scalar v; v:=makeset appends(sacar('xi,u),sacar('eta,u),sacar('c,u)); foreach x in v do if not assoc(x,depl!*) then v:=delete(x,v); return v; end$ symbolic procedure makeset!-c!-x u$ if not u then nil else if member!-c!-x(car u,cdr u) then makeset!-c!-x cdr u else car u . makeset!-c!-x cdr u$ symbolic procedure member!-c!-x(u,v)$ if not v then nil else if equal!-c!-x(u,car v) then v else member!-c!-x(u,cdr v)$ symbolic procedure equal!-c!-x(u,v)$ begin scalar p,q; p:=scar('c,u) or scar('xi,u) or scar('eta,u); q:=scar('c,v) or scar('xi,v) or scar('eta,v); return equal(subst('cxx,p,u),subst('cxx,q,v)); end$ symbolic procedure numgen$ length get('gen,'kvalue)$ symbolic operator numgen$ symbolic procedure gengen$ begin scalar u,z,cgen,dgen; integer ngen; remprop('gen,'kvalue); remprop('gen,'klist); foreach x in cadr uhf do u:=append(ldf!-fvar numr x,u); foreach x in makeset u do begin scalar v,w; w:=nil ./ 1; if assoc(x,depl!*) then v:=foreach y in cadr uhf collect simp prepsq(ldf!-fvar!-part(numr y,x) ./denr y) else v:=foreach y in cadr uhf collect simp prepsq((lcf ldf!-fvar!-part(numr y,x)) ./denr y); for k:=1:nn do if numr nth(v,k) then w:=addsq(multsq(nth(v,k),!*k2q !*a2k list('dx,k)),w); for k:=1:mm do if numr nth(v,nn+k) then w:=addsq(multsq(nth(v,nn+k),!*k2q !*a2k list('du,k)),w); if assoc(x,depl!*) then cgen:=(absf remfacn numr simp prepf numr w) . cgen else dgen:=(absf remfacn numr simp prepf numr w) . dgen; end; dgen:=makeset dgen; cgen:=makeset!-c!-x cgen; num!-dgen:=length dgen; num!-cgen:=length cgen; for k:=1:nn do if member(z:=!*k2f !*a2k list('dx,k),dgen) then <<setk(list('gen,ngen:=add1 ngen),prepf z); dgen:=delete(z,dgen)>>; for k:=1:mm do if member(z:=!*k2f !*a2k list('du,k),dgen) then <<setk(list('gen,ngen:=add1 ngen),prepf z); dgen:=delete(z,dgen)>>; dgen:=sortx(function length,dgen); foreach x in dgen do setk(list('gen,ngen:=add1 ngen),prepf x); cgen:=sortx(function length,cgen); foreach x in cgen do setk(list('gen,ngen:=add1 ngen),prepf x); end$ symbolic operator gengen$ algebraic procedure comm(a,b)$ begin scalar z; if (lisp length list!-deq)=0 then <<write"Differential equations not defined"; return nil>>; z:= (for k:=1:nn sum df(a,dx k)*df(b,x k)-df(b,dx k)*df(a,x k)) +(for k:=1:mm sum df(a,du k)*df(b,u k)-df(b,du k)*df(a,u k))$ return z; end$ algebraic procedure result$ begin integer l; if (l:=lisp length list!-deq)=1 then write"The differential equation" else write"The differential equations"; for j:=1:l do begin scalar z; integer i,k; lisp(z:=car cadadr nth(list!-deq,j)); i:=lisp cadar nth(list!-deq,j); k:=lisp lengthf prepf z; symbolic(!*list := k>40); write"DEQ(",i,"):=",lisp prepf z; end; !*list := nil; if (lisp length car uhf) neq 0 then prsys!*"The determining system is not completely solved" else <<lisp gengen(); prgen(); comm!-tab()>>; end$ %*************************************************************$ % Procedures for displaying the output $ %*************************************************************$ symbolic procedure prsys!* u$ if uhf and car uhf then <<terpri(); write u; terpri(); prsys(); terpri()>>$ symbolic procedure prsys$ begin scalar v; terpri(); remprop('gl,'kvalue); remprop('gl,'klist); for k:=1:length car uhf do begin scalar z; integer l; z:=prepf nth(car uhf,k); l:=lengthf prepf nth(car uhf,k); !*list := l>50; algebraic write"GL(",k,"):=",z; setk(list('gl,k),z); end; terpri2(); write"The remaining dependencies"; terpri2(); v:=makeset appends(sacar('xi,car uhf),sacar('eta,car uhf),sacar('c,car uhf)); foreach x in v do write!-dep x; !*list := nil; end$ symbolic procedure prrule u$ begin terpri2(); if eqn(length u,1) then write"Substitution" else write"Substitutions"; terpri2(); foreach x in u do <<maprin car x; prin2!*" = "; maprin cdr x; terpri!* t;>>; terpri(); foreach x in u do foreach y in sacar('c,cdr x) do write!-dep y; end$ symbolic procedure prtlist u$ <<write u; terpri2(); write"DEPL!*:='"; prettyprint depl!*; write"UHF:='"; prettyprint uhf>>$ symbolic procedure write!-df!-sub$ if get('df,'kvalue) then begin scalar w; w:=get('df,'kvalue); remprop('df,'kvalue); terpri(); if length w=1 then write"Constraint" else write"Constraints"; terpri2(); foreach x in w do begin scalar u,v; u:=car x; v:=cadadr x; algebraic write lisp u,":=",lisp prepsq v; terpri2(); end; put('df,'kvalue,w); end$ algebraic procedure prgen$ begin scalar lcpar; for k:=1:nn do <<order dx k; factor dx k>>; for k:=1:mm do factor du k$ lisp(lcpar:=cpar get('gen,'kvalue)); write"The symmetry generators are"; for k:=1:numgen() do if (lisp lengthf reval list('gen,k)) leq 60 then <<symbolic(!*list := nil); write"GEN(",k,"):=",gen k>> else begin scalar z; integer r,s,nt; operator gen!*; nt:=lisp length(z:=numr simp reval list('gen,k)); r:=lisp maxl foreach x in z collect abs comfacn list x; if r=1 then r:=0 else r:=lisp flatsizec r; for l:=1:nt do gen!* l:=lisp prepf list nth(z,l); for l:=1:nt do begin symbolic(!*list := lengthf prepf tc nth(z,l) geq 56); s:=lisp abs comfacn list nth(z,l); if r=0 then s:=0 else if s=1 then s:=-1 else s:=lisp flatsizec s; if l=1 then write"GEN(",k,"):=",lisp blanks(r-s+1),gen!* 1 else if minus!-f gen!* l=t then write lisp blanks(r-s+6),gen!* l else write lisp blanks(r-s+6)," + ",gen!* l; end; clear gen!*; symbolic(!*list := nil); end; if (lisp length lcpar) neq 0 then <<write"The remaining dependencies"; lisp terpri()>>; for k:=1:(lisp length lcpar) do <<lisp write!-dep nth(lcpar,k);>>; if (lisp length lcpar) neq 0 then lisp terpri(); lisp write!-df!-sub(); end$ algebraic procedure comm!-tab$ if (lisp num!-dgen) geq 2 then begin integer nd; scalar v; nd:=lisp num!-dgen; write"The non-vanishing commutators of the finite subgroup"; for i:=1:nd-1 do for j:=(i+1):nd do if(v:=comm(gen i,gen j)) neq 0 then if (lisp lengthf reval v) leq 60 then <<symbolic(!*list := nil); write"COMM(",i,",",j,"):= ",v>> else begin integer r,s,nt; scalar z; operator gen!*; nt:=lisp length(z:=numr simp reval v); r:=lisp maxl foreach x in z collect abs comfacn list x; if r=1 then r:=0 else r:=lisp flatsizec r; for i:=1:nt do gen!* i:=lisp prepf list nth(z,i); for l:=1:nt do begin symbolic(!*list := lengthf reval list('gen!*,l) geq 63); s:=lisp abs comfacn list nth(z,l); if r=0 then s:=0 else if s=1 then s:=-1 else s:=lisp flatsizec s; if l=1 then write"COMM(",i,",",j,"):=",lisp blanks(r-s+1),gen!* 1 else if minus!-f gen!* l=t then write lisp blanks(r-s+9),gen!* l else write lisp blanks(r-s+9)," + ",gen!* l; end; clear gen!*; end; symbolic(!*list := nil); end$ symbolic procedure write!-dep u$ if assoc(reval u,depl!*) then begin scalar v; v:=cdr assoc(u,depl!*); write car u,"(",cadr u,") depends on "; write caar v,"(",cadar v,")"; foreach x in cdr v do write",",car x,"(",cadr x,")"; terpri2(); end$ symbolic operator write!-dep$ symbolic procedure find!-nfun$ if not get('c,'klist) then 0 else maxl makeset foreach x in get('c,'klist) collect cadar x$ endmodule; end; |
Added r33/symget.dat version [43b2e36117].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % symget.dat (load symget) (setq &symgetsize& 32) (null (progn (install-symget 'opmtch 1) % get pseudo gets (install-symget 'stat 2) (install-symget 'infix 3) (install-symget 'newnam 4) (install-symget 'array 5) (install-symget 'alt 6) (install-symget 'polyfn 7) (install-symget 'specprn 8) (install-symget 'dname 9) (install-symget 'avalue 10) (install-symget 'formfn 11) (install-symget 'initl 12) (install-symget 'psopfn 13) (install-symget 'rtype 14) (install-symget 'prifn 15) (install-symget 'rvalue 16) (install-symget 'pprifn 17) (install-symget 'dimension 18) (install-symget 'simpfn 19) (install-symget 'klist 20) (install-symget 'rtypefn 21) (install-symget 'idvalfn 22) (install-symget 'kvalue 23) (install-symget 'switch* 24) (install-symget 'onep 25) (install-symget 'zerop 26) (install-symget 'plus 27) (install-symget 'times 28) (install-symget 'quotient 29) (install-symget 'id2 30) (install-symget 'intequivfn 31) % true flags (install-symflag 'share 0) (install-symflag 'full 1) (install-symflag 'nary 2) (install-symflag 'noncom 3) (install-symflag 'nospur 4) (install-symflag 'symmetric 5) (install-symflag 'opfn 6) (install-symflag 'nochange 7) (install-symflag 'nodel 8) (install-symflag 'noform 9) (install-symflag 'field 10) (install-symflag 'delim 11) (install-symflag 'intfn 12) (install-symflag 'noncom 13) (install-symflag 'modefn 14) (install-symflag 'convert 15) )) |
Added r33/util.red version [60e5a7157d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module cedit; % REDUCE input string editor. % Author: Anthony C. Hearn; fluid '(!*mode); global '(!$eol!$ !*blanknotok!* !*eagain !*full crbuf!* crbuf1!* crbuflis!* esc!* inputbuflis!* rprifn!* rterfn!* statcounter); %esc!* := intern ascii 125; %this is system dependent and defines %a terminator for strings. symbolic procedure rplacw(u,v); if atom u or atom v then errach list('rplacw,u,v) else rplacd(rplaca(u,car v),cdr v); symbolic procedure cedit n; begin scalar x,ochan; if null terminalp() then rederr "Edit must be from a terminal"; ochan := wrs nil; if n eq 'fn then x := reversip crbuf!* else if null n then if null crbuflis!* then <<statcounter := statcounter-1; rederr "No previous entry">> else x := cdar crbuflis!* else if (x := assoc(car n,crbuflis!*)) then x := cedit0(cdr x,car n) else <<statcounter := statcounter-1; rederr list("Entry",car n,"not found")>>; crbuf!* := nil; x := for each j in x collect j; %to make a copy. terpri(); editp x; terpri(); x := cedit1 x; wrs ochan; if x eq 'failed then nil else crbuf1!* := x end; symbolic procedure cedit0(u,n); % Returns input string augmented by appropriate mode. begin scalar x; if not(x := assoc(n,inputbuflis!*)) or ((x := cddr x) eq !*mode) then return u else return append(explode x,append(cdr explode '! ,u)) end; symbolic procedure cedit1 u; begin scalar x,y,z; z := setpchar '!>; if not !*eagain then <<prin2t "For help, type ?"; !*eagain := t>>; while u and (car u eq !$eol!$) do u := cdr u; u := append(u,list '! ); %to avoid 'last char' problem. if !*full then editp u; top: x := u; %current pointer position. a: y := readch(); %current command. if y eq 'p or y eq '!p then editp x else if y eq 'i or y eq '!i then editi x else if y eq 'c or y eq '!c then editc x else if y eq 'd or y eq '!d then editd x else if y eq 'f or y eq '!f then x := editf(x,nil) else if y eq 'e or y eq '!e then <<terpri(); editp1 u; setpchar z; return u>> else if y eq 'q or y eq '!q then <<setpchar z; return 'failed>> else if y eq '!? then edith() else if y eq 'b or y eq '!b then go to top else if y eq 'k or y eq '!k then editf(x,t) else if y eq 's or y eq '!s then x := edits x else if y eq '! and not !*blanknotok!* or y eq 'x or y eq '!x then x := editn x else if y eq '! and !*blanknotok!* then go to a else if y eq !$eol!$ then go to a else lprim!* list(y,"Invalid editor character"); go to a end; symbolic procedure editc x; if null cdr x then lprim!* "No more characters" else rplaca(x,readch()); symbolic procedure editd x; if null cdr x then lprim!* "No more characters" else rplacw(x,cadr x . cddr x); symbolic procedure editf(x,bool); begin scalar y,z; y := cdr x; z := readch(); if null y then return <<lprim!* list(z,"Not found"); x>>; while cdr y and not z eq car y do y := cdr y; return if null cdr y then <<lprim!* list(z,"Not found"); x>> else if bool then rplacw(x,car y . cdr y) else y end; symbolic procedure edith; <<prin2t "THE FOLLOWING COMMANDS ARE SUPPORTED:"; prin2t " B move pointer to beginning"; prin2t " C<character> replace next character by <character>"; prin2t " D delete next character"; prin2t " E end editing and reread text"; prin2t " F<character> move pointer to next occurrence of <character>"; prin2t " I<string><escape> insert <string> in front of pointer"; prin2t " K<character> delete all chars until <character>"; prin2t " P print string from current pointer"; prin2t " Q give up with error exit"; prin2t " S<string><escape> search for first occurrence of <string>"; prin2t " positioning pointer just before it"; prin2t " <space> or X move pointer right one character"; terpri(); prin2t "ALL COMMAND SEQUENCES SHOULD BE FOLLOWED BY A CARRIAGE RETURN"; prin2t " TO BECOME EFFECTIVE">>; symbolic procedure editi x; begin scalar y,z; while (y := readch()) neq esc!* do z := y . z; rplacw(x,nconc(reversip z,car x . cdr x)) end; symbolic procedure editn x; if null cdr x then lprim!* "NO MORE CHARACTERS" else cdr x; symbolic procedure editp u; <<editp1 u; terpri()>>; symbolic procedure editp1 u; for each x in u do if x eq !$eol!$ then terpri() else prin2 x; symbolic procedure edits u; begin scalar x,y,z; x := u; while (y := readch()) neq esc!* do z := y . z; z := reversip z; a: if null x then return <<lprim!* "not found"; u>> else if edmatch(z,x) then return x; x := cdr x; go to a end; symbolic procedure edmatch(u,v); % Matches list of characters U against V. Returns rest of V if % match occurs or NIL otherwise. if null u then v else if null v then nil else if car u=car v then edmatch(cdr u,cdr v) else nil; symbolic procedure lprim!* u; <<lprim u; terpri()>>; comment Editing Function Definitions; remprop('editdef,'stat); symbolic procedure editdef u; editdef1 car u; symbolic procedure editdef1 u; begin scalar type,x; if null(x := getd u) then return lprim list(u,"not defined") else if codep cdr x or not eqcar(cdr x,'lambda) then return lprim list(u,"cannot be edited"); type := car x; x := cdr x; if type eq 'expr then x := 'de . u . cdr x else if type eq 'fexpr then x := 'df . u . cdr x else if type eq 'macro then x := 'dm . u . cdr x else rederr list("strange function type",type); rprifn!* := 'add2buf; rterfn!* := 'addter2buf; crbuf!* := nil; x := errorset(list('rprint,mkquote x),t,nil); rprifn!* := nil; rterfn!* := nil; if errorp x then return (crbuf!* := nil); crbuf!* := cedit 'fn; return nil end; symbolic procedure add2buf u; crbuf!* := u . crbuf!*; symbolic procedure addter2buf; crbuf!* := !$eol!$ . crbuf!*; put('editdef,'stat,'rlis); comment Displaying past input expressions; put('display,'stat,'rlis); symbolic procedure display u; % Displays input stack in reverse order. % Modification to reverse list added by F. Kako. begin scalar x,w; u := car u; x := crbuflis!*; terpri(); if not numberp u then u := length x; while u>0 and x do <<w := car x . w; x := cdr x; u := u - 1>>; for each j in w do <<prin2 car j; prin2 ": "; editp cdr j; terpri()>> end; endmodule; module pretty; % Print list structures in an indented format. % Author: A. C. Norman, July 1978. fluid '(bn bufferi buffero indblanks indentlevel initialblanks lmar pendingrpars rmar rparcount stack); global '(!*quotes !*symmetric thin!*); !*symmetric := t; !*quotes := t; thin!* := 5; % This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % Functions: % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = <<superprintm(x,posn()); terpri(); terpri()>>; % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; symbolic procedure prettyprint x; << superprinm(x,posn()); %WHAT REDUCE DOES NOW; terpri(); terpri(); nil>>; symbolic procedure superprintm(x,lmar); << superprinm(x,lmar); terpri(); x >>; % From here down the functions are not intended for direct use. % The following functions are defined here in case this package % is called from LISP rather than REDUCE. symbolic procedure eqcar(a,b); pairp a and car a eq b; symbolic procedure spaces n; for i:=1:n do prin2 '! ; % End of compatibility section. symbolic procedure superprinm(x,lmar); begin scalar stack,bufferi,buffero,bn,initialblanks,rmar, pendingrpars,indentlevel,indblanks,rparcount,w; bufferi:=buffero:=list nil; %fifo buffer. initialblanks:=0; rparcount:=0; indblanks:=0; rmar:=linelength(nil)-3; %right margin. if rmar<25 then error(0,list(rmar+3, "Linelength too short for superprinting")); bn:=0; %characters in buffer. indentlevel:=0; %no indentation needed, yet. if lmar+20>=rmar then lmar:=rmar-21; %no room for specified margin. w:=posn(); if w>lmar then << terpri(); w:=0 >>; if w<lmar then initialblanks:=lmar-w; prindent(x,lmar+3); %main recursive print routine. % traverse routine finished - now tidy up buffers. overflow 'none; %flush out the buffer. return x end; % Access functions for a stack entry. smacro procedure top; car stack; smacro procedure depth frm; car frm; smacro procedure indenting frm; cadr frm; smacro procedure blankcount frm; caddr frm; smacro procedure blanklist frm; cdddr frm; smacro procedure setindenting(frm,val); rplaca(cdr frm,val); smacro procedure setblankcount(frm,val); rplaca(cddr frm,val); smacro procedure setblanklist(frm,val); rplacd(cddr frm,val); smacro procedure newframe n; list(n,nil,0); smacro procedure blankp char; numberp car char; symbolic procedure prindent(x,n); % Print list x with indentation level n. if atom x then if vectorp x then prvector(x,n) else for each c in (if !*symmetric then if stringp x then explodes x else explode x else explode2 x) do putch c else if quotep x then << putch '!'; prindent(cadr x,n+1) >> else begin scalar cx; if 4*n>3*rmar then << %list is too deep for sanity. overflow 'all; n:=n/8; if initialblanks>n then << lmar:=lmar-initialblanks+n; initialblanks:=n >> >>; stack := (newframe n) . stack; putch ('lpar . top()); cx:=car x; prindent(cx,n+1); if idp cx and not atom cdr x then cx:=get(cx,'ppformat) else cx:=nil; if cx=2 and atom cddr x then cx:=nil; if cx='prog then << putch '! ; prindent(car (x:=cdr x),n+3) >>; % CX now controls the formatting of what follows: % nil default action % <number> first few blanks are non-indenting % prog display atoms as labels. x:=cdr x; scan: if atom x then go to outt; finishpending(); %about to print a blank. if cx='prog then << putblank(); overflow bufferi; %force format for prog. if atom car x then << % a label. lmar:=initialblanks:=max(lmar-6,0); prindent(car x,n-3); % print the label. x:=cdr x; if not atom x and atom car x then go to scan; if lmar+bn>n then putblank() else for i:=lmar+bn:n-1 do putch '! ; if atom x then go to outt>> >> else if numberp cx then << cx:=cx-1; if cx=0 then cx:=nil; putch '! >> else putblank(); prindent(car x,n+3); x:=cdr x; go to scan; outt: if not null x then << finishpending(); putblank(); putch '!.; putch '! ; prindent(x,n+5) >>; putch ('rpar . (n-3)); if indenting top()='indent and not null blanklist top() then overflow car blanklist top() else endlist top(); stack:=cdr stack end; symbolic procedure explodes x; %dummy function just in case another format is needed. explode x; symbolic procedure prvector(x,n); begin scalar bound; bound:=upbv x; % length of the vector. stack:=(newframe n) . stack; putch ('lsquare . top()); prindent(getv(x,0),n+3); for i:=1:bound do << putch '!,; putblank(); prindent(getv(x,i),n+3) >>; putch('rsquare . (n-3)); endlist top(); stack:=cdr stack end; symbolic procedure putblank(); begin putch top(); %represents a blank character. setblankcount(top(),blankcount top()+1); setblanklist(top(),bufferi . blanklist top()); %remember where I was. indblanks:=indblanks+1 end; symbolic procedure endlist l; %Fix up the blanks in a complete list so that they %will not be turned into indentations. pendingrpars:=l . pendingrpars; % When I have printed a ')' I want to mark all of the blanks % within the parentheses as being unindented, ordinary blank % characters. It is however possible that I may get a buffer % overflow while printing a string of )))))))))), and so this % marking should be delayed until I get round to printing % a further blank (which will be a candidate for a place to % split lines). This delay is dealt with by the list % pendingrpars which holds a list of levels that, when % convenient, can be tidied up and closed out. symbolic procedure finishpending(); << for each stackframe in pendingrpars do << if indenting stackframe neq 'indent then for each b in blanklist stackframe do << rplaca(b,'! ); indblanks:=indblanks-1 >>; % blanklist of stackframe must be non-nil so that overflow % will not treat the '(' specially. setblanklist(stackframe,t) >>; pendingrpars:=nil >>; symbolic procedure quotep x; !*quotes and not atom x and car x='quote and not atom cdr x and null cddr x; % property ppformat drives the prettyprinter - % prog : special for prog only % 1 : (fn a1 % a2 % ... ) % 2 : (fn a1 a2 % a3 % ... ) ; put('prog,'ppformat,'prog); put('lambda,'ppformat,1); put('lambdaq,'ppformat,1); put('setq,'ppformat,1); put('set,'ppformat,1); put('while,'ppformat,1); put('t,'ppformat,1); put('de,'ppformat,2); put('df,'ppformat,2); put('dm,'ppformat,2); put('foreach,'ppformat,4); % (foreach x in y do ...) etc. % Now for the routines that buffer things on a character by character % basis, and deal with buffer overflow. symbolic procedure putch c; begin if atom c then rparcount:=0 else if blankp c then << rparcount:=0; go to nocheck >> else if car c='rpar then << rparcount:=rparcount+1; % format for a long string of rpars is: % )))) ))) ))) ))) ))) ; if rparcount>4 then << putch '! ; rparcount:=2 >> >> else rparcount:=0; while lmar+bn>=rmar do overflow 'more; nocheck: bufferi:=cdr rplacd(bufferi,list c); bn:=bn+1 end; symbolic procedure overflow flg; begin scalar c,blankstoskip; %the current buffer holds so much information that it will %not all fit on a line. try to do something about it. % flg is one of: % 'none do not force more indentation % 'more force one level more indentation % <a pointer into the buffer> % prints up to and including that character, which % should be a blank. if indblanks=0 and initialblanks>3 and flg='more then << initialblanks:=initialblanks-3; lmar:=lmar-3; return 'moved!-left >>; fblank: if bn=0 then << % No blank found - can do no more for now. % If flg='more I am in trouble and so have to print % a continuation mark. in the other cases I can just exit. if not(flg = 'more) then return 'empty; if atom car buffero then % continuation mark not needed if last char printed was % special (e.g. lpar or rpar). prin2 "%+"; %continuation marker. terpri(); lmar:=0; return 'continued >> else << spaces initialblanks; initialblanks:=0 >>; buffero:=cdr buffero; bn:=bn-1; lmar:=lmar+1; c:=car buffero; if atom c then << prin2 c; go to fblank >> else if blankp c then if not atom blankstoskip then << prin2 '! ; indblanks:=indblanks-1; % blankstoskip = (stack-frame . skip-count). if c eq car blankstoskip then << rplacd(blankstoskip,cdr blankstoskip-1); if cdr blankstoskip=0 then blankstoskip:=t >>; go to fblank >> else go to blankfound else if car c='lpar or car c='lsquare then << prin2 get(car c,'ppchar); if flg='none then go to fblank; % now I want to flag this level for indentation. c:=cdr c; %the stack frame. if not null blanklist c then go to fblank; if depth c>indentlevel then << %new indentation. % this level has not emitted any blanks yet. indentlevel:=depth c; setindenting(c,'indent) >>; go to fblank >> else if car c='rpar or car c='rsquare then << if cdr c<indentlevel then indentlevel:=cdr c; prin2 get(car c,'ppchar); go to fblank >> else error(0,list(c,"UNKNOWN TAG IN OVERFLOW")); blankfound: if eqcar(blanklist c,buffero) then setblanklist(c,nil); % at least one entry on blanklist ought to be valid, so if I % print the last blank I must kill blanklist totally. indblanks:=indblanks-1; % check if next level represents new indentation. if depth c>indentlevel then << if flg='none then << %just print an ordinary blank. prin2 '! ; go to fblank >>; % here I increase the indentation level by one. if blankstoskip then blankstoskip:=nil else << indentlevel:=depth c; setindenting(c,'indent) >> >>; %otherwise I was indenting at that level anyway. if blankcount c>(thin!*-1) then << %long thin list fix-up here. blankstoskip:=c . ((blankcount c) - 2); setindenting(c,'thin); setblankcount(c,1); indentlevel:=(depth c)-1; prin2 '! ; go to fblank >>; setblankcount(c,(blankcount c)-1); terpri(); lmar:=initialblanks:=depth c; if buffero eq flg then return 'to!-flg; if blankstoskip or not (flg='more) then go to fblank; % keep going unless call was of type 'more'. return 'more; %try some more. end; put('lpar,'ppchar,'!(); put('lsquare,'ppchar,'![); put('rpar,'ppchar,'!)); put('rsquare,'ppchar,'!]); endmodule; module rprint; % The Standard LISP to REDUCE pretty-printer. % Author: Anthony C. Hearn. fluid '(!*n buffp combuff curmark curpos orig pretop pretoprinf rmar); global '(rprifn!* rterfn!*); comment RPRIFN!* allows output from RPRINT to be handled differently, RTERFN!* allows end of lines to be handled differently; pretop := 'op; pretoprinf := 'oprinf; symbolic procedure rprint u; begin integer !*n; scalar buff,buffp,curmark,rmar,x; curmark := 0; buff := buffp := list list(0,0); rmar := linelength nil; x := get('!*semicol!*,pretop); !*n := 0; mprino1(u,list(caar x,cadar x)); prin2ox ";"; omarko curmark; prinos buff end; symbolic procedure rprin1 u; begin scalar buff,buffp,curmark,x; curmark := 0; buff := buffp := list list(0,0); x := get('!*semicol!*,pretop); mprino1(u,list(caar x,cadar x)); omarko curmark; prinos buff end; symbolic procedure mprino u; mprino1(u,list(0,0)); symbolic procedure mprino1(u,v); begin scalar x; if x := atsoc(u,combuff) then <<for each y in cdr x do comprox y; combuff := delete(x,combuff)>>; if numberp u and u<0 and (x := get('difference,pretop)) then return begin scalar p; x := car x; p := (not car x>cadr v) or (not cadr x>car v); if p then prin2ox "("; prinox u; if p then prinox ")" end else if atom u then return prinox u else if not atom car u then <<curmark := curmark+1; prin2ox "("; mprino car u; prin2ox ")"; omark list(curmark,3); curmark := curmark-1>> else if x := get(car u,pretoprinf) then return begin scalar p; p := car v>0 and not car u memq '(block procedure prog quote string); if p then prin2ox "("; apply(x,list cdr u); if p then prin2ox ")" end else if x := get(car u,pretop) then return if car x then inprinox(u,car x,v) else if cddr u then rederr "Syntax error" else if null cadr x then inprinox(u,list(100,1),v) else inprinox(u,list(100,cadr x),v) else prinox car u; if rlistatp car u then return rlpri cdr u; u := cdr u; if null u then prin2ox "()" else mprargs(u,v) end; symbolic procedure mprargs(u,v); if null cdr u then <<prin2ox " "; mprino1(car u,list(100,100))>> else inprinox('!*comma!* . u,list(0,0),v); symbolic procedure inprinox(u,x,v); begin scalar p; p := (not car x>cadr v) or (not cadr x>car v); if p then prin2ox "("; omark '(m u); inprino(car u,x,cdr u); if p then prin2ox ")"; omark '(m d) end; symbolic procedure inprino(opr,v,l); begin scalar flg,x; curmark := curmark+2; x := get(opr,pretop); if x and car x then <<mprino1(car l,list(car v,0)); l := cdr l; flg := t>>; while l do <<if opr eq '!*comma!* then <<prin2ox ","; omarko curmark>> else if opr eq 'setq then <<prin2ox " := "; omark list(curmark,1)>> else if atom car l or not opr eq get!*(caar l,'alt) then <<omark list(curmark,1); oprino(opr,flg); flg := t>>; mprino1(car l,list(if null cdr l then 0 else car v, if null flg then 0 else cadr v)); l := cdr l>>; curmark := curmark-2 end; symbolic procedure oprino(opr,b); (lambda x; if null x then <<if b then prin2ox " "; prinox opr; prin2ox " ">> else prin2ox x) get(opr,'prtch); symbolic procedure prin2ox u; <<rplacd(buffp,explode2 u); while cdr buffp do buffp := cdr buffp>>; symbolic procedure explode2 u; % "explodes" atom U without including escape characters; if numberp u then explode u else if stringp u then reversip cdr reversip cdr explode u else explode21 explode u; symbolic procedure explode21 u; if null u then nil else if car u eq '!! then cadr u . explode21 cddr u else car u . explode21 cdr u; symbolic procedure prinox u; <<rplacd(buffp,explode u); while cdr buffp do buffp := cdr buffp>>; symbolic procedure omark u; <<rplacd(buffp,list u); buffp := cdr buffp>>; symbolic procedure omarko u; omark list(u,0); symbolic procedure comprox u; begin scalar x; if car buffp = '(0 0) then return <<for each j in u do prin2ox j; omark '(0 0)>>; x := car buffp; rplaca(buffp,list(curmark+1,3)); for each j in u do prin2ox j; omark x end; symbolic procedure rlistatp u; get(u,'stat) member '(endstat rlis); symbolic procedure rlpri u; if null u then nil else begin prin2ox " "; omark '(m u); inprino('!*comma!*,list(0,0),u); omark '(m d) end; symbolic procedure condox u; begin scalar x; omark '(m u); curmark := curmark+2; while u do <<prin2ox "IF "; mprino caar u; omark list(curmark,1); prin2ox " THEN "; if cdr u and eqcar(cadar u,'cond) and not eqcar(car reverse cadar u,'t) then <<x := t; prin2ox "(">>; mprino cadar u; if x then prin2ox ")"; u := cdr u; if u then <<omarko(curmark-1); prin2ox " ELSE ">>; if u and null cdr u and caar u eq 't then <<mprino cadar u; u := nil>>>>; curmark := curmark-2; omark '(m d) end; put('cond,pretoprinf,'condox); symbolic procedure blockox u; begin omark '(m u); curmark := curmark+2; prin2ox "BEGIN "; if car u then varprx car u; u := labchk cdr u; omark list(curmark,if eqcar(car u,'!*label) then 1 else 3); while u do <<mprino car u; if not eqcar(car u,'!*label) and cdr u then prin2ox "; "; u := cdr u; if u then omark list(curmark, if eqcar(car u,'!*label) then 1 else 3)>>; omark list(curmark-1,-1); prin2ox " END"; curmark := curmark-2; omark '(m d) end; symbolic procedure retox u; begin omark '(m u); curmark := curmark+2; prin2ox "RETURN "; omark '(m u); mprino car u; curmark := curmark-2; omark '(m d); omark '(m d) end; put('return,pretoprinf,'retox); % symbolic procedure varprx u; % mapc(cdr u,function (lambda j; % <<prin2ox car j; % prin2ox " "; % inprino('!*comma!*,list(0,0),cdr j); % prin2ox "; "; % omark list(curmark,6)>>)); comment a version for the old parser; symbolic procedure varprx u; begin scalar typ; u := reverse u; while u do <<if cdar u eq typ then <<prin2ox ","; omarko(curmark+1); prinox caar u>> else <<if typ then <<prin2ox "; "; omark '(m d)>>; prinox (typ := cdar u); prin2ox " "; omark '(m u); prinox caar u>>; u := cdr u>>; prin2ox "; "; omark '(m d) end; put('block,pretoprinf,'blockox); symbolic procedure progox u; blockox(mapcar(reverse car u,function (lambda j; j . 'scalar)) . cdr u); symbolic procedure labchk u; begin scalar x; for each z in u do if atom z then x := list('!*label,z) . x else x := z . x; return reversip x end; put('prog,pretoprinf,'progox); symbolic procedure gox u; <<prin2ox "GO TO "; prinox car u>>; put('go,pretoprinf,'gox); symbolic procedure labox u; <<prinox car u; prin2ox ": ">>; put('!*label,pretoprinf,'labox); symbolic procedure quotox u; if stringp u then prinox u else <<prin2ox "'"; prinsox car u>>; symbolic procedure prinsox u; if atom u then prinox u else <<prin2ox "("; omark '(m u); curmark := curmark+1; while u do <<prinsox car u; u := cdr u; if u then <<omark list(curmark,-1); if atom u then <<prin2ox " . "; prinsox u; u := nil>> else prin2ox " ">>>>; curmark := curmark-1; omark '(m d); prin2ox ")">>; put('quote,pretoprinf,'quotox); symbolic procedure prognox u; begin curmark := curmark+1; prin2ox "<<"; omark '(m u); while u do <<mprino car u; u := cdr u; if u then <<prin2ox "; "; omarko curmark>>>>; omark '(m d); prin2ox ">>"; curmark := curmark-1 end; put('prog2,pretoprinf,'prognox); put('progn,pretoprinf,'prognox); symbolic procedure repeatox u; begin curmark := curmark+1; omark '(m u); prin2ox "REPEAT "; mprino car u; prin2ox " UNTIL "; omark list(curmark,3); mprino cadr u; omark '(m d); curmark := curmark-1 end; put('repeat,pretoprinf,'repeatox); symbolic procedure whileox u; begin curmark := curmark+1; omark '(m u); prin2ox "WHILE "; mprino car u; prin2ox " DO "; omark list(curmark,3); mprino cadr u; omark '(m d); curmark := curmark-1 end; put('while,pretoprinf,'whileox); symbolic procedure procox u; begin omark '(m u); curmark := curmark+1; if cadddr cdr u then <<mprino cadddr cdr u; prin2ox " ">>; prin2ox "PROCEDURE "; procox1(car u,cadr u,caddr u) end; symbolic procedure procox1(u,v,w); begin prinox u; if v then mprargs(v,list(0,0)); prin2ox "; "; omark list(curmark,3); mprino w; curmark := curmark-1; omark '(m d) end; put('proc,pretoprinf,'procox); symbolic procedure proceox u; begin omark '(m u); curmark := curmark+1; if cadr u then <<mprino cadr u; prin2ox " ">>; if not caddr u eq 'expr then <<mprino caddr u; prin2ox " ">>; prin2ox "PROCEDURE "; proceox1(car u,cadddr u,car cddddr u) end; symbolic procedure proceox1(u,v,w); begin prinox u; if v then <<if not atom car v then v:= for each j in v collect car j; %allows for typing to be included with proc arguments; mprargs(v,list(0,0))>>; prin2ox "; "; omark list(curmark,3); mprino w; curmark := curmark -1; omark '(m d) end; put('procedure,pretoprinf,'proceox); symbolic procedure proceox0(u,v,w,x); proceox list(u,'symbolic,v, mapcar(w,function (lambda j; j . 'symbolic)),x); symbolic procedure deox u; proceox0(car u,'expr,cadr u,caddr u); put('de,pretoprinf,'deox); symbolic procedure dfox u; proceox0(car u,'fexpr,cadr u,caddr u); %put('df,pretoprinf,'dfox); %commented out because of confusion with %differentiation; symbolic procedure stringox u; <<prin2ox '!"; prin2ox car u; prin2ox '!">>; put('string,pretoprinf,'stringox); symbolic procedure lambdox u; begin omark '(m u); curmark := curmark+1; procox1('lambda,car u,cadr u) end; put('lambda,pretoprinf,'lambdox); symbolic procedure eachox u; <<prin2ox "FOR EACH "; while cdr u do <<mprino car u; prin2ox " "; u := cdr u>>; mprino car u>>; put('foreach,pretoprinf,'eachox); symbolic procedure forox u; begin curmark := curmark+1; omark '(m u); prin2ox "FOR "; mprino car u; prin2ox " := "; mprino caadr u; if cadr cadr u neq 1 then <<prin2ox " STEP "; mprino cadr cadr u; prin2ox " UNTIL ">> else prin2ox ":"; mprino caddr cadr u; prin2ox " "; mprino caddr u; prin2ox " "; omark list(curmark,3); mprino cadddr u; omark '(m d); curmark := curmark-1 end; put('for,pretoprinf,'forox); symbolic procedure forallox u; begin curmark := curmark+1; omark '(m u); prin2ox "FOR ALL "; inprino('!*comma!*,list(0,0),car u); if cadr u then <<omark list(curmark,3); prin2ox " SUCH THAT "; mprino cadr u>>; prin2ox " "; omark list(curmark,3); mprino caddr u; omark '(m d); curmark := curmark-1 end; put('forall,pretoprinf,'forallox); comment Declarations needed by old parser; if null get('!*semicol!*,'op) then <<put('!*semicol!*,'op,'((-1 0))); put('!*comma!*,'op,'((5 6)))>>; comment RPRINT MODULE, Part 2; fluid '(orig curpos); symbolic procedure prinos u; begin integer curpos; scalar orig; orig := list posn(); curpos := car orig; prinoy(u,0); terpri0x() end; symbolic procedure prinoy(u,n); begin scalar x; if car(x := spaceleft(u,n)) then return prinom(u,n) else if null cdr x then return if car orig<10 then prinom(u,n) else <<orig := 9 . cdr orig; terpri0x(); spaces20x(curpos := 9+cadar u); prinoy(u,n)>> else begin a: u := prinoy(u,n+1); if null cdr u or caar u<=n then return; terpri0x(); spaces20x(curpos := car orig+cadar u); go to a end; return u end; symbolic procedure spaceleft(u,mark); %U is an expanded buffer of characters delimited by non-atom marks %of the form: '(M ...) or '(INT INT)) %MARK is an integer; begin integer n; scalar flg,mflg; n := rmar - curpos; u := cdr u; %move over the first mark; while u and not flg and n>=0 do <<if atom car u then n := n-1 else if caar u eq 'm then nil else if mark>=caar u then <<flg := t; u := nil . u>> else mflg := t; u := cdr u>>; return ((n>=0) . mflg) end; symbolic procedure prinom(u,mark); begin integer n; scalar flg,x; n := curpos; u := cdr u; while u and not flg do <<if atom car u then <<x := prin20x car u; n := n+1>> else if caar u eq 'm then if cadar u eq 'u then orig := n . orig else orig := cdr orig else if mark>=caar u and not(x='!, and rmar-n-6>charspace(u,x,mark)) then <<flg := t; u := nil . u>>; u := cdr u>>; curpos := n; if mark=0 and cdr u then <<terpri0x(); terpri0x(); orig := list 0; curpos := 0; prinoy(u,mark)>>; %must be a top level constant; return u end; symbolic procedure charspace(u,char,mark); %determines if there is space until the next character CHAR; begin integer n; n := 0; while u do <<if car u = char then u := list nil else if atom car u then n := n+1 else if car u='(m u) then <<n := 1000; u := list nil>> else if numberp caar u and caar u<mark then u := list nil; u := cdr u>>; return n end; symbolic procedure spaces20x n; %for i := 1:n do prin20x '! ; while n>0 do <<prin20x '! ; n := n-1>>; symbolic procedure prin2rox u; begin integer m,n; scalar x,y; m := rmar-12; n := rmar-1; while u do if car u eq '!" then <<if not stringspace(cdr u,n-!*n) then <<terpri0x(); !*n := 0>> else nil; prin20x '!"; u := cdr u; while not car u eq '!" do <<prin20x car u; u := cdr u; !*n := !*n+1>>; prin20x '!"; u := cdr u; !*n := !*n+2; x := y := nil>> else if atom car u and not(car u eq '! and (!*n=0 or null x or cdr u and breakp cadr u or breakp x and not y eq '!!)) then <<y := x; prin20x(x := car u); !*n := !*n+1; u := cdr u; if !*n=n or !*n>m and not breakp car u and nospace(u,n-!*n) then <<terpri0x(); x := y := nil>> else nil>> else u := cdr u end; symbolic procedure nospace(u,n); if n<1 then t else if null u then nil else if not atom car u then nospace(cdr u,n) else if not car u eq '!! and (cadr u eq '! or breakp cadr u) then nil else nospace(cdr u,n-1); symbolic procedure breakp u; u member '(!< !> !; !: != !) !+ !- !, !' !"); symbolic procedure stringspace(u,n); if n<1 then nil else if car u eq '!" then t else stringspace(cdr u,n-1); comment Some interfaces needed; symbolic procedure prin20x u; if rprifn!* then apply(rprifn!*,list u) else prin2 u; symbolic procedure terpri0x; if rterfn!* then apply(rterfn!*,nil) else terpri(); endmodule; end; |
Added r34.1/README version [ccdf66d6c9].
> > > > | 1 2 3 4 | The "plot" directory seems to contain a set of files relating to "gnuplot". They may be distributed IF UNCHANGED (and I believe that the copies here are unaltered from the original versions). |
Added r34.1/doc/addendum.tex version [a622098877].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt]{article} \parindent 0pt \parskip 6pt \raggedbottom \newlength{\reduceboxwidth} \setlength{\reduceboxwidth}{4in} \newlength{\redboxwidth} \setlength{\redboxwidth}{3.5in} \newlength{\rboxwidth} \setlength{\rboxwidth}{2.6in} \newcommand{\REDUCE}{REDUCE} \newcommand{\RLISP}{RLISP} \newcommand{\ttindex}[1]{\index{#1@{\tt #1}}} \newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }} % Close up default vertical spacings: \setlength{\topsep}{0.5\baselineskip} % above and below environments \setlength{\itemsep}{\topsep} \setlength{\abovedisplayskip}{\topsep} % for "long" equations \setlength{\belowdisplayskip}{\topsep} \pagestyle{headings} \begin{document} % \pagestyle{empty} % \vspace*{\fill} \begin{center} {\LARGE\bf Addendum to the \\[0.4cm] \Huge\bf {\REDUCE}} \\[0.1cm] {\LARGE\bf User's Manual\vspace{0.3cm} \\ for Version 3.4.1} \vspace{0.1in}\large\bf Anthony C.\ Hearn \\ RAND \\ Santa Monica, CA 90407-2138 \vspace{0.1in} \bf Email: reduce@rand.org \vspace{0.1in} \large\bf July 1992 \vspace*{0.2in} \end{center} %\pagestyle{headings} %\setcounter{page}{1} \section{Introduction} The major purpose of the 3.4.1 release is to correct various bugs and deficiencies in the former version. In addition, the following capabilities have been augmented or changed: \section{SOLVE} A number of changes have been made in the {\tt SOLVE} package in order to improve its effectiveness. \subsection{Improved Handling of Undetermined Solutions} The {\tt SOLVE} package has been modified so that when a solution cannot be found, an equation for the relevant indeterminates is normally returned in terms of a new operator {\tt ROOT\_OF}, rather than an equation in terms of unknown expressions. For example, the expression \begin{verbatim} solve(cos(x) + log(x),x); \end{verbatim} now returns the result \begin{verbatim} {X=ROOT_OF(COS(X_) + LOG(X_),X_)} \end{verbatim} rather than \begin{verbatim} {COS(X) + LOG(X)=0} . \end{verbatim} This makes the form of the {\tt SOLVE} output much more uniform, thus allowing for its easier manipulation by other operators. An expression with a top-level {\tt ROOT\_OF} operator is implicitly a list with an unknown number of elements (since we can't always know how many solutions an equation has). If a substitution is made into such an expression, closed form solutions can emerge. If this occurs, the {\tt ROOT\_OF construct} is replaced by an operator {\tt ONE\_OF}. At this point it is of course possible to transform the result of the original {\tt SOLVE} operator expression into a standard {\tt SOLVE} solution. To effect this, an operator {\tt EXPAND\_CASES} can be used. The following complete example shows the use of these facilities: \begin{verbatim} solve({1-c*x1+x1*x2^2, 1-c*x2+x2*x1^2}, {x1,x2}); 3 SQRT(4*C + 1) + 1 {{X2=--------------------, 2*C 3 - SQRT(4*C + 1) + 1 X1=-----------------------}, 2*C 3 - SQRT(4*C + 1) + 1 {X2=-----------------------, 2*C 3 SQRT(4*C + 1) + 1 X1=--------------------}, 2*C 3 {X2=ROOT_OF(C*X2____ - X2____ - 1,X2____), X1=X2}} sub(c=2,ws); SQRT(33) + 1 {{X2=--------------, 4 - SQRT(33) + 1 X1=-----------------}, 4 - SQRT(33) + 1 {X2=-----------------, 4 SQRT(33) + 1 X1=--------------}, 4 1/2 1/2 - 5 - 1 5 - 1 {X2=ONE_OF(-------------,----------,1), 2 2 X1=X2}} expand_cases ws; SQRT(33) + 1 - SQRT(33) + 1 {{X2=--------------,X1=-----------------}, 4 4 - SQRT(33) + 1 SQRT(33) + 1 {X2=-----------------,X1=--------------}, 4 4 - SQRT(5) - 1 - SQRT(5) - 1 {X2=----------------,X1=----------------}, 2 2 SQRT(5) - 1 SQRT(5) - 1 {X2=-------------,X1=-------------}, 2 2 {X2=1,X1=1}} \end{verbatim} \subsection{Improved Handling of Cubics and Quartics} Since roots of cubics and quartics can often be very messy, a switch {\tt FULLROOTS} has been added, which, when off (the default), will prevent the production of a result in closed form. The {\tt ROOT\_OF} construct will be used in this case instead. Finally, the code for the production of solutions of cubics and quartics has been modified so that trigonometrical forms are used where appropriate. This option is under the control of a switch {\tt TRIGFORM}, which is normally on. The following example illustrates the use of these facilities: \begin{verbatim} let xx = solve(x^3+x+1,x); xx; 3 {X=ROOT_OF(X_ + X_ + 1,X_)} on fullroots; xx; - SQRT(31)*I ATAN(---------------) 3*SQRT(3) {X=(I*(SQRT(3)*SIN(-----------------------) 3 - SQRT(31)*I ATAN(---------------) 3*SQRT(3) - COS(-----------------------)))/SQRT(3), 3 - SQRT(31)*I ATAN(---------------) 3*SQRT(3) X=( - I*(SQRT(3)*SIN(-----------------------) 3 - SQRT(31)*I ATAN(---------------) 3*SQRT(3) + COS(-----------------------)))/SQRT( 3 3), - SQRT(31)*I ATAN(---------------) 3*SQRT(3) 2*COS(-----------------------)*I 3 X=----------------------------------} SQRT(3) off trigform; xx; 2/3 {X=( - (SQRT(31) - 3*SQRT(3)) *SQRT(3)*I 2/3 2/3 - (SQRT(31) - 3*SQRT(3)) - 2 *SQRT(3)*I 2/3 1/3 1/3 + 2 )/(2*(SQRT(31) - 3*SQRT(3)) *6 1/6 *3 ), 2/3 X=((SQRT(31) - 3*SQRT(3)) *SQRT(3)*I 2/3 2/3 - (SQRT(31) - 3*SQRT(3)) + 2 *SQRT(3)*I 2/3 1/3 1/3 + 2 )/(2*(SQRT(31) - 3*SQRT(3)) *6 1/6 *3 ), 2/3 2/3 (SQRT(31) - 3*SQRT(3)) - 2 X=-------------------------------------} 1/3 1/3 1/6 (SQRT(31) - 3*SQRT(3)) *6 *3 \end{verbatim} \newpage \section{New Operators} In addition to the operators ONE\_OF and ROOT\_OF described above, the following new operator is available in REDUCE 3.4.1: \subsection{ROOT\_VAL Operator} The {\tt ROOT\_VAL} operator takes a single univariate polynomial as argument, and returns a list of root values at system precision (or greater if required to separate roots). It is used with the syntax \begin{verbatim} ROOT_VAL(EXPRN:univariate polynomial):list. \end{verbatim} For example, the sequence \begin{verbatim} on rounded; root_val(x^3-x-1); \end{verbatim} gives the result \begin{verbatim} {0.562279512062*I - 0.662358978622, - 0.562279512062*I - 0.662358978622,1.32471795724} \end{verbatim} \section{New Switches} In many cases it is desirable to expand product arguments of logarithms, or collect a sum of logarithms into a single logarithm. Since these are inverse operations, it is not possible to provide rules for doing both at the same time and preserve the {\REDUCE} concept of idempotent evaluation. As an alternative, REDUCE 3.4.1 provides two switches {\tt EXPANDLOGS} and {\tt COMBINELOGS} to carry out these operations. Both are off by default. Thus to expand {\tt LOG(X*Y)} into a sum of logs, one can say \begin{verbatim} ON EXPANDLOGS; LOG(X*Y); \end{verbatim} and to combine this sum into a single log: \begin{verbatim} ON COMBINELOGS; LOG(X) + LOG(Y); \end{verbatim} At the present time, it is possible to have both switches on at once, which could lead to infinite recursion. However, an expression is switched from one form to the other in this case. Users should not rely on this behavior, since it may change in the next release. \section{User-Contributed Library Packages} The following packages, not directly supported by the REDUCE distributors, are contained in the REDUCE 3.4.1 user library. Please consult the {\tt lib} directory for a detailed description of their functionality. Any questions regarding them should be directed to the relevant author(s). \begin{itemize} \item{ASSIST: Useful utilities for various applications} Author: Hubert Caprasse. \item{CAMAL: Calculations in celestial mechanics} Author: John P. Fitch \item{CHANGEVAR: Change of Independent Variable(s) in DEs} Author: G. \"{U}\c{c}oluk \item{CVIT: Fast Calculation of Dirac Gamma matrices traces} Authors: V.Ilyin, A.Kryukov, A.Rodionov, A.Taranov \item{DESIR: Differential linear homogenous Equation Solutions in the neighbourhood of Irregular and Regular singular points} Authors: C. Dicrescenzo, F. Richard-Jung, E. Tournier \item{FIDE: Finite difference method for partial differential equations} Author: Richard Liska \item{GNUPLOT: Using the GNUPLOT package for REDUCE graphical output} Author: Herbert Melenk \item{LAPLACE: Laplace and inverse Laplace transform} Author: C. Kazasov, M. Spiridonova, V. Tomov \item{LININEQ: Solving systems of linear inequalities} Author: Herbert Melenk \item{NUMERIC: Basic algorithms for numerical problems using rounded mode} Author: Herbert Melenk \item{PHYSOP: Package for Operator Calculus in Quantum Theory} Author: Mathias Warns \item{PM: A REDUCE Pattern Matcher} Author: Kevin McIsaac \item{REACTEQN: Support for chemical reaction equation systems} Author: Herbert Melenk \item{RLFI: REDUCE LATEX Formula Interface} Author: Richard Liska \item{SYMMETRY: Symmetry-adapted bases and block diagonal forms of symmetric matrices} Author: Karin Gatermann \item{TRI: TeX REDUCE Interface} Author: Werner Antweiler \item{WU: Wu Algorithm for polynomial systems} Author: Russell Bradford \end{itemize} \end{document} |
Added r34.1/doc/arnum.bib version [286098fe49].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % Bibliography entry for arnum.tex. @INPROCEEDINGS{Bradford:86, AUTHOR = "R. J. Bradford and A. C. Hearn and J. A. Padget and E. Schr{\"u}fer", TITLE = "Enlarging the {REDUCE} Domain of Computation", BOOKTITLE = "Proceedings of {SYMSAC} '86", YEAR = 1986, PAGES = "100-106"} @INPROCEEDINGS{Trager:76, AUTHOR = "B. M. Trager", TITLE = "Algebraic Factoring and Rational Function Integration", BOOKTITLE = "Proceedings of {SYMSAC} '76", YEAR = 1976, PAGES = "196-208"} @INCOLLECTION{Davenport:81, AUTHOR = "James Harold Davenport", TITLE = "On the Integration of Algebraic Functions", BOOKTITLE = "Lecture Notes in Computer Science", PUBLISHER = "Springer Verlag", VOLUME = 102, YEAR = 1981} |
Added r34.1/doc/arnum.tex version [280481b037].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{Algebraic Number Fields} \date{} \author{Eberhard Schr\"{u}fer \\ GMD, Institut F1 \\ Postfach 1240 \\ 5205 St. Augustin \\ GERMANY \\[0.05in] Email: schrufer@gmdzi.gmd.de} \begin{document} \maketitle \index{algebraic number fields} \index{algebraic numbers} \index{ARNUM package} Algebraic numbers are the solutions of an irreducible polynomial over some ground domain. \index{i} The algebraic number $i$ (imaginary unit), \index{imaginary unit} for example, would be defined by the polynomial $i^2 + 1$. The arithmetic of algebraic number $s$ can be viewed as a polynomial arithmetic modulo the defining polynomial. Given a defining polynomial for an algebraic number $a$ \begin{eqnarray*} a^n ~ + ~ {p _{n-1}} {a ^ {n -1}} ~ + ~ ... ~ + ~ {p_0} \end{eqnarray*} All algebraic numbers which can be built up from $a$ are then of the form: \begin{eqnarray*} {r_{n-1}} {a ^{n-1}} ~+~ {r_{n-2}} {a ^{n-2}} ~+~ ... ~+~ {r_0} \end{eqnarray*} where the $r_j$'s are rational numbers. \index{+ ! algebraic numbers} The operation of addition is defined by \begin{eqnarray*} ({r_{n-1}} {a ^{n-1}} ~+~ {r_{n-2}} {a ^{n-2}} ~+~ ...) ~ + ~ ({s_{n-1}} {a ^{n-1}} ~+~ {s_{n-2}} {a ^{n-2}} ~+~ ...) ~ = \\ ({r_{n-1}+s_{n-1}}) {a ^{n-1}} ~+~ ({r_{n-2}+s_{n-2}}) {a ^{n-2}} ~+~ ... \end{eqnarray*} \index{* ! algebraic numbers} Multiplication of two algebraic numbers can be performed by normal polynomial multiplication followed by a reduction of the result with the help of the defining polynomial. \begin{eqnarray*} ({r_{n-1}} {a ^{n-1}} + {r_{n-2}} {a ^{n-2}} + ...) ~ \times ~ ({s_{n-1}} {a ^{n-1}} + {s_{n-2}} {a ^{n-2}} + ...) = \\ {r_{n-1}} {s ^{n-1}}{a^{2n-2}} + ... ~ {\bf modulo} ~ a^n ~ + ~ {p _{n-1}} {a ^ {n -1}} ~ + ~ ... ~ + ~ {p_0} \\ = ~~~{q_{n-1}} a^{n-1} ~ + ~ {q _{n-2}} {a ^ {n -2}} ~ + ~ ... \end{eqnarray*} \index{/ ! algebraic numbers} Division of two algebraic numbers r and s yields another algebraic number q. $ \frac{r}{s} = q$ or $ r = q s $. The last equation written out explicitly reads \begin{eqnarray*} \lefteqn{({r_{n-1}} {a^{n-1}} + {r_{n-2}} {a^{n-2}} + \ldots)} \\ & = & ({q_{n-1}} {a^{n-1}} + {q_{n-2}} {a^{n-2}} + \ldots) \times ({s_{n-1}} {a^{n-1}} + {s_{n-2}} {a^{n-2}} + \ldots) \\ & & {\bf modulo} (a^n + {p _{n-1}} {a^{n -1}} + \ldots) \\ & = & ({t_{n-1}} {a^{n-1}} + {t_{n-2}} {a^{n-2}} + \ldots) \end{eqnarray*} The $t_i$ are linear in the $q_j$. Equating equal powers of $a$ yields a linear system for the quotient coefficients $q_j$. With this, all field operations for the algebraic numbers are available. The translation into algorithms is straightforward. For an implementation we have to decide on a data structure for an algebraic number. We have chosen the representation REDUCE normally uses for polynomials, the so-called standard form. Since our polynomials have in general rational coefficients, we must allow for a rational number domain inside the algebraic number. \begin{tabbing} \s{algebraic number} ::= \\ \hspace{.25in} \= {\tt :ar:} . \s{univariate polynomial over the rationals} \\[0.05in] \s{univariate polynomial over the rationals} ::= \\ \> \s{variable} .** \s{ldeg} .* \s{rational} .+ \s{reductum} \\[0.05in] \s{ldeg} ::= integer \\[0.3in] \s{rational} ::= \\ \> {\tt :rn:} . \s{integer numerator} . \s{integer denominator} : integer \\[0.05in] \s{reductum} ::= \s{univariate polynomial} : \s{rational} : nil \end{tabbing} This representation allows us to use the REDUCE functions for adding and multiplying polynomials on the tail of the tagged algebraic number. Also, the routines for solving linear equations can easily be used for the calculation of quotients. We are still left with the problem of introducing a particular algebraic number. In the current version this is done by giving the defining polynomial to the statement {\bf defpoly}. The \index{DEFPOLY statement} algebraic number sqrt(2), for example, can be introduced by \begin{verbatim} defpoly sqrt2**2 - 2; \end{verbatim} This statement associates a simplification function for the translation of the variable in the defining polynomial into its tagged internal form and also generates a power reduction rule used by the operations {\bf times} and {\bf quotient} for the reduction of their result modulo the defining polynomial. A basis for the representation of an algebraic number is also set up by the statement. In the working version, the basis is a list of powers of the indeterminate of the defining polynomial up to one less then its degree. Experiments with integral bases, however, have been very encouraging, and these bases might be available in a later version. If the defining polynomial is not monic, it will be made so by an appropriate substitution. \example \index{ARNUM package ! example} \begin{verbatim} defpoly sqrt2**2-2; 1/(sqrt2+1); SQRT2 - 1 (x**2+2*sqrt2*x+2)/(x+sqrt2); X + SQRT2 on gcd; (x**3+(sqrt2-2)*x**2-(2*sqrt2+3)*x-3*sqrt2)/(x**2-2); 2 (X - 2*X - 3)/(X - SQRT2) off gcd; sqrt(x**2-2*sqrt2*x*y+2*y**2); X - SQRT2*Y \end{verbatim} Until now we have dealt with only a single algebraic number. In practice this is not sufficient as very often several algebraic numbers appear in an expression. There are two possibilities for handling this: one can use multivariate extensions \cite{Davenport:81} or one can construct a defining polynomial that contains all specified extensions. This package implements the latter case (the so called primitive representation). The algorithm we use for the construction of the primitive element is the same as given by Trager \cite{Trager:76}. In the implementation, multiple extensions can be given as a list of equations to the statement {\bf defpoly}, which, among other things, adds the new extension to the previously defined one. All algebraic numbers are then expressed in terms of the primitive element. \example\index{ARNUM package ! example} \begin{verbatim} defpoly sqrt2**2-2,cbrt5**3-5; *** defining polynomial for primitive element: 6 4 3 2 A1 - 6*A1 - 10*A1 + 12*A1 - 60*A1 + 17 sqrt2; 5 4 3 2 48/1187*A1 + 45/1187*A1 - 320/1187*A1 - 780/1187*A1 + 735/1187*A1 - 1820/1187 sqrt2**2; 2 \end{verbatim} \newpage We can provide factorization of polynomials over the algebraic number domain by using Trager's algorithm. The polynomial to be factored is first mapped to a polynomial over the integers by computing the norm of the polynomial, which is the resultant with respect to the primitive element of the polynomial and the defining polynomial. After factoring over the integers, the factors over the algebraic number field are recovered by GCD calculations. \example\index{ARNUM package ! example} \begin{verbatim} defpoly a**2-5; x**2 + x - 1; (X + (1/2*A + 1/2))*(X - (1/2*A - 1/2)) \end{verbatim} \index{SPLIT\_FIELD function} We have also incorporated a function {\bf split\_field} for the calculation of a primitive element of minimal degree for which a given polynomial splits into linear factors. The algorithm as described in Trager's article is essentially a repeated primitive element calculation. \example\index{ARNUM package ! example} \begin{verbatim} split!_field(x**3-3*x+7); *** Splitting field is generated by: 6 4 2 A5 - 18*A5 + 81*A5 + 1215 4 2 {1/126*A5 - 5/42*A5 - 1/2*A5 + 2/7, 4 2 - (1/63*A5 - 5/21*A5 + 4/7), 4 2 1/126*A5 - 5/42*A5 + 1/2*A5 + 2/7} for each j in ws product (x-j); 3 X - 3*X + 7 \end{verbatim} A more complete description can be found in \cite{Bradford:86}. \bibliography{arnum} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/avector.tex version [3c536e94ab].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \date{} \title{A Vector Algebra and Calculus Package for REDUCE} \author{David Harper \\ Astronomy Unit \\ Queen Mary and Westfield College \\ University of London \\ Mile End Road \\ London E1 4NS \\ England \\[0.05in] Electronic mail: {\it adh@star.qmw.ac.uk}} \begin{document} \maketitle \index{AVECTOR package} \section{Introduction} This package \footnote{Reference: Computer Physics Communications, {\bf 54}, 295-305 (1989)} is written in RLISP (the LISP meta-language) and is intended for use with REDUCE 3.4. \index{vector algebra} It provides REDUCE with the ability to perform vector algebra using the same notation as scalar algebra. The basic algebraic operations are supported, as are differentiation and integration of vectors with respect to scalar variables, cross product and dot product, component manipulation and application of scalar functions ({\em e.g.} cosine) to a vector to yield a vector result. A set of vector calculus operators are provided for use with any orthogonal curvilinear coordinate system. These operators are gradient, divergence, curl and del-squared (Laplacian). The Laplacian operator can take scalar or vector arguments. Several important coordinate systems are pre-defined and can be invoked by name. It is also possible to create new coordinate systems by specifying the names of the coordinates and the values of the scale factors. \section{Vector declaration and initialisation} Any name may be declared to be a vector, provided that it has not previously been declared as a matrix or an array. To declare a list of names to be vectors use the VEC command: \index{VEC command} \begin{verbatim} VEC A,B,C; \end{verbatim} declares the variables {\tt A}, {\tt B} and {\tt C} to be vectors. If they have already been assigned (scalar) values, these will be lost. When a vector is declared using the {\tt VEC} command, it does not have an initial value. If a vector value is assigned to a scalar variable, then that variable will automatically be declared as a vector and the user will be notified that this has happened. \index{AVEC function} A vector may be initialised using the {\tt AVEC} function which takes three scalar arguments and returns a vector made up from those scalars. For example \begin{verbatim} A := AVEC(A1, A2, A3); \end{verbatim} sets the components of the vector {\tt A} to {\tt A1}, {\tt A2} and {\tt A3}. \section{Vector algebra} (In the examples which follow, {\tt V}, {\tt V1}, {\tt V2} {\em etc} are assumed to be vectors while {\tt S}, {\tt S1}, {\tt S2} etc are scalars.) \index{+ ! vector} \index{- ! vector} \index{* ! vector} \index{/ ! vector} The scalar algebra operators +,-,* and / may be used with vector operands according to the rules of vector algebra. Thus multiplication and division of a vector by a scalar are both allowed, but it is an error to multiply or divide one vector by another. \begin{tabular}{l l} {\tt V := V1 + V2 - V3;} & Addition and subtraction \\ {\tt V := S1*3*V1;} & Scalar multiplication \\ {\tt V := V1/S;} & Scalar division \\ {\tt V := -V1;} & Negation \\ \end{tabular} \index{DOT ! vector} \index{dot product} \index{CROSS ! vector} \index{cross product} \noindent Vector multiplication is carried out using the infix operators {\tt DOT} and {\tt CROSS}. These are defined to have higher precedence than scalar multiplication and division. \begin{tabular}{l l} {\tt V := V1 CROSS V2;} & Cross product \\ {\tt S := V1 DOT V2;} & Dot product \\ {\tt V := V1 CROSS V2 + V3;} & \\ {\tt V := (V1 CROSS V2) + V3;} & \\ \end{tabular} The last two expressions are equivalent due to the precedence of the {\tt CROSS} operator. \index{VMOD operator} The modulus of a vector may be calculated using the {\tt VMOD} operator. \begin{verbatim} S := VMOD V; \end{verbatim} A unit vector may be generated from any vector using the {\tt VMOD} operator. \begin{verbatim} V1 := V/(VMOD V); \end{verbatim} Components may be extracted from any vector using index notation in the same way as an array. \begin{tabular}{l l} {\tt V := AVEC(AX, AY, AZ);} & \\ {\tt V(0);} & yields AX \\ {\tt V(1);} & yields AY \\ {\tt V(2);} & yields AZ \\ \end{tabular} It is also possible to set values of individual components. Following from above: \begin{verbatim} V(1) := B; \end{verbatim} The vector {\tt V} now has components {\tt AX}, {\tt B}, {\tt AZ}. \index{vector ! differentiation} \index{vector | integration} \index{differentiation ! vector} \index{differentiation ! vector} Vectors may be used as arguments in the differentiation and integration routines in place of the dependent expression. \begin{tabular}{l l} {\tt V := AVEC(X**2, SIN(X), Y);} & \\ {\tt DF(V,X);} & yields (2*X, COS(X), 0) \\ {\tt INT(V,X);} & yields (X**3/3, -COS(X), Y*X) \\ \end{tabular} Vectors may be given as arguments to monomial functions such as {\tt SIN}, {\tt LOG} and {\tt TAN}. The result is a vector obtained by applying the function component-wise to the argument vector. \begin{tabular}{l l} {\tt V := AVEC(A1, A2, A3);} & \\ {\tt SIN(V);} & yields (SIN(A1), SIN(A2), SIN(A3)) \\ \end{tabular} \section{ Vector calculus} \index{DIV ! operator} \index{divergence ! vector field} \index{GRAD ! operator} \index{gradient ! vector field} \index{CURL ! operator} \index{curl ! vector field} \index{DELSQ ! operator} \index{Laplacian ! vector field} The vector calculus operators div, grad and curl are recognised. The Laplacian operator is also available and may be applied to scalar and vector arguments. \begin{tabular}{l l} {\tt V := GRAD S;} & Gradient of a scalar field \\ {\tt S := DIV V;} & Divergence of a vector field \\ {\tt V := CURL V1;} & Curl of a vector field \\ {\tt S := DELSQ S1;} & Laplacian of a scalar field \\ {\tt V := DELSQ V1;} & Laplacian of a vector field \\ \end{tabular} These operators may be used in any orthogonal curvilinear coordinate system. The user may alter the names of the coordinates and the values of the scale factors. Initially the coordinates are {\tt X}, {\tt Y} and {\tt Z} and the scale factors are all unity. \index{COORDS vector} \index{HFACTORS scale factors} There are two special vectors : {\tt COORDS} contains the names of the coordinates in the current system and {\tt HFACTORS} contains the values of the scale factors. \index{COORDINATES operator} The coordinate names may be changed using the {\tt COORDINATES} operator. \begin{verbatim} COORDINATES R,THETA,PHI; \end{verbatim} This command changes the coordinate names to {\tt R}, {\tt THETA} and {\tt PHI}. \index{SCALEFACTORS operator} The scale factors may be altered using the {\tt SCALEFACTORS} operator. \begin{verbatim} SCALEFACTORS(1,R,R*SIN(THETA)); \end{verbatim} This command changes the scale factors to {\tt 1}, {\tt R} and {\tt R SIN(THETA)}. Note that the arguments of {\tt SCALEFACTORS} must be enclosed in parentheses. This is not necessary with {\tt COORDINATES}. When vector differential operators are applied to an expression, the current set of coordinates are used as the independent variables and the scale factors are employed in the calculation. (See, for example, Batchelor G.K. 'An Introduction to Fluid Mechanics', Appendix 2.) \index{"!*CSYSTEMS global (AVECTOR)} Several coordinate systems are pre-defined and may be invoked by name. To see a list of valid names enter \begin{verbatim} SYMBOLIC !*CSYSTEMS; \end{verbatim} and REDUCE will respond with something like \begin{verbatim} (CARTESIAN SPHERICAL CYLINDRICAL) \end{verbatim} \index{GETCSYSTEM command} To choose a coordinate system by name, use the command {\tt GETCSYSTEM}. To choose the Cartesian coordinate system : \begin{verbatim} GETCSYSTEM 'CARTESIAN; \end{verbatim} \index{PUTCSYSTEM command} Note the quote which prefixes the name of the coordinate system. This is required because {\tt GETCSYSTEM} (and its complement {\tt PUTCSYSTEM}) is a {\tt SYMBOLIC} procedure which requires a literal argument. REDUCE responds by typing a list of the coordinate names in that coordinate system. The example above would produce the response \begin{verbatim} (X Y Z) \end{verbatim} whilst \begin{verbatim} GETCSYSTEM 'SPHERICAL; \end{verbatim} would produce \begin{verbatim} (R THETA PHI) \end{verbatim} Note that any attempt to invoke a coordinate system is subject to the same restrictions as the implied calls to {\tt COORDINATES} and {\tt SCALEFACTORS}. In particular, {\tt GETCSYSTEM} fails if any of the coordinate names has been assigned a value and the previous coordinate system remains in effect. A user-defined coordinate system can be assigned a name using the command {\tt PUTCSYSTEM}. It may then be re-invoked at a later stage using {\tt GETCSYSTEM}. \example\index{AVECTOR package ! example} We define a general coordinate system with coordinate names {\tt X},{\tt Y},{\tt Z} and scale factors {\tt H1},{\tt H2},{\tt H3} : \begin{verbatim} COORDINATES X,Y,Z; SCALEFACTORS(H1,H2,H3); PUTCSYSTEM 'GENERAL; \end{verbatim} This system may later be invoked by entering \begin{verbatim} GETCSYSTEM 'GENERAL; \end{verbatim} \section{Volume and Line Integration} Several functions are provided to perform volume and line integrals. These operate in any orthogonal curvilinear coordinate system and make use of the scale factors described in the previous section. Definite integrals of scalar and vector expressions may be calculated using the {\tt DEFINT} function. \example\index{AVECTOR package ! example} \index{DEFINT function} \index{integration ! definite (simple)} \index{definite integration (simple)} \noindent To calculate the definite integral of $\sin(x)^2$ between 0 and 2$\pi$ we enter \begin{verbatim} DEFINT(SIN(X)**2,X,0,2*PI); \end{verbatim} This function is a simple extension of the {\tt INT} function taking two extra arguments, the lower and upper bounds of integration respectively. \index{VOLINTEGRAL function} \index{integration ! volume} Definite volume integrals may be calculated using the {\tt VOLINTEGRAL} function whose syntax is as follows : \noindent {\tt VOLINTEGRAL}({\tt integrand}, vector {\tt lower-bound}, vector {\tt upper-bound}); \example\index{AVECTOR package ! example} \noindent In spherical polar coordinates we may calculate the volume of a sphere by integrating unity over the range $r$=0 to {\tt RR}, $\theta$=0 to {\tt PI}, $\phi$=0 to 2*$\pi$ as follows : \begin{tabular}{l l} {\tt VLB := AVEC(0,0,0);} & Lower bound \\ {\tt VUB := AVEC(RR,PI,2*PI);} & Upper bound in $r, \theta, \phi$ respectively \\ {\tt VOLINTORDER := (0,1,2);} & The order of integration \\ {\tt VOLINTEGRAL(1,VLB,VUB);} & \\ \end{tabular} \index{VOLINTORDER vector} Note the use of the special vector {\tt VOLINTORDER} which controls the order in which the integrations are carried out. This vector should be set to contain the number 0, 1 and 2 in the required order. The first component of {\tt VOLINTORDER} contains the index of the first integration variable, the second component is the index of the second integration variable and the third component is the index of the third integration variable. \example\index{AVECTOR package ! example} Suppose we wish to calculate the volume of a right circular cone. This is equivalent to integrating unity over a conical region with the bounds: \begin{tabular}{l l} z = 0 to H & (H = the height of the cone) \\ r = 0 to pZ & (p = ratio of base diameter to height) \\ phi = 0 to 2*PI & \\ \end{tabular} We evaluate the volume by integrating a series of infinitesimally thin circular disks of constant z-value. The integration is thus performed in the order : d($\phi$) from 0 to $2\pi$, dr from 0 to p*Z, dz from 0 to H. The order of the indices is thus 2, 0, 1. \begin{verbatim} VOLINTORDER := AVEC(2,0,1); VLB := AVEC(0,0,0); VUB := AVEC(P*Z,H,2*PI); VOLINTEGRAL(1,VLB,VUB); \end{verbatim} (At this stage, we replace {\tt P*H} by {\tt RR}, the base radius of the cone, to obtain the result in its more familiar form.) \index{LINEINT function} \index{DEFLINEINT function} \index{integration ! line} \index{line integrals} Line integrals may be calculated using the {\tt LINEINT} and {\tt DEFLINEINT} functions. Their general syntax is \noindent {\tt LINEINT}({\tt vector-function}, {\tt vector-curve}, {\tt variable}); \noindent{\tt DEFLINENINT}({\tt vector-function}, {\tt vector-curve}, {\tt variable}, {\tt lower-bound}, {\tt upper-bound}); \noindent where \begin{description} \item[{\tt vector-function}] is any vector-valued expression; \item[{\tt vector-curve}] is a vector expression which describes the path of integration in terms of the independent variable; \item[{\tt variable}] is the independent variable; \item[{\tt lower-bound}] \item[{\tt upper-bound}] are the bounds of integration in terms of the independent variable. \end{description} \example\index{AVECTOR package ! example} In spherical polar coordinates, we may integrate round a line of constant theta (`latitude') to find the length of such a line. The vector function is thus the tangent to the `line of latitude', (0,0,1) and the path is {\tt (0,LAT,PHI)} where {\tt PHI} is the independent variable. We show how to obtain the definite integral {\em i.e.} from $\phi=0$ to $2 \pi$ : \begin{verbatim} DEFLINEINT(AVEC(0,0,1),AVEC(0,LAT,PHI),PHI,0,2*PI); \end{verbatim} \section{Defining new functions and procedures} Most of the procedures in this package are defined in symbolic mode and are invoked by the REDUCE expression-evaluator when a vector expression is encountered. It is not generally possible to define procedures which accept or return vector values in algebraic mode. This is a consequence of the way in which the REDUCE interpreter operates and it affects other non-scalar data types as well : arrays cannot be passed as algebraic procedure arguments, for example. \section{Acknowledgements} This package was written whilst the author was the U.K. Computer Algebra Support Officer at the University of Liverpool Computer Laboratory. \end{document} |
Added r34.1/doc/bibl.bib version [11899c1328].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 | % REDUCE BIBLIOGRAPHY % Part 1: A-F % Copyright (c) 1991 RAND. All Rights Reserved. % Additions and corrections are solicited. Please send them, in the % same format as these entries if possible, to reduce at rand.org. @ARTICLE{Abbott:85, AUTHOR = "J. A. Abbott and R. J. Bradford and J. H. Davenport", TITLE = "A Remark on Factorisation", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "31-33", MONTH = "May"} @INPROCEEDINGS{Abbott:86, AUTHOR = "J. A. Abbott and R. J. Bradford and J. H. Davenport", TITLE = "The {Bath} Algebraic Number Package", BOOKTITLE = "Proc. of {SYMSAC} '86", YEAR = 1986, PAGES = "250-253"} @INPROCEEDINGS{Abbott:87, AUTHOR = "J. A. Abbott and J. H. Davenport", TITLE = "Polynomial Factorization: An Exploration of {Lenstra's} Algorithm", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "391-402", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Abbott:87a, AUTHOR = "J. A. Abbott", TITLE = "Integration: Solving the {Risch} Differential Equation", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "465-467", PUBLISHER = "Springer-Verlag"} @PHDTHESIS{Abbott:88, AUTHOR = "J. A. Abbott", TITLE = "Factorisation of Polynomials over Algebraic Number Fields", SCHOOL = "Univ. of Bath, England", YEAR = 1988} @ARTICLE{Abbott:88a, AUTHOR = "J. A. Abbott and J. H. Davenport", TITLE = "A Remark on a Paper by {Wang}: Another Surprising Property of 42", JOURNAL = "Math. Comp.", YEAR = 1988, VOLUME = 51, PAGES = "837-839"} @INPROCEEDINGS{Abbott:89, AUTHOR = "J. A. Abbott", TITLE = "Recovery of Algebraic Numbers from their p-Adic Approximations", BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York", YEAR = 1989, PAGES = "112-120"} @TECHREPORT{Abbott:89a, AUTHOR = "J. A. Abbott and R. J. Bradford and J. H. Davenport", TITLE = "A Remark on the Multiplication of Sparse Polynomials", NUMBER = "TR 89-21", YEAR = 1989, INSTITUTION = "School of Mathematical Sciences, University of Bath"} @INPROCEEDINGS{Abdali:88, AUTHOR = "S. K. Abdali and D. S. Wise", TITLE = "Experiments with Quadtree Representation of Matrices", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "96-108"} @ARTICLE{Abiezzi:83, AUTHOR = "Salim S. {Abi-Ezzi}", TITLE = "Clarification to the Symbolic Mode in {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = "3 and 4", PAGES = "43-47", MONTH = "August and November"} @INPROCEEDINGS{Abramov:91, AUTHOR = "S. A. Abramov and K. Yu. Kvansenko", TITLE = "Fast Algorithms to Search for the Rational Solutions of Linear Differential Equations with Polynomial Coefficients", EDITOR = "Stephen M. Watt", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991, PAGES = "267-270"} @TECHREPORT{Abramov:91a, AUTHOR = "S. A. Abramov and K. Yu. Kvashenko", TITLE = "Fast search of a certain type solutions of linear ordinary differential equations with polynomial coefficients", INSTITUTION = "Computer Center of the USSR, Academy of Science, Moscow", YEAR = 1991} @InProceedings{Adamchik90, author = "V. S. Adamchik and O. I. Marichev", title = "The Algorithm for calculating Integrals of Hypergeometric type functions and its realization in {REDUCE} System", booktitle = "Proceedings of the 1990 International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "212-224", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Adams:83, AUTHOR = "K. J. Adams", TITLE = "Analytic Estimates for the Dynamic Aperture of Nonlinear Lattices", JOURNAL = "IEEE Trans. Nucl. Sci.", YEAR = 1983, VOLUME = "NS-30", PAGES = "2436-2438", COMMENT = {"For an accelerator lattice{\ldots}" {REDUCE} was used to obtain low order coefficients in the calculation of the amplitude.}} @ARTICLE{Adkins:83, AUTHOR = "G. S. Adkins", TITLE = "Analytic Evaluation of an {O}($\alpha$) Vertex Correction to the Rate of Orthopositronium", JOURNAL = "Phys. Rev. A", YEAR = 1983, VOLUME = 27, PAGES = "530-532", ABSTRACT = {The order-$\alpha$ correction to the lowest order orthopositronium decay rate due to the two outer-vertex graphs obtained in analytic form.}} @ARTICLE{Adkins:83a, AUTHOR = "G. S. Adkins and F. R. Brown", TITLE = "Rate for Positronium Decay to Five Photons", JOURNAL = "Phys. Rev. A", YEAR = 1983, VOLUME = 28, PAGES = "1164-1165", COMMENT = {{REDUCE} used to calculate trace of $\gamma$ matrices. Large calculation.}} @ARTICLE{Adkins:85, AUTHOR = "G. S. Adkins", TITLE = "Inner-Vertex Contributions to the Decay Rate of Orthopositronium", JOURNAL = "Phys. Rev. A", YEAR = 1985, VOLUME = 31, PAGES = "1250-1252", COMMENT = {{REDUCE} trace calculations. "In this paper the order-$\alpha$ contribution to the inner-vertex graphs to the decay rate of orthopositronium is obtained in analytic form."}} @ARTICLE{Aguilera-Navarro:87, AUTHOR = "V. C. Aguilera-Navarro and R. Guardiola and C. Keller and M. de Llano and M. Popovic and M. Fortes", TITLE = "Van der {Waals} Perturbation Theory for Fermion and Boson Ground-State Matter", JOURNAL = "Phys. Rev. A", YEAR = 1987, VOLUME = 35, PAGES = "3901-3910", COMMENT = {Uses computer algebra to rearrange ideal-gas-based low-density expansions; to them {REDUCE} or {MACSYMA} provide just the expertise they require to substitute forms into equations, and so makes their formulation possible.}} @TECHREPORT{Akselrod:90, AUTHOR = "I.R. Akselrod and V.P. Gerdt and V.E. Kovtun and V.N. Robuk", TITLE = "Construction of a {Lie} algebra by a subset of generators and commutation relations", INSTITUTION = "J.I.N.R.", YEAR = 1990, TYPE = "Preprint", NUMBER = "E5-90-508", ABSTRACT = {The problem of constructing the quotient algebra for a free {Lie} algebra over an ideal given by a subset of generators and commutation relations is investigated. The method proposed to solve this problem can be applied in particular for constructing a {L-A} pair for nonlinear evolution equations. The algorithm is based on the concept of {Hall} basis for a free {Lie} algebra and is implemented in the computer algebra system {REDUCE}.}} @ARTICLE{Aldins:69, AUTHOR = "J. Aldins and S. J. Brodsky and A. J. Dufner and T. Kinoshita", TITLE = "Photon-Photon Scattering Contribution to the Sixth Order Magnetic Moments of the Muon and Electron", JOURNAL = "Phys. Rev. Lett.", YEAR = 1969, VOLUME = 23, PAGES = "441-443"} @TECHREPORT{Alekseev:86, AUTHOR = "A. I. Alekseev and V. F. Edneral", TITLE = "Tensor Structure of Axial Gauge Polarization Operator in the Infrared Region", INSTITUTION = "IHEP", YEAR = 1986, TYPE = "Preprint", NUMBER = "86-46"} @ARTICLE{Alekseev:87, AUTHOR = "A. I. Alekseev and V. F. Edneral", TITLE = "Tensor Structure of Gluon Polarization Operator in the Axial Gauge for Infra-Red Region", JOURNAL = "Journal of Nuclear Physics", YEAR = 1987, PAGES = "1105-1114"} @TECHREPORT{Alekseev:87a, AUTHOR = "A. I. Alekseev and V. F. Edneral", TITLE = "On Evaluation of {Feynman} Integrals in Axial Gauge", INSTITUTION = "IHEP", YEAR = 1987, TYPE = "Preprint", NUMBER = "87-118", ABSTRACT = {The recurrent algorithm for axial gauge calculations of one-loop massless {Feynman} integrals in the n-dimensional momentum space is described. The algorithm we suggest is realized on the basis of {REDUCE} system and presented as a procedure. It is rather effective for cumbersome combinations of those integrals.}} @ARTICLE{Alfeld:82, AUTHOR = "P. Alfeld", TITLE = "Fixed Point Iteration with Inexact Function Values", JOURNAL = "Math. Comp.", YEAR = 1982, VOLUME = 38, PAGES = "87-98", COMMENT = {Numerical analysis generating an improved iterative scheme. "The technical manipulations in this paper were carried out using the symbol manipulation language {REDUCE}."}} @TECHREPORT{Amirkhanov:87, AUTHOR = "I. V. Amirkhanov and E. P. Zhydkov and I. E. Zhydkova", TITLE = "The Conditions of Bounding of the Oscillation Amplitudes of Charge Particle within the Resonance Vicinity Investigations", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1987, NUMBER = "P11-87-452"} @INPROCEEDINGS{Amirkhanov:91, AUTHOR = "I.V. Amirkhanov and E.P. Zhidkov and I.E. Zhidkova", TITLE = "The Betatron Oscillations in the Vicinity of Nonlinear Resonance in Cyclic Accelerator Investigation", EDITOR = "Stephen M. Watt", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991, PAGES = "452-453"} @ARTICLE{Antweiler:89, AUTHOR = "Werner Antweiler and Andreas Strotmann and Volker Winkelmann", TITLE = "A {\TeX-{REDUCE}-Interface}", JOURNAL = "SIGSAM Bulletin", YEAR = 1989, VOLUME = 23, MONTH = "February", PAGES = "26-33"} @ARTICLE{Appelquist:70, AUTHOR = "T. W. Appelquist and S. J. Brodsky", TITLE = "The Order $\alpha^{2}$ Electrodynamic Corrections to the {Lamb} Shift", JOURNAL = "Phys. Rev. Letters", YEAR = 1970, VOLUME = 24, PAGES = "562-565"} @TECHREPORT{Arbuzov:86, AUTHOR = "B. A. Arbuzov and E. E. Boos and A. I. Davydychev", TITLE = "Infrared Asymptotics of Gluonic {Green} Functions in Covariant Gauge", INSTITUTION = "IHEP", YEAR = 1986, TYPE = "Preprint", NUMBER = "86-123"} @ARTICLE{Aso:81, AUTHOR = "T. Aso and T. Nonoyama and S. Kato", TITLE = "Numerical Simulation of Semidiurnal Atmospheric Tides", JOURNAL = "J. Geophysical R.", YEAR = 1981, VOLUME = 86, NUMBER = 11, PAGES = "388-400", COMMENT = {"Numerical modeling of the solar and lunar semidiurnal atmospheric tides has been performed by invoking a comprehensive approach that includes both algebraic manipulation and numerical solution of the primitive equation system." Used {REDUCE} to overcome difficulties of complication and error.}} @ARTICLE{Atherton:73, AUTHOR = "R. W. Atherton and G. M. Homsey", TITLE = "Use of Symbolic Computation to Generate Evolution Equations and Asymptotic Solutions to Elliptic Equations", JOURNAL = "Journ. Comp. Phys.", YEAR = 1973, VOLUME = 1, PAGES = "45-59"} @ARTICLE{Aurenche:84, AUTHOR = "P. Aurenche and A. Douir and R. Baier and M. Fontannaz and D. Schiff", TITLE = "Photoproduction of Hadrons at Large Transverse Momentum in Second Order {QCD}", JOURNAL = "Phys. Lett.", YEAR = 1984, VOLUME = "135B", PAGES = "164-168", COMMENT = {Uses {REDUCE} and {SCHOONSCHIP} in the extension of calculations to a higher order to keep pace with experimental results.}} @ARTICLE{Aurenche:84a, AUTHOR = "P. Aurenche and A. Douir and R. Baier and M. Fontannaz and D. Schiff", TITLE = "Prompt Photon Production at Large $p_{\tau}$ in {GCD} Beyond the Leading Order", JOURNAL = "Phys. Lett.", YEAR = 1984, VOLUME = "140B", PAGES = "87-92", COMMENT = {Uses {REDUCE} and {SCHOONSCHIP}.}} @ARTICLE{Autin:89, AUTHOR = "B. Autin and J. Bengtsson", TITLE = "Symbolic Evaluation of Integrals Occurring in Accelerator Orbit Theory", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 7, NUMBER = 2, PAGES = "183-187", MONTH = "February"} @ARTICLE{Baekler:84, AUTHOR = "P. Baekler and F. W. Hehl", TITLE = "A Charged {Taub-NUT} Metric with Torsion: A New Axially Symmetric Solution of the {Poincar\'{e}} Gauge Field Theory", JOURNAL = "Phys. Lett.", YEAR = 1984, VOLUME = "100A", PAGES = "277-316"} @TECHREPORT{Baekler:84a, AUTHOR = "Peter Baekler and Friedrich W. Hehl", TITLE = "On the Dynamics of the Torsion of Spacetime: Exact Solutions in a Gauge Theoretical Model of Gravity", INSTITUTION = "Department of Physics, University of California, Los Angeles", YEAR = 1984, NUMBER = "UCLA/84/TEP/19", PAGE = "18", MONTH = "December"} @INPROCEEDINGS{Baekler:86, AUTHOR = "P. Baekler and F. W. Hehl and E. W. Mielke", TITLE = "Nonmetricity and Torsion: Facts and Fancies in Gauge Approaches to Gravity", EDITOR = "R. Ruffini", BOOKTITLE = "Proc. 4th Marcel Grossmann Meeting on General Relativity, ed.", PUBLISHER = "North-Holland, Amsterdam", YEAR = 1986, PAGES = "277-316"} @ARTICLE{Baekler:87, AUTHOR = "P. Baekler and R. Hecht and F. W. Hehl and T. Shirafuji", TITLE = "Mass and Spin of Exact Solutions of the {Poincar{\'e}} Gauge Theory", JOURNAL = "Prog. Theor. Phys.", YEAR = 1987, VOLUME = 78, PAGES = "16-21"} @ARTICLE{Baekler:87a, AUTHOR = "P. Baekler and M. Guerses", TITLE = "Exact Solutions of the {Poincar{\'e}} Gauge Theory from Its Linearized Field Equations", JOURNAL = "Lett. Math. Phys.", YEAR = 1987, VOLUME = 14, PAGES = "185-191"} @ARTICLE{Baekler:87b, AUTHOR = "P. Baekler and E. W. Mielke and F. W. Hehl", TITLE = "Kinky Torsion in a {Poincar{\'e}} Gauge Model of Gravity Coupled to a Massless Scalar Field", JOURNAL = "Nuclear Phys.", YEAR = 1987, VOLUME = "B288", PAGES = "800-812"} @ARTICLE{Baekler:88, AUTHOR = "P. Baekler and M. Seitz and V. Winkelmann", TITLE = "Cylindrically Symmetric Solutions of Self-Consistently Coupled {Dirac} Fields in Gauge Theories of Gravity", JOURNAL = "Class. Quantum Grav.", YEAR = 1988, VOLUME = 5, PAGES = "479-490"} @ARTICLE{Baekler:88a, AUTHOR = "P. Baekler and M. Guerses and F. W. Hehl and J. D. McCrea", TITLE = "The Exterior Gravitational Field of a Charged Spinning Source in the {Poincar{\'e}} Gauge Theory: A {Kerr-Newman} Metric with Dynamic Torsion", JOURNAL = "Phys. Lett.", YEAR = 1988, VOLUME = "A128", PAGES = "245-250"} @ARTICLE{Baekler:88b, AUTHOR = "P. Baekler and M. Guerses and F. W. Hehl", TITLE = "A New Method to Solve the Field Equations of {Poincar{\'e}} Gauge Theories", JOURNAL = "Class. Quantum Grav.", YEAR = 1988} @TECHREPORT{Bahrdt:90, AUTHOR = "J. Bahrdt and G. W{\"u}stefeld", TITLE = "A New Tracking Routine for Particles in Undulator and Wiggler Fields", INSTITUTION = "Technischer Bericht", YEAR = 1990, TYPE = "Report", NUMBER = "BESSY TB Nr. 158", MONTH = "October", ABSTRACT = {In this report we present an approximated solution of the particle motion in wiggler and undulator fields by an algebraic mapping routine. The solution is based on a series expansion up to the third order in the two transversal angle coordinates and, as a third variable, the bending radius of the particle orbit. The wiggler and undulator fields are represented by an expansion as suggested by K. Halbach. The report consists of two parts. In the first part we solve the equations of motion by an iteration procedure, which originally was also the first approach. In the second part the solution is based on a Taylor series expansion. Both approaches are equivalent.}, ABSTRACT2 = {Beside the presentation of the solution, the main topics discussed in the two parts are the calculation speed and accuracy of the algebraic method in comparison to integration methods along undulator fields, as they are typically applied in lattice design codes. As a further result of the discussion we obtain a proper canonical mapping routine at least as accurate but faster than typical integration routines.}} @ARTICLE{Baier:81, AUTHOR = {V.N.Baier and A.G.Grozin}, TITLE = {Inclusive quarkonium production in {$e^+ e^-$} annihilation}, JOURNAL = {Yad. Fiz. (Sov. J. Nucl. Phys.)}, YEAR = 1981, VOLUME = 33, NUMBER = 2, PAGES = {491-500}} @ARTICLE{Baier:85, AUTHOR = {V.N.Baier and A.G.Grozin}, TITLE = {Gluonic contributions to the exclusive amplitudes}, JOURNAL = {Zeit. f\"ur Phys. C}, YEAR = 1985, VOLUME = 29, PAGES = {161-165}} @ARTICLE{Baier:90, AUTHOR = {V.N.Baier and A.G.Grozin}, TITLE = {Decay {$B \to D l \bar\nu$} from {QCD} sum rules}, JOURNAL = {Zeit. f\"ur Phys. C}, YEAR = 1990, VOLUME = 47, PAGES = {669-675}} @TECHREPORT{Bajla:78, AUTHOR = "I. Bajla and G. A. Ososkov and A. C. Hearn", TITLE = "The Orthogonalization Program of Polynomials in Two Variables in {REDUCE}-2 Language", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1978, TYPE = "Report", NUMBER = "P10-11944", ABSTRACT = {The analytical algorithm for constructing orthogonal polynomials in two variables, based on the {Gram-Schmidt} orthogonalization method, is proposed.}} @INPROCEEDINGS{Balian:78, AUTHOR = "R. Balian and G. Parisi and A. Voros", TITLE = "Quartic Oscillator", YEAR = 1978, MONTH = "May", BOOKTITLE = "Proc. of the Colloq. on Mathematical Problems in {Feynman} Path Integrals, Marseille", ABSTRACT = {On the example of the semi-classical expansion for the levels of the quartic oscillator -(d**2/dq**2)+q**4, we show how the complex WKB method provides information about the singularities of the Borel transform of the semi-classical series.}} @ARTICLE{Baker:81, AUTHOR = "G. A. Baker and L. P. Benofy and M. Fortes and M. de Llano and S. M. Peltier and A. Plastino", TITLE = "Hard-Core Square-Well Fermion", JOURNAL = "Phys. Rev. A", YEAR = 1982, VOLUME = 26, PAGES = "3575-3588", COMMENT = {The mixed use of {FORTRAN} and {REDUCE}, various derivative were calculated algebraically, but the double series was evaluated numerically.}} @ARTICLE{Bark:78, AUTHOR = "Fritz H. Bark and Herman Tinoco", TITLE = "Stability of Plane {Poiseuille} Flow of a Dilute Suspension of Slender Fibres", JOURNAL = "J. Fluid Mech.", YEAR = 1978, VOLUME = 87, PAGES = "321-333", ABSTRACT = {The linear hydrodynamic stability problem for plane {Poiseuille} flow of a dilute suspension of rigid fibers is solved numerically. The constitutive equation given by {Batchelor} is used to model the rheological properties of the suspension. The resulting eigenvalue problem is shown to be singular.}} @ARTICLE{Barthes-Biesel:73, AUTHOR = "D. Barthes-Biesel and A. Acrivos", TITLE = "On Computer Generated Analytic Solutions to the Equations of Fluid Mechanics, The Case of Creeping Flows", JOURNAL = "Journ. Comp. Phys.", YEAR = 1973, VOLUME = 3, PAGES = "403-411"} @ARTICLE{Barton:72, AUTHOR = "David Barton and Anthony C. Hearn", TITLE = "Comment on Problem \#2 - The {Y(2n)} Functions", JOURNAL = "SIGSAM Bulletin", YEAR = 1972, VOLUME = 15, ABSTRACT = {A compact program for the solution of {SIGSAM} Problem \#2 is presented.}} @ARTICLE{Bateman:86, AUTHOR = "G. Bateman and R. G. Storer", TITLE = "Direct Determination of Axisymmetric Magnetohydrodynamic Equilibrium in {Hamada} Coordinates", JOURNAL = "Journ. Comp. Phys.", YEAR = 1986, VOLUME = 64, PAGES = "161-176", COMMENT = {Plasma. {"REDUCE} was used to analyse the general set of equations for large numbers of {Fourier} harmonics {\ldots}"}} @INPROCEEDINGS{Belkov:91, AUTHOR = "Alexander A. Bel'Kov and Alexander V. Lanyov", TITLE = "{REDUCE} Usage for Calculation of Low-Energy Process Amplitudes in Chiral {QCD} Model", EDITOR = "Stephen M. Watt", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991, PAGES = "454-455", ABSTRACT = {We describe the extension of {REDUCE} capabilities for the calculations of strong and weak meson processes within the chiral Lagrangians with higher derivatives. The main non-trivial difficulty is to obtain the process amplitude from the Lagrangian, describing these interactions. Another one is to overcome some {REDUCE} deficiencies such as the lack of arguments in the matrix data type as well as of some physical operations with the particle operators. This package of procedures allows one to claculate the amplitudes of the strong and weak processes by simple specifying the particles involved and their momenta.}} @TECHREPORT{Bennett, AUTHOR = "J. P. Bennett and J. H. Davenport and H. M. Sauro", TITLE = "Solution of Some Equations in Biochemistry", INSTITUTION = "School of Mathematical Sciences, University of Bath, England", NUMBER = "88-12"} @ARTICLE{Berends:81, AUTHOR = "A. Berends and R. Kleiss and P. de Causmaecher and T. T. Wu", TITLE = "Single Bremsstrahlung Process in Gauge Theories", JOURNAL = "Phys. Lett.", YEAR = 1981, VOLUME = "103B", PAGES = "124-128", COMMENT = {Used {REDUCE} to calculate 25 {Feynman} diagrams to produce theoretical results which could be checked against experiment.}} @TECHREPORT{Berkovich:89, AUTHOR = "L.M. Berkovich and V.P. Gerdt and Z.T. Kostova and M.L. Nechaevsky", TITLE = "Second Order Reducible Linear Differential Equations", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1989, TYPE = "Preprint", NUMBER = "E5-89-141"} @TECHREPORT{Berkovich:90, AUTHOR = "L.M. Berkovich and V.P. Gerdt and Z.T. Kostova and M.L. Nechaevsky", TITLE = "Computer algebra generating related {2nd} order linear differential equation", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1990, TYPE = "Preprint", NUMBER = "E5-90-509", ABSTRACT = {An algorithm with its mathematical foundation concerning {2nd} order ordinary linear differential equations {(OLDE)} is described. It allows one to generate related {four-parametric} families of {OLDE} with coefficients of preassigned (in the scope of the procedure) structures integrable in terms of a given (generating) equation. The number of those families in each next generation grows according to geometric progression with ratio eight. Several examples of both mathematical and physical significance illustrate the efficiency of the algorithm implemented in the {REDUCE} compute algebra system.}} @ARTICLE{Berman:63, AUTHOR = "S. M. Berman and Y. S. Tsai", TITLE = "Intermediate Boson Pair Production as a Means for Determining its Magnetic Moment", JOURNAL = "Phys. Rev. Lett.", YEAR = 1963, VOLUME = 11, PAGES = "483-487"} @INPROCEEDINGS{Berndt:91, AUTHOR = "R. Berndt and A. Lock and G. Witte and Ch. W{\"o}ll", TITLE = "Application of Computer Algebra to Surface Lattice Dynamics", EDITOR = "Stephen M. Watt", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991, PAGES = "433-438", ABSTRACT = {Lattice dynamical calculations for surfaces and in particular for stepped and adsorbed covered surfaces are commonly hampered by the complexity of the dynamical matrix for these systems. We propose the use of computer algebra programs to set up the dynamical matrix. In the present implementation the dynamical matrix is calculated fully analytically within the framework of a force constant-model and partially analytically for other interaction models such as the shell model or the bond charge model.}} @ARTICLE{Bessis:85, AUTHOR = "N. Bessis and G. Bessis and D. Roux", TITLE = "Closed-Form Expressions for the {Dirac-Coulomb} Radial $r^{t}$ Integrals", JOURNAL = "Phys. Rev. A", YEAR = 1985, VOLUME = 32, PAGES = "2044-2050", COMMENT = {No direct algebraic manipluation, but the formula is stated to be well suited to evaluation by {REDUCE} or {MACSYMA}, and this is an advantage of their formula.}} @TECHREPORT{Billoire:78, AUTHOR = "A. Billoire and R. Lacaze and A. Morel and H. Navelet", TITLE = "The {OZI} Rule Violating Radiative Decays of the Heavy Pseudoscalars", INSTITUTION = "{CEN}-Saclay", YEAR = 1978, TYPE = "Report", NUMBER = "DpH-T 43/78", COMMENT = {Submitted to Phys. Letters B. In lowest order {QCD} the rates for radiative transitions violating the {OZI} rule of heavy pseudoscalars are found to be extremely small.}} @ARTICLE{Biro:86, AUTHOR = "T. S. Biro and J. Zimanyi and M. Zimanyi", TITLE = "Hadrochemistry in Relativistic Mean Fields", JOURNAL = "Physics Letters", YEAR = 1986, VOLUME = "167B", NUMBER = 3, PAGES = "271-276", MONTH = "February"} @ARTICLE{Biro:87, AUTHOR = "T. S. Biro and K. Niita and A. L. de Paoli and W. Bauer and W. Cassing and U. Mosel", TITLE = "Microscopic Theory of Photon Production in Proton-Nucleus and Nucleus-Nucleus Collisions", JOURNAL = "Nuclear Physics", YEAR = 1987, VOLUME = "475A", PAGES = "579-597", MONTH = "December"} @TECHREPORT{Birrell:77, AUTHOR = "N. D. Birrell", TITLE = "The Application of Adiabatic Regularization to Calculations of Cosmological Interest", INSTITUTION = "Dept. Math, King's College, London", YEAR = 1977} @ARTICLE{Biswas:75, AUTHOR = "S. N. Biswas and S. R. Chaudhuri and K. S. Taank and J. A. Campbell", TITLE = "Neutrino Production in Stellar Matter by Photons in a Renormalizable Scalar-Boson-Exchange Model of Weak Interactions", JOURNAL = "Phys. Rev. D", YEAR = 1975, VOLUME = 8, PAGES = "2523-2525"} @TECHREPORT{Bittencourt:90, AUTHOR = "Guilherme Bittencourt and Jacques Calmet", TITLE = "Integrating Computer Algebra and Knowledge Representation", INSTITUTION = "Universit{\"a}t Karlsruhe Institut f{\"u}r Algorithmen und Kognitive Systeme", YEAR = 1990, TYPE = "Preprint"} @ARTICLE{Bocko:92, AUTHOR = "J. Bocko", TITLE = "{EQSHELL-} a {REDUCE-based} program for generation of equations of equilibrium for shell", JOURNAL = "Comp. Phys. Commun.", YEAR = 1992, VOLUME = 69, NUMBER = 1, PAGES = "215-222", MONTH = "February", COMMENT = {EQSHELL is a REDUCE-based program which generates the equations of equilibrium for various shapes of shells. This program also produces other important characteristics of the shell.}} @ARTICLE{Boege:86, AUTHOR = "W. Boege and R. Gebauer and H. Kredel", TITLE = "Some Examples for Solving Systems of Algebraic Equations by Calculating {Groebner} Bases", JOURNAL = "J. Symbolic Computation", YEAR = 1986, VOLUME = 2, NUMBER = 1, PAGES = "83-98", MONTH = "March"} @ARTICLE{Bogdanova:88, AUTHOR = "N. Bogdanova and H. Hogreve", TITLE = "A {REDUCE} Package for Exact {Coulomb} Interaction Matrix Elements", JOURNAL = "Comp. Phys. Commun.", YEAR = 1988, VOLUME = 48, NUMBER = 2, PAGES = "319-326", MONTH = "February"} @ARTICLE{Bordoni:81, AUTHOR = "Luciana Bordoni and Attilio Colagrossi", TITLE = "An Application of {REDUCE} to Industrial Mechanics", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1981, VOLUME = 15, NUMBER = 2, PAGES = "8-12", MONTH = "May"} @INPROCEEDINGS{Bowyer:87, AUTHOR = "A. Bowyer and J. H. Davenport and P. S. Milne and J. A. Padget and A. F. Wallis", TITLE = "Applications of Computer Algebra in Solid Modelling", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "244-245", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Boyd:78, AUTHOR = "John P. Boyd", TITLE = "The Effects of Latitudinal Shear on Equatorial Waves, Part {I}: Theory and Methods", INSTITUTION = "Dept. of Atmos. and Oceanic Science, Univ. of Michigan", YEAR = 1978, TYPE = "Preprint", MONTH = "January", COMMENT = {To be published in Journal of The Atmospheric Sciences. By using the method of multiple scales in height and a variety of methods in latitude, analytic solutions for equatorial waves in combined vertical and horizontal shear are derived.}} @INPROCEEDINGS{Brackx:87, AUTHOR = "F. Brackx and H. Serras", TITLE = "Boundary Value Problems for the {Laplacian} in {Euclidean} Space Solved by Symbolic Computation", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "208-215", PUBLISHER = "Springer-Verlag"} @ARTICLE{Brackx:87a, AUTHOR = "F. Brackx and D. Constales and R. Delanghe and H. Serras", TITLE = "{Clifford} Algebra with {REDUCE}", JOURNAL = "Rend. Circ. Mat. Palermo, Ser. II", YEAR = 1987, VOLUME = 16, PAGES = "11-19"} @ARTICLE{Brackx:89, AUTHOR = "F. Brackx and D. Constales and A. Ronveaux and H. Serras", TITLE = "On the Harmonic and Monogenic Decomposition of Polynomials", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 8, NUMBER = 3, PAGES = "297-304", MONTH = "September"} @INPROCEEDINGS{Bradford:86, AUTHOR = "R. J. Bradford and A. C. Hearn and J. A. Padget and E. Schr{\"u}fer", TITLE = "Enlarging the {REDUCE} Domain of Computation", BOOKTITLE = "Proc. of {SYMSAC} '86", YEAR = 1986, PAGES = "100-106"} @INPROCEEDINGS{Bradford:88, AUTHOR = "R. J. Bradford and J. H. Davenport", TITLE = "Effective Tests for Cyclotomic Polynomials", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "244-251"} @InProceedings{Bradford90, author = "Russell Bradford", title = "A parallelization of the {Buchberger} Algorithm", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "296", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Broadhurst:85, AUTHOR = "D. J. Broadhurst", TITLE = "Evaluation of a Class of {Feynman} Diagrams for all Numbers of Loops and Dimensions", JOURNAL = "Phys. Lett. B", YEAR = "1985", VOLUME = "164", PAGES = "356-360", COMMENT = {Uses {REDUCE} to calculate explicitly the l-loop member of a class of massless, dimensionally regularized {Feynman} diagrams, in order to verify an explicit formula.}} @ARTICLE{Broadhurst:91, AUTHOR = {D.J.Broadhurst and A.G.Grozin}, TITLE = {Two-loop renormalization of the effective field theory of a static quark}, JOURNAL = {Phys. Lett. B}, YEAR = 1991, VOLUME = 267, PAGES = {105-110}} @TECHREPORT{Broadhurst:91a, AUTHOR = {D.J.Broadhurst and A.G.Grozin}, TITLE = {Operator product expansion in static-quark effective theory: large perturbative corrections}, INSTITUTION = {Open University, Milton Keynes MK7 6AA, England}, YEAR = 1991, NUMBER = {OUT-4102-31}} @ARTICLE{Brodsky:62, AUTHOR = "S. J. Brodsky and A. C. Hearn and R. G. Parsons", TITLE = "Determination of the Real Part of the {Compton} Amplitude at a Nucleon Resonance", JOURNAL = "Phys. Rev.", YEAR = 1962, VOLUME = 187, PAGES = "1899-1904"} @ARTICLE{Brodsky:67, AUTHOR = "S. J. Brodsky and J. D. Sullivan", TITLE = "W-Boson Contribution to the Anomalous Magnetic Moment of the Muon", JOURNAL = "Phys. Rev.", YEAR = 1967, VOLUME = 156, PAGES = "1644-1647"} @INPROCEEDINGS{Brodsky:69, AUTHOR = "S. J. Brodsky", TITLE = "Status of Quantum Electrodynamics", YEAR = 1969, BOOKTITLE = "Proc. International Symposium on Electron and Photon Interactions at High Energies, Liverpool, England"} @TECHREPORT{Brodsky:70, AUTHOR = "S. J. Brodsky", TITLE = "Quantum Electrodynamic Theory: Its Relation to Precision Low Energy Experiments", INSTITUTION = "SLAC", YEAR = 1970, TYPE = "Report", NUMBER = "SLAC-PUB-795", MONTH = "August"} @INPROCEEDINGS{Brodsky:71, AUTHOR = "S. J. Brodsky", TITLE = "Algebraic Computation Techniques in Quantum Electrodynamics", YEAR = 1971, VOLUME = "II", PAGES = "IV-1 to IV-27", BOOKTITLE = "Proc. {2nd} Computing Methods in Theoretical Physics, Marseilles"} @TECHREPORT{Brodsky:72, AUTHOR = "S. J. Brodsky", TITLE = "Atomic Physics and Quantum Electrodynamics in the Infinite Momentum Frame", INSTITUTION = "SLAC", YEAR = 1972, TYPE = "Report", NUMBER = "SLAC-PUB-1118", MONTH = "August", COMMENT = {Presented at the Third International Conference on Atomic Physics.}} @ARTICLE{Brodsky:72a, AUTHOR = "S. J. Brodsky and J. F. Gunion and R. L. Jaffe", TITLE = "Test for Fractionally Charged Partons from Deep-Inelastic Bremsstrahlung in the Scaling Region", JOURNAL = "Phys. Rev. D", YEAR = 1972, VOLUME = 6, PAGES = "2487-2494"} @ARTICLE{Brodsky:72b, AUTHOR = "S. J. Brodsky and R. Roskies", TITLE = "Quantum Electrodynamics and Renormalization Theory in The Infinite Momentum Frame", JOURNAL = "Phys. Lett.", YEAR = 1972, VOLUME = "41B", PAGES = "517-520"} @ARTICLE{Brodsky:73, AUTHOR = "S. J. Brodsky and R. Roskies and R. Suaya", TITLE = "Quantum Electrodynamics and Renormalization Theory in the Infinite-Momentum Frame", JOURNAL = "Phys. Rev. D", YEAR = 1973, VOLUME = 8, PAGES = "4574-4594"} @ARTICLE{Broughan:82, AUTHOR = "K. A. Broughan", TITLE = "{Grad-Fokker-Planck} Plasma Equations. Part 1. {Collision} Moments", JOURNAL = "J. Plasma Phys.", YEAR = 1982, VOLUME = 27, PAGES = "437-452", COMMENT = {{REDUCE} used in collaboration with hand calculation. {REDUCE} did the substitutions, with hand integrations. "Thirteen moments are taken of the collision term in Boltzmann-Fokker-Planck equation{\ldots}plasma{\ldots}"}} @ARTICLE{Broughan:91, AUTHOR = "K. A. Broughan and G. Keady and T. D. Robb and M. G. Richardson and M. C. Dewar", TITLE = "Some Symbolic Computing Links to the {NAG} Numeric Library", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1991, VOLUME = 25, NUMBER = 3, PAGES = "28-37", MONTH = "July"} @ARTICLE{Brown:79, AUTHOR = "W. S. Brown and A. C. Hearn", TITLE = "Applications of Symbolic Algebraic Computation", JOURNAL = "Comp. Phys. Comm.", YEAR = 1979, VOLUME = 17, PAGES = "207-215", COMMENT = {This paper is a survey of applications of systems for symbolic algebraic computation.}} @ARTICLE{Bryan-Jones:87, AUTHOR = "Jane Bryan-Jones", TITLE = "A Tutorial in Computer Algebra for Statisticians", JOURNAL = "The Professional Statistician", YEAR = 1987, VOLUME = 6, NUMBER = 6, MONTH = "December",PAGES = "TBD"} @TECHREPORT{Burnel, AUTHOR = "A. Burnel and H. Caprasse", TITLE = "Locality in Class III Noncovariant Gauges", INSTITUTION = "Physique Th{\'e}orique et Math{\'e}matique, Universit{\'e} de Li{\`e}ge", ABSTRACT = {It is shown within a perturbative calculation of the gluon self-energy that, in the framework of a general formulation of linear gauges, axial gauges do not exhibit nonlocal counterterms.}} @TECHREPORT{Calmet:72, AUTHOR = "Jacques Calmet", TITLE = "Further Evaluation of the Sixth Order Corrections to the Anomalous Magnetic Moment of the Electron", INSTITUTION = "Department of Physics, University of Utah", YEAR = 1972, ABSTRACT = {We report on the contributions to the $\alpha^{3}$ part of the anomalous magnetic moment of the electron from the seven so-called cross and ladder diagrams.}} @ARTICLE{Calmet:72a, AUTHOR = "Jacques Calmet", TITLE = "A {REDUCE} Approach to the Calculation of {Feynman} Diagrams", JOURNAL = "Comp. Phys. Comm.", YEAR = 1972, VOLUME = 4, PAGES = "199-204", ABSTRACT = {A brief survey of two existing {REDUCE} programs (by Campbell-Hearn and by Calmet) dealing with algebraic computation of {Feynman} diagrams is given. Work in progress on a more general approach to this problem is discussed.}} @ARTICLE{Calmet:74, AUTHOR = "Jacques Calmet", TITLE = "Computer Recognition of Divergences in {Feynman} Graphs", JOURNAL = "SIGSAM Bulletin", YEAR = 1974, VOLUME = 8, NUMBER = 3, PAGES = "74-75", MONTH = "August", ABSTRACT = {A description of a program for the recognition of divergences in {Feynman} graphs is given.}} @INCOLLECTION{Calmet:83, AUTHOR = "J. Calmet and J. A. van Hulzen", TITLE = "Computer Algebra Applications", EDITOR = "B. Buchberger and G. E. Collins and R. Loos and R. Albrecht", BOOKTITLE = "Computer Algebra Symbolic and Algebraic Computation", EDITION = "2nd", PUBLISHER = "Springer-Verlag", YEAR = 1983} @ARTICLE{Campbell:67, AUTHOR = "J. A. Campbell", TITLE = "Algebraic Computation of Radiative Corrections for Electron-Positron Scattering", JOURNAL = "Nucl. Phys.", YEAR = 1967, VOLUME = "B1", PAGES = "283-300"} @ARTICLE{Campbell:68, AUTHOR = "J. A. Campbell", TITLE = "Astrophysical Consequences of the Existence of Charged Intermediate Vector Bosons", JOURNAL = "Aust. Journ. of Phys.", YEAR = 1968, VOLUME = 21, PAGES = "139-148"} @ARTICLE{Campbell:70, AUTHOR = "J. A. Campbell and A. C. Hearn", TITLE = "Symbolic Analysis of {Feynman} Diagrams by Computer", JOURNAL = "Journ. of Comp. Phys.", YEAR = 1970, VOLUME = 5, PAGES = "280-327"} @ARTICLE{Campbell:70a, AUTHOR = "J. A. Campbell and R. B. Clark and D. Horn", TITLE = "Low-T Theorems for Charged-Pion Photoproduction", JOURNAL = "Phys. Rev. D", YEAR = 1970, VOLUME = 2, PAGES = "217-224"} @ARTICLE{Campbell:74, AUTHOR = "J. A. Campbell", TITLE = "Symbolic Computing and Its Relationship to Particle Physics", JOURNAL = "Acta Physica Austriaca", YEAR = 1974, VOLUME = "Suppl. XIII", PAGES = "595-647"} @ARTICLE{Campbell:87, AUTHOR = "J. A. Campbell and P. O. Fr{\"o}man and E. Walles", TITLE = "Explicit series formulae for the evaluation of integrals by the method of steepest descents", JOURNAL = "Studies in Applied Mathematics", YEAR = 1987, VOLUME = 77, PAGES = "151-172"} @TECHREPORT{Caprasse:84, AUTHOR = "H. Caprasse", TITLE = "Description et Utilisation d'Une Extension du Programme {REDUCE}", INSTITUTION = "Physique Th{\'e}orique et Math{\'e}matique, Universit{\'e} de Li{\`e}ge", YEAR = 1984, MONTH = "October"} @ARTICLE{Caprasse:85, AUTHOR = "H. Caprasse and M. Hans", TITLE = "A New Use of Operators in the Algebraic Mode of {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "46-52", MONTH = "August"} @ARTICLE{Caprasse:86, AUTHOR = "H. Caprasse", TITLE = "Description of an Extension of the Matrix Package of {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1986, VOLUME = 20, NUMBER = 4, PAGES = "7-10", MONTH = "December"} @ARTICLE{Caprasse:86a, AUTHOR = "H. Caprasse", TITLE = "A Complete Simplification Package for the Absolute Value Function in {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1986, VOLUME = 20, NUMBER = "1 and 2", PAGES = "18-21", MONTH = "February and May", COMMENT = {Implementation for {REDUCE} 3.2 of the function {"ABS"}.}} @INPROCEEDINGS{Caprasse:88, AUTHOR = "H. Caprasse and J. Demaret and E. Schruefer", TITLE = "Can {EXCALC} be Used to Investigate {High-dimensional} Cosmological Models with {Non-Linear Lagrangians}?", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, PAGES = "116-124"} @ARTICLE{Caprasse:89a, AUTHOR = "H. Caprasse", TITLE = "Les Th{\'e}ories des {Champs} dans le monde de {REDUCE} (in {French})", JOURNAL = "{CALSYF} (to appear)", YEAR = 1989} @ARTICLE{Caprasse:90, AUTHOR = "H. Caprasse", TITLE = "Renormalization Group, Function Iterations and Computer Algebra", JOURNAL = "J. Symbolic Computation", YEAR = 1990, VOLUME = 9, NUMBER = 1, PAGES = "61-72", MONTH = "January", COMMENT = {Based on a renormalization group equation met in Quantum Field Theory, Continuous Iterations of a large class of functions are computed using {REDUCE}.}} @ARTICLE{Caprasse:91, AUTHOR = "H. Caprasse and J. Demaret and K. Gatermann and H. Melenk", TITLE = "Power-law type solutions of fourth-order gravity for multidimensional {Bianchi I} Universes", JOURNAL = "International Journal of Modern Physics C", YEAR = 1991, VOLUME = 2, NUMBER = 2, PAGES = "601-611", COMMENT = {This paper is devoted to the application of computer algebra to the study of solutions of the field equations derived from a non-linear Lagrangian, as suggested by recently proposed unified theories. More precisely, we restrict ourselves to the most general quadratic Lagrangian, i.e. containing quadratic contributions in the different curvature tensors exclusively. The corresponding field equations are then fourth-order in the metric tensor components. The cosmological models studied are the simplest ones in the class of spatially homogeneous but anisotropic models, i.e. Bianchi I models. For these models, we consider only power-law type solutions of the field equations. All the solutions of the associated system of algebraic equations are found, using computer algebra, from a search of its Groebner bases. While, in space dimension d=3, the Einsteinian-Kasner metric is still the most general power-law type solution, for d>3, no solution, other than the Minkowski space-time, is common to the three systems of equations corresponding to the three contributions to the Lagrangian density. In the case of a pure Riemann-squared contribution to the Lagrangian (suggested by a recent calculation of the effective action for the heterotic string), the possibility exists to realize a splitting of the d-dimensional space into a (d-3)-dimensional internal space and a physical 3-dimensional space, the latter expanding in time as a power bigger than 2 (about 4.5 when d=9).}} @ARTICLE{Carlson:80, AUTHOR = "P. Carlson", TITLE = "Coordinate Free Relativity", JOURNAL = "J. Math. Phys.", YEAR = 1980, VOLUME = 21, PAGES = "1149-1154", COMMENT = {{REDUCE} programs for tetrad formulation of GR.}} @PHDTHESIS{Carroll:73, AUTHOR = "R. Carroll", TITLE = "The Anomalous Magnetic Moment of the Electron in the Mass Operator Formalism", SCHOOL = "University of Michigan", YEAR = 1973} @ARTICLE{Carroll:75, AUTHOR = "R. Carroll", TITLE = "Mass-Operator Calculation of the Electron g-Factor", JOURNAL = "Phys. Rev. D", YEAR = 1975, VOLUME = 8, PAGES = "2344-2354"} @TECHREPORT{Cejchan, AUTHOR = "A. Cejchan and J. Nadrchal", TITLE = "Application of {REDUCE}-2 and Analytic Integration Program in the Theoretical Solid State Physics", INSTITUTION = "Institute of Physics, CSAV, Prague"} @INPROCEEDINGS{Chaffy:88, AUTHOR = "C. Chaffy-Camus", TITLE = "An Application of {REDUCE} to the Approximation of $f(x,y)$", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "73-84"} @ARTICLE{Chinnick:86, AUTHOR = "K. Chinnick and C. Gibson and J. F. Griffiths and W. Kordylewski", TITLE = "Isothermal Interpretations of Oscillatory Ignition During Hydrogen Oxidation in an Open System. {I}. {Analytical} Predictions and Experimental Measurements of Periodicity", JOURNAL = "Proc. Royal Soc. Lond.", YEAR = 1986, VOLUME = "A405", PAGES = "117-128", COMMENT = {Used {REDUCE} to solve Jacobian, but answer too complicated to be of any use.}} @ARTICLE{Cline:90, AUTHOR = "Terry Cline and Harold Abelson and Warren Harris", TITLE = "Symbolic Computing in Engineering Design", JOURNAL = "AI EDAM", YEAR = 1990, MONTH = "February"} @TECHREPORT{Cohen:76, AUTHOR = "H. I. Cohen and O. Leringe and Y. Sundblad", TITLE = "The Use of Algebraic Computing in General Relativity", INSTITUTION = "The Royal Institute of Technology Department of Mechanics", YEAR = 1976, NUMBER = "TRITA-MEK-76-02"} @TECHREPORT{Cohen:76a, AUTHOR = "I. Cohen and F. Bark", TITLE = "Perturbation Calculations for the Spin Up Problem Using {REDUCE}", INSTITUTION = "The Royal Institute of Technology, Department of Mechanics", YEAR = 1976, NUMBER = "TRITA-MEK-76-03"} @TECHREPORT{Cohen:77, AUTHOR = "I. Cohen and S. Yu. Slavyanov", TITLE = "Smooth Perturbations of the {Schr{\"o}dinger} Equation with a Linear Potential Related to the Charmonium Models", INSTITUTION = "University of Stockholm Institute of Physics", YEAR = 1977, TYPE = "USIP Report", NUMBER = "77-17"} @ARTICLE{Cohen:79, AUTHOR = "J. P. Fitch and H. I. Cohen", TITLE = "Using {CAMAL} for Algebraic Calculations in General Relativity", JOURNAL = "General Relativity and Gravitation", VOLUME = 11, YEAR = 1979, PAGES = "411-418"} @ARTICLE{Cohen:84, AUTHOR = "H. I. Cohen and I. B. Frick and J. E. {\AA}man", TITLE = "Algebraic Computing in General Relativity", JOURNAL = "General Relativity and Gravitation, ed.", YEAR = 1984, PAGES = "139-162", COMMENT = {General relativity review.}} @INPROCEEDINGS{Cohen:89, AUTHOR = "Joel S. Cohen", TITLE = "The Effective Use of Computer Algebra Systems", YEAR = 1989, PAGES = "677-698", BOOKTITLE = "Transactions of the Sixth Army Conference on Applied Mathematics and Computing", COMMENT = {Review of author's experience with four computer algebra systems.}} @ARTICLE{Connor:84, AUTHOR = "J. N. L. Connor and P. R. Curtis and D. Farrelly", TITLE = "The Uniform Asymptotic Swallowtail Approximation: Practical Methods for Oscillating Integrals with Four Coalescing Saddle Points", JOURNAL = "J. Phys. A", YEAR = 1984, VOLUME = 17, PAGES = "283-310", COMMENT = {Used {REDUCE} and {SCHOONSCHIP} for some algebraic manipulations, and then checked the results with {MACSYMA}; this is the most distrustful reference we have found.}} @ARTICLE{Connor:84a, AUTHOR = "J. N. L. Connor and P. R. Curtis and C. J. Edge and A. Lagan{`a}", TITLE = "The Uniform Asymptotic Swallowtail Approximation: Application to the Collinear $H+F_{2}$", JOURNAL = "J. Chem. Phys.", YEAR = 1984, VOLUME = 80, NUMBER = 3, PAGES = "1362-1363", MONTH = "February"} @ARTICLE{Conwell:84, AUTHOR = "P. R. Conwell and P. W. Barber and C. K. Rushworth", TITLE = "Resonant Spectra of Dielectric Sphere", JOURNAL = "J. Opt. Soc. Am. A", YEAR = 1984, VOLUME = 1, PAGES = "62-67", COMMENT = {{REDUCE} used to confirm independently convergence and accuracy of {Numerical Bessel} function routine, expanding series by {REDUCE} and using bigfloats. Described as slow but worthwhile.}} @INPROCEEDINGS{Cowan:79, AUTHOR = "Richard M. Cowan and Martin L. Griss", TITLE = "Hashing -- The Key to Rapid Pattern Matching", BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "266-278", PUBLISHER = "Springer-Verlag"} @ARTICLE{Cung:75, AUTHOR = "V. K. Cung", TITLE = "Differential Cross Section of e+ + e- to e+ + mu- + nubar(mu) + nubar(e)", JOURNAL = "Phys. Lett.", YEAR = 1975, VOLUME = "55B", PAGES = "67-70"} @TECHREPORT{Darbaidze:86, AUTHOR = "Ya. Z. Darbaidze", TITLE = "A Gluon Bremsstrahlung in Supersymmetry {QCD}", INSTITUTION = "JINR", YEAR = 1986, TYPE = "Preprint", NUMBER = "P2-86-825"} @ARTICLE{Darbaidze:86a, AUTHOR = "J. Z. Darbaidze and V. A. Matveev and Z. V. Merebashvili and L. A. Slepchenko", TITLE = "Gluon Bremsstrahlung in Supersymmetric {QCD}", JOURNAL = "Phys. Lett.", YEAR = 1986, VOLUME = "B177", PAGE = "188"} @TECHREPORT{Darbaidze:88, AUTHOR = "Ya. Z. Darbaidze and Z.V. Merebashvili and V.A. Rostovtsev", TITLE = "Some Computer Realizations of the {REDUCE-3} Calculations for Exclusive Processes", INSTITUTION = "JINR", YEAR = 1988, TYPE = "Preprint", NUMBER = "P2-88-769"} @TECHREPORT{Darbaidze:89, AUTHOR = "Ya. Z. Darbaidze and V.A. Rostovtsev", TITLE = "Analysis of the Differential Equations for the Exclusive Processes and Explanation for the {``Mystery''} of the {Gamma-Distribution}", INSTITUTION = "JINR", YEAR = 1989, TYPE = "Preprint", NUMBER = "E2-89-286"} @INPROCEEDINGS{Dautcourt:79, AUTHOR = "G. Dautcourt", TITLE = "Application of {REDUCE} to Algebraic Computations in General Relativity and Astrophysics", YEAR = 1979, MONTH = "September", BOOKTITLE = "Proc. of the Workshop in Symbolic Computation, Dubna, {U.S.S.R.}", COMMENT = {Reports the use of the system {REDUCE} 2 for general relativistic calculations.}} @TECHREPORT{Dautcourt:80, AUTHOR = "G. Dautcourt and K. P. Jann", TITLE = "A Program Package in {REDUCE} 2 for Algebraic Computations in General Relativity", YEAR = 1980, INSTITUTION = "Zentralinstitut fuer Astrophysik der Akademie der Wissenschaften"} @ARTICLE{Dautcourt:81, AUTHOR = "G. Dautcourt and K. P. Jann and E. Riemer and M. Riemer", TITLE = "User's Guide to {REDUCE} Subroutines For Algebraic Computations in General Relativity", JOURNAL = "Astron. Nachr.", YEAR = 1981, VOLUME = 302, PAGES = "1-13"} @ARTICLE{Dautcourt:83, AUTHOR = "G. Dautcourt", TITLE = "The Cosmological Problem as an Initial Value Problem on the Observer's Past Light Cone: Geometry", JOURNAL = "J. Phys. A", YEAR = 1983, VOLUME = 16, PAGES = "3507-3528", COMMENT = {Checked calculations with {REDUCE}, mainly {Riemann} tensor in null coordinates.}} @ARTICLE{Davenport:81, AUTHOR = "James Harold Davenport", TITLE = "On the Integration of Algebraic Functions", JOURNAL = "Lecture Notes in Computer Science", PUBLISHER = "Springer-Verlag", YEAR = 1981, VOLUME = 102, PAGES = "1-197"} @ARTICLE{Davenport:82, AUTHOR = "James H. Davenport", TITLE = "Fast {REDUCE:} The {trade-off} between efficiency and generality", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 1, PAGES = "8-11", MONTH = "February"} @ARTICLE{Davenport:82a, AUTHOR = "James H. Davenport", TITLE = "What do we want from a {high-level} language?", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "6-9", MONTH = "November"} @INPROCEEDINGS{Davenport:85, AUTHOR = "James Davenport and Julian Padget", TITLE = "{HEUGCD:} How Elementary Upperbounds Generate Cheaper Data", BOOKTITLE = "Proc. {EUROCAL} 1985, Lecture Notes in Computer Science", YEAR = 1985, VOLUME = 204, PAGES = "18-28", PUBLISHER = "Springer-Verlag"} @ARTICLE{Davenport:88, AUTHOR = "J. H. Davenport", TITLE = "The World of Computer Algebra", JOURNAL = "New Scientist", YEAR = 1988, MONTH = "September", VOLUME = 1629, PAGES = "71-72"} @BOOK{Davenport:88a, AUTHOR = "J. H. Davenport and Y. Siret and E. Tournier", TITLE = "Computer Algebra, Systems and Algorithms for Algebraic Computation", PUBLISHER = "Academic Press", PRINTING = "2nd", YEAR = 1989} @TECHREPORT{Della-Dora:81, AUTHOR = "J. Della Dora and E. Tournier", TITLE = "Solutions Formelles D'Equations Differentielles au Voisinage de Points Singuliers Reguliers", INSTITUTION = "Centre National de la Recherche Scientifique", YEAR = 1981, TYPE = "Report", NUMBER = 239} @INPROCEEDINGS{Della-Dora:84, AUTHOR = "J. Della Dora and E. Tournier", TITLE = "Homogeneous Linear Difference Equation {(Frobenius-Boole Method)}", BOOKTITLE = "Proc. {EUROSAM} 1984, Lecture Notes in Computer Science", YEAR = 1984, VOLUME = 174, PAGES = "2-12", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Della-Dora:85, AUTHOR = "Jean Della-Dora and Claire Dicrescenzo and Dominique Duval", TITLE = "About a New Method for Computing in Algebraic Number Fields", INSTITUTION = "Universit{\'e} de Grenoble, Institut Fourier, France", YEAR = 1985, MONTH = "November"} @ARTICLE{Demaret:89, AUTHOR = "J. Demaret and H. Caprasse and A. Moussiaux and Ph. Tombal and D. Papadopoulos", TITLE = "{Ten-dimensional Lovelock-type Space-Times}", JOURNAL = "{To appear} Phys. Rev. D", YEAR = 1989, MONTH = "July"} @ARTICLE{DeMenna:87, AUTHOR = "L. De Menna and G. Miano and G. Rubinacci", TITLE = "Volterra's Series Solutions of Free Boundary Plasma Equilibria", JOURNAL = "Phys. Fluids", YEAR = 1987, VOLUME = 30, PAGES = "409-416", COMMENT = {Magnetohydrodynamics. "We have carried out the computations up to the fourth order, (the fourth order has been obtained by means of the symbolic program {REDUCE}").}} @ARTICLE{Demichev:85, AUTHOR = "A. P. Demichev and A. Ya. Rodionov", TITLE = "A {REDUCE} Program for the Calculation of Geometrical Characteristics of Compactified Multidimensional {Riemannian} Space", JOURNAL = "Comp. Phys. Comm.", YEAR = 1985, VOLUME = 38, PAGES = "441-448", COMMENT = {Covariant theories in N dimensional ($N \geq 4$) space-time. {REDUCE} programs to calculate {Ricci, Einstein and Yang-Mills} curvature and energy-momentum tensor.}} @TECHREPORT{Demichev:86, AUTHOR = "A. P. Demichev and A. Ya. Rodionov", TITLE = "Freund-{Rubin} Type Solutions for Different Compactifications of the Eleven-Dimensional Space", INSTITUTION = "Institute for High Energy Physics", YEAR = 1986, TYPE = "Preprint", NUMBER = "86-85", ABSTRACT = {The results of calculating geometrical characteristics of seven-dimensional quotient spaces are represented. These quantities are necessary for the construction of compactifying solutions of the eleven-dimensional supergravity.}} @ARTICLE{deRop:88, AUTHOR = "Y. de Rop and J. Demaret", TITLE = "Using {EXCALC} to Study Nondiagonal Multidimensional Spatially Homogeneous Cosmologies", JOURNAL = "Gen. Rel. Grav.", YEAR = 1988, VOLUME = 20, PAGES = "1127-1139"} @TECHREPORT{DeVos:89, AUTHOR = "Alexis De Vos", TITLE = "The use of {Reduce} in solar energy conversion theory", INSTITUTION = "State University of Gent, {CAGe} Computer Algebra Group", YEAR = 1989, TYPE = "Reports of the {CAGe} Project", NUMBER = 4, MONTH = "August"} @INPROCEEDINGS{Dewar:89, AUTHOR = "M. C. Dewar", TITLE = "{IRENA --} An Integrated Symbolic and Numerical Computation Environment", BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York", YEAR = 1989, PAGES = "171-179"} @ARTICLE{Dhar:85, AUTHOR = "D. Dhar and J-M. Maillard", TITLE = "Susceptibility of the Checkerboard {Ising} Model", JOURNAL = "J. Phys. A", YEAR = 1985, VOLUME = 18, PAGES = "L383-L388", COMMENT = {Used {REDUCE} for tedious algebra, and got a simple answer. statistical mechanics(?). "At the disorder variety, the n-point correlation functions of the checkerboard Potts model has a simple causal structure. An exact expression for the susceptibility in the Ising case is obtained."}} @TECHREPORT{Dicrescenzo:85, AUTHOR = "Claire Dicrescenzo", TITLE = "Algebraic Computation on Algebraic Numbers", INSTITUTION = "Institut Fourier, Laboratoire de Math{\'e}matiques, France", YEAR = 1985, MONTH = "December", COMMENT = {Examples are given of a new method, implemented on {REDUCE}, for computing algebraically on algebraic numbers.}} @TECHREPORT{Diver, AUTHOR = "D. A. Diver and E. Q. Laing and C. C. Sellar", TITLE = "Waves in a Cold Plasma with a Spatially Rotating Magnetic Field", INSTITUTION = "Department of Physics and Astronomy, University of Glasgow, Plasma Physics Group", TYPE = "Report", NUMBER = "GU TPA 88/12-1", COMMENT = {"{\ldots}The algebraic manipulation system {REDUCE} was used in constructing the following tensor definitions which allows us to make fewer approximations than other authors."}} @INPROCEEDINGS{Diver:86, AUTHOR = "D. A. Diver and E. W. Laing", TITLE = "Proc. 8th {Europhysics} Conference on Computational Physics", YEAR = 1986, BOOKTITLE = "Computing in Plasma Physics"} @INPROCEEDINGS{Diver:88, AUTHOR = "D. A. Diver and E. W. Laing", TITLE = "Proc. {XV} {European} Conference on Controlled Fusion and Plasma Heating", YEAR = 1988} @TECHREPORT{Diver:88a, AUTHOR = "D. A. Diver and E. W. Laing", TITLE = "Alfven Resonance Absorption in a Magnetofluid", YEAR = 1988, TYPE = "Internal Report", NUMBER = "GUTPA 88/04-01", MONTH = "July", COMMENT = {Presented at 15th {UK} Plasma Physics Conference, {UMIST}.}} @ARTICLE{Diver:91, AUTHOR = "D. A. Diver", TITLE = "Modelling Waves with Computer Algebra", JOURNAL = "J. Symbolic Computation", YEAR = 1991, VOLUME = 11, NUMBER = 3, PAGES = "275-289", MONTH = "March", ABSTRACT = {A sophisticated model for linear waves in an inhomogeneous plasma is tackled completely using the computer algebra system {REDUCE}. The algebra code mirrors the mathematics, and is structured in a simple and straightforward manner. In so doing, the solution technique is made obvious, and the overall philosophy of the approach is intuitive to the {non-specialist} computer algebra user.}} @TECHREPORT{Dorfi:85, AUTHOR = "E. A. Dorfi and L. O'C. Drury", TITLE = "Simple Adaptive Grids for {1D} Initial Value Problems", INSTITUTION = "Max-Plack-Institut fuer Kernphysik, Heidelberg, West Germany", YEAR = 1985, NUMBER = "MPI H-1985-V21"} @ARTICLE{Dorizzi:86, AUTHOR = "B. Dorizzi and B. Grammaticos and J. Hietarinta and A. Ramani and F. Schwarz", TITLE = "New integrable three dimensional quartic potentials", JOURNAL = "Phys. Lett.", YEAR = 1986, VOLUME = "116A", PAGES = "432-436", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @TECHREPORT{dosSantos:85, AUTHOR = "R. P. dos Santos and P. P. Srivastava", TITLE = "Two-loop Effective Potential for {Wess-Zumino} Model using Superfields", INSTITUTION = "International Centre for Theoretical Physics", YEAR = 1985, NUMBER = "IC/85/205", MONTH = "October", ABSTRACT = {For the case of several interacting chiral superfields the propagators for the unconstrained superfield potentials in the 'shifted' theory, where the supersymmetry is explicitly broken, are derived in a compact form. They are used to compute one-loop effective potential in the general case, while a superfield calculation of renormalized effective potential to two loops for the Wess-Zumino model is performed.}} @ARTICLE{dosSantos:87, AUTHOR = "Renato P. dos Santos", TITLE = "Using {REDUCE} in Supersymmetry", JOURNAL = "J. Symb. Comp.", YEAR = 1989, VOLUME = 7, PAGES = "523-525"} @PHDTHESIS{dosSantos:87a, AUTHOR = "R. P. dos Santos", TITLE = "O M{\'e}todo de Supercampos para o C{\'a}lculo de Potencial Efetivo em Modelos com Supercampos Quirais: Os Modelos de Wess e Zumino e de O'Raifeartaigh", SCHOOL = "Centro Brasileiro de Pesquisas F{\'i}sicas", YEAR = 1987, COMMENT = {{(In Portuguese)} Using the method of {Superfields}, the effective potential for supersymmetric models of {Wess-Zumino} and of {O'Raifeartaigh} is evaluated up to two-loop order. The spontaneous supersymmetry breaking is discussed. {REDUCE} plays very important role in evaluation of the {Feynman} superdiagrams and in renormalization.}} @TECHREPORT{dosSantos:88a, AUTHOR = "Renato P. dos Santos", TITLE = "Introdu\c{c}\~{a}o ao Sistema {REDUCE} de C\'{a}lculo Alg\'{e}brico", INSTITUTION = "CBPF, Rio de Janeiro, Brazil", YEAR = 1988, NUMBER = "CBPF-NT-001/88", COMMENT = {{(In Portuguese)} Lecture notes of a course on {REDUCE}.}} @ARTICLE{dosSantos:90, AUTHOR = "R. P. dos Santos and W. L. Roque", TITLE = "On the Design of an Expert Help System for Computer Algebra Systems", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1990, VOLUME = 24, NUMBER = 4, PAGES = "22-25", MONTH = "October"} @ARTICLE{Drska:90, AUTHOR = "Ladislav Drska and Richard Liska and Milan Sinor", TITLE = "Two practical packages for computational physics{-GCPM, RLFI}", JOURNAL = "Comp. Phys. Comm.", YEAR = 1990, VOLUME = 61, NUMBER = "1-2", MONTH = "November", PAGES = "225-230", ABSTRACT = {Two handy computer-program packages for technical support of the work in two different branches of the computational physics are reported: (1) A general package for the symbolic and numerical transformation of expressions from one system of units to another. (2) A package allowing high-quality two-dimensional output of mathematical formulas from the computer-algebra system {REDUCE}.}} @ARTICLE{Dubowsky:75, AUTHOR = "S. Dubowsky and J. L. Grant", TITLE = "Application of Symbolic Manipulation to Time Domain Analysis of Nonlinear Dynamic Systems", JOURNAL = "Journ. of Dynamic Systems, Measurement, and Control", YEAR = 1975, NUMBER = "75-Aut-J"} @ARTICLE{Dudley:89, AUTHOR = "M. L. Dudley and R. W. James", TITLE = "{Computer-aided} Derivation of Spherical Harmonic Spectral Equations in Astrogeophyics", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 8, NUMBER = 4, PAGES = "423-427", MONTH = "October"} @ARTICLE{Dufner:69, AUTHOR = "A. M. Dufner and Y. S. Tsai", TITLE = "Phenomenological Analysis of the $\gamma$NN* Form Factors", JOURNAL = "Phys. Rev.", YEAR = 1969, VOLUME = 168, PAGES = "1801-1809"} @INPROCEEDINGS{Dulyan:87, AUTHOR = "L. S. Dulyan", TITLE = "The Calculation of {QCD} Triangular {Feynman} Graphs in the External Gluonic Field Using {REDUCE}-2 System", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "172-173", PUBLISHER = "Springer-Verlag"} @ARTICLE{Duncan:86, AUTHOR = "Anthony Duncan and Ralph Roskies", TITLE = "Representations of Unusual Mathematical Structures in Scientific Applications of Symbolic Computation", JOURNAL = "J. Symbolic Computation", YEAR = 1986, VOLUME = 2, NUMBER = 2, PAGES = "201-206", MONTH = "June", ABSTRACT = {We present examples of techniques we have used to apply {REDUCE} to problems in particle physics which have mathematical structures unknown to {REDUCE}.}} @PHDTHESIS{Duval:87, AUTHOR = "Dominique Duval", TITLE = "Diverses questions relatives au Calcul Formel Avec des Nombres Alg{\'e}briques", SCHOOL = "L'Universit{\'e} Scientifique, Technologique et M{\'e}dicale de Grenoble", YEAR = 1987} @ARTICLE{Earles:70, AUTHOR = "D. Earles", TITLE = "A Measurement of the Electron-Production of Muon Pairs", JOURNAL = "Phys. Rev. Lett.", YEAR = 1970, VOLUME = 25, PAGES = "129-133"} @ARTICLE{Eastwood:87, AUTHOR = "James W. Eastwood", TITLE = "Orthovec: A {REDUCE} Program for {3-D} Vector Analysis in Orthogonal Curvilinear Coordinates", JOURNAL = "Comp. Phys. Commun.", YEAR = 1987, VOLUME = 47, NUMBER = 1, PAGES = "139-147", MONTH = "October"} @TECHREPORT{Eastwood:87a, AUTHOR = "James W. Eastwood and Christopher J. H. Watson", TITLE = "An Analytic Theory of {Wave-Current} Interactions", INSTITUTION = "Culham Laboratory, Theory and Optics Division", YEAR = 1987, NUMBER = "Plasma Physics Note 87/7", MONTH = "February", ABSTRACT = {This report presents results of the Department of Energy contract to obtain high order analytic solutions to nonlinear hydrodynamic equation describing steady periodic waves propagating in sheared currents. The purpose of this work is to provide working formulae for computing combined wave and current loadings in the design of offshore structures. Using the {REDUCE} algebra package, we have identified minor typographical errors in the published fifth coefficients for uniform currents given by {Fenton [2]} and by Skjelbreia and {Hendrickson [5]}. We have demonstrated the equivalence of corrected forms of these expressions to fifth order, and extended Fenton's expansion to seventh order. We present a new fifth order theory for bilinear current profiles. {FORTRAN} software for the seven order uniform current and fifth order bilinear current theories are given.}} @ARTICLE{Eastwood:91, AUTHOR = "James W. Eastwood", TITLE = "{ORTHOVEC:} version 2 of the {REDUCE} program for {3-D} vector analysis in orthogonal curvilinear coordinates", JOURNAL = "Comp. Phys. Commun.", YEAR = 1991, VOLUME = 64, NUMBER = 1, PAGES = "121-122", MONTH = "April"} @TECHREPORT{Edelen:81, AUTHOR = "Dominic G. B. Edelen", TITLE = "Programs for Calculation of Isovector Fields in the {REDUCE}-2 Environment", INSTITUTION = "Center for the Application of Mathematics, Lehigh University", YEAR = 1981, NUMBER = "TBD", MONTH = "August"} @ARTICLE{Edelen:82, AUTHOR = "D. G. B. Edelen", TITLE = "Isovector Fields for Problems in the Mechanics of Solids and Fluids", JOURNAL = "Int. Journ. Eng. Sci.", YEAR = 1982, VOLUME = 20, PAGES = "803-815", COMMENT = {Prolongation methods as a {REDUCE} package for this, available from Center for Applications of Mathematics, Lehigh Univ., Bethlehem, PA 18015. Applications to mechanics of solids and fluids.}} @BOOK{Edneral:89, AUTHOR = "Viktor F. Edneral and Aleksandr P. Kryukov and Anatolii Ia. Rodionov", TITLE = "The language of the analytic computer program {REDUCE}", PUBLISHER = "Moscow, {Izd-vo}, Moskovskogo {un-ta}", YEAR = 1989, COMMENT = {This monograph -- first in The Soviet Union with a systematic treatment of the analytical computer (program) {REDUCE}.}} @ARTICLE{Eisenberger:90, AUTHOR = "Moshe Eisenberger", TITLE = "Application of Symbolic Algebra to the Analysis of Plates on Variable Elastic Foundation", JOURNAL = "J. Symbolic Computation", YEAR = 1990, VOLUME = 9, NUMBER = 2, PAGES = "207-213", MONTH = "February"} @TECHREPORT{Eissfeller:86, AUTHOR = "Bernd Ei{\ss}feller and G{\"u}nter W. Hein", TITLE = "A Contribution to {3D-Operational} Geodesy", INSTITUTION = "Universit{\"a}rer Studiengang Vermessungswesen and Universit{\"a}t der Bundeswehr M{\"u}nchen", YEAR = 1986, NUMBER = "Heft 17", MONTH = "December"} @PHDTHESIS{Eitelbach:73, AUTHOR = "D. L. Eitelbach", TITLE = "Automatic Analysis of Problems in Elementary Mechanics", SCHOOL = "University of Illinois", YEAR = 1973} @ARTICLE{Eleuterio:82, AUTHOR = "S. M. Eleut{\'e}rio and R. V. Mendes", TITLE = "Note on Equivalence and Singularities: An Application of Computer Algebra", JOURNAL = "Journ. Comp. Phys.", YEAR = 1982, VOLUME = 48, PAGES = "150-156", COMMENT = {{GR} equivalence, commenting on \AAman & Karlhede.}} @ARTICLE{Eliseev:85, AUTHOR = "V. P. Eliseev and R. N. Fedorova and V. V. Kornyak", TITLE = "A {REDUCE} Program for Determining Point and Contact {Lie} Symmetries of Differential Equations", JOURNAL = "Comp. Phys. Comm.", YEAR = 1985, VOLUME = 36, PAGES = "383-389", ABSTRACT = {A universal {REDUCE} program for obtaining the systems of determining equations of the Lie algebra of point and contact symmetries is proposed.}} @ARTICLE{Elishakoff:87, AUTHOR = "Isaac Elishakoff and Joseph Hollkamp", TITLE = "Computerized Symbolic Solution for a Nonconservative System in Which Instability Occurs by Flutter in One Range of a Parameter and by Divergence in Another", JOURNAL = "Comp. Methods in Applied Mechanics and Engineering", YEAR = 1987, VOLUME = 62, PAGES = "27-46", COMMENT = {"{\ldots}the problem is solved by the {Galerkin} method in conjunction with computerized symbolic algebra". The system used is {REDUCE}. "It carries out algebraic operations irrespective of their complexity". Includes snatches of code and algebraic answers. Mainly differentiation and substitution, plus a little integration. The coefficients get rather large (18 digits or so).}} @ARTICLE{Elishakoff:87a, AUTHOR = "Isaac Elishakoff and Brian Couch", TITLE = "Application of Symbolic Algebra to the Instability of a Nonconservative System", JOURNAL = "J. Symbolic Computation", YEAR = 1987, VOLUME = 4, NUMBER = 3, PAGES = "391-396", MONTH = "December"} @ARTICLE{Esteban:90, AUTHOR = "E.P. Esteban and E. Ramos", TITLE = "Algebraic computing and the {Newman-Penrose} formalism", JOURNAL = "Computers in Physics", YEAR = 1990, PAGES = "285-290", MONTH = "May/June"} @ARTICLE{Falck:89, AUTHOR = "N. K. Falck and D. Graudenz and G. Kramer", TITLE = "Cross section for {five-parton} production in $e^{+} e^{-}$ annihilation", JOURNAL = "Comp. Phys. Comm.", YEAR = 1989, VOLUME = 56, PAGES = "181-198", NUMBER = 2, MONTH = "December"} @ARTICLE{Fazio:84, AUTHOR = "P. M. Fazio and G. E. Copeland", TITLE = "Cooper-Type Minima in Multipole Cross Sections of Atomic Hydrogen", JOURNAL = "Phys. Rev. Lett.", YEAR = 1984, VOLUME = 53, NUMBER = "2", MONTH = "July"} @INPROCEEDINGS{Fedorova:87, AUTHOR = "R. N. Fedorova and V. P. Gerdt and N. N. Govorun and V. P. Shirikov", TITLE = "Computer Algebra in Physical Research of {Joint Institute} for {Nuclear Research}", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "1-10", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Fedorova:87a, AUTHOR = "R. N. Fedorova and V. V. Kornyak", TITLE = "Computer Algebra Application for Determining Local Symmetries of Differential Equations", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "174-175", PUBLISHER = "Springer-Verlag"} @ARTICLE{Feldmar:86, AUTHOR = "E. Feldmar and K. S. K{\"o}lbig", TITLE = "{REDUCE} Procedures for the Manipulation of Generalized Power Series", JOURNAL = "Comp. Phys. Comm.", YEAR = 1986, VOLUME = 39, PAGES = "267-284"} @ARTICLE{Feuillebois:84, AUTHOR = "F. Feuillebois", TITLE = "Sedimentation in a Dispersion with Vertical Inhomogenieties", JOURNAL = "Journ. Fluid Mech.", YEAR = 1984, VOLUME = 139, PAGES = "145-171", COMMENT = {Uses {REDUCE} and {INT} to evaluate some integrals in the expansion of 1/s, a small quantity.}} @ARTICLE{Fitch:73, AUTHOR = "John Fitch", TITLE = "Problems \#3 and \#4 in {REDUCE} and {MACSYMA}", JOURNAL = "SIGSAM Bulletin", YEAR = 1973, PAGES = "10-11", ABSTRACT = {The algebra systems {REDUCE} and {MACSYMA} are used to solve {SIGSAM} Problem \#3, the Reversion of a Double Series, and {SIGSAM} Problem \#4, the Lie Transform Solution of the Harmonic Oscillator.}} @INPROCEEDINGS{Fitch:81, AUTHOR = "J. P. Fitch", TITLE = "User-based Integration Software", BOOKTITLE = "Proc. 1981 {ACM} Symposium on Symbolic and Algebraic Computation", YEAR = 1981, PAGES = "245-248"} @INPROCEEDINGS{Fitch:83, AUTHOR = "J. P. Fitch", TITLE = "Implementing {REDUCE} on a Microprocessor", BOOKTITLE = "Proc. {EUROCAL} 1983, Lecture Notes in Computer Science", YEAR = 1983, VOLUME = 162, PAGES = "128-136", PUBLISHER = "Springer-Verlag"} @ARTICLE{Fitch:85, AUTHOR = "J. P. Fitch", TITLE = "Solving Algebraic Problems with {REDUCE}", JOURNAL = "J. of Symbolic Computation", YEAR = 1985, VOLUME = 1, NUMBER = 2, PAGES = "211-227", MONTH = "June"} @INPROCEEDINGS{Fitch:85a, AUTHOR = "J. P. Fitch", TITLE = "Applying Computer Algebra", BOOKTITLE = "International Conference on Computer Algebra and its Application in Theory", YEAR = 1985, PAGES = "262-275"} @INPROCEEDINGS{Fitch:87, AUTHOR = "J. P. Fitch", TITLE = "Utilisation du Calcul Formel", BOOKTITLE = "Calcul Formel et Automatique", EDITOR = "P. Chenin", PUBLISHER = "Editions du {CNRS}", YEAR = 1987, PAGES = "119-136"} @INPROCEEDINGS{Fitch:87a, AUTHOR = "J. P. Fitch and R. G. Hall", TITLE = "Symbolic Computation and the Finite Element Method", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "95-96", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Fitch:89, AUTHOR = "J. P. Fitch", TITLE = "Can {REDUCE} be run in parallel?", BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York", YEAR = 1989, PAGES = "155-162"} @ARTICLE{Fitch:89a, AUTHOR = "J. Fitch", TITLE = "Compiling for Parallelism", JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora and J. Fitch", YEAR = 1989, PAGES = "19-31", PUBLISHER = "Academic Press, London"} @InProceedings{Fitch90, author = "J. P. Fitch", title = "A delivery system for {REDUCE}", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "76-81", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Fitch:90a, AUTHOR = "John Fitch", TITLE = "The symbolic-numeric interface", JOURNAL = "Comp. Phys. Comm.", YEAR = 1990, VOLUME = 61, NUMBER = "1-2", MONTH = "November", PAGES = "22-33", ABSTRACT = {Algebraic computation can be of great assistance in the preparation of numerical programs. The paper considers some of these, from simple to complex, and describes work currently in progress to produce a true integrated symbolic-numeric computing system.}} @TECHREPORT{Flatau:86, AUTHOR = "Piotr J. Flatau and John P. Boyd and William R. Cotton", TITLE = "Symbolic Algebra in Applied Mathematics and Geophysical Fluid Dynamics - {REDUCE} Examples", INSTITUTION = "Dept. of Atmospheric and Oceanic Science, University of Michigan, and Dept. of Atmospheric Science, Colorado State University", YEAR = 1986} @TECHREPORT{Flath:86, AUTHOR = "Dan Flath", TITLE = "Remarks on Tensor Operators", INSTITUTION = "National University of Singapore, Department of Mathematics", TYPE = "Research Report", YEAR = 1986, NUMBER = 266, MONTH = "July"} @ARTICLE{Fleischer:71, AUTHOR = "J. Fleischer", TITLE = "Partial Wave Analysis of Nucleon-Nucleon {Bethe}-{Salpeter} Equation on the Computer", JOURNAL = "Journ. of Comp. Phys.", YEAR = 1971, VOLUME = 12, PAGES = "112-123"} @ARTICLE{Fleischer:73, AUTHOR = "J. Fleischer and J. L. Gammel and M. T. Menzel", TITLE = "Matrix {Pad\'e} Approximants for the {1SO}- and {3PO}- Partial Waves in Nucleon-Nucleon Scattering", JOURNAL = "Phys. Rev. D", YEAR = 1973, VOLUME = 8, PAGES = "1545-1552"} @ARTICLE{Fleischer:75, AUTHOR = "J. Fleischer and J. A. Tjon", TITLE = "Bethe-{Salpeter} Equation for {J}=0 Nucleon-Nucleon Scattering with One-Boson Exchange", JOURNAL = "Nuclear Physics", YEAR = 1975, VOLUME = "B84", PAGES = "375-396"} @ARTICLE{Fogelholm:82, AUTHOR = "Rabbe Fogelholm and Inge B. Frick", TITLE = "Standard {LISP} for the {VAX:} A Provisional Implementation", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "10-12", MONTH = "November"} @ARTICLE{Foster:89, AUTHOR = "Kenneth R. Foster and Haim H. Bau", TITLE = "Symbolic Manipulation Programs for the Personal Computer", JOURNAL = "Science", YEAR = 1989, VOLUME = 243, PAGES = "679-243", MONTH = "February", COMMENT = {Reviews several algebra programs that run on small machines. doesn't rate the {PC} version of {REDUCE} very highly because of the small workspace.}} @ARTICLE{Fox:71, AUTHOR = "J. A. Fox", TITLE = "Recalculation of the Crossed Graph Contribution to the 4th Order {Lamb} Shift", JOURNAL = "Phys. Rev. D", YEAR = 1971, VOLUME = 3, PAGES = "3228-3230"} @ARTICLE{Fox:74, AUTHOR = "John A. Fox and Anthony C. Hearn", TITLE = "Analytic Computation of Some Integrals in Fourth Order Quantum Electrodynamics", JOURNAL = "Journ. Comp. Phys.", YEAR = 1974, VOLUME = 14, PAGES = "301-317", ABSTRACT = {A program for the analytic evaluation of some parametric integrals which occur in fourth order {QED} calculations is described.}} @ARTICLE{Franceschetti:85, AUTHOR = "G. Franceschetti and I. Pinto", TITLE = "Nonlinear Propagation and Scattering: Analytical Solution and Symbolic Code Implementation", JOURNAL = "J. Opt. Soc. Am. A", YEAR = 1985, VOLUME = 2, PAGES = "997-1006", COMMENT = {Volterra series using {REDUCE}. Perturbation expansions.}} @INPROCEEDINGS{Freire:88, AUTHOR = "E. Freire and E. Gamero and E. Ponce and L. G. Franquelo", TITLE = "An Algorithm for Symbolic Computation of Center Manifolds", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "218-230"} @INPROCEEDINGS{Freire:89, AUTHOR = "E. Freire and E. Gamero and E. Ponce", TITLE = "An Algorithm for Symbolic Computation of {Hopf} Bifurcation", BOOKTITLE = "Proc. Computers and Mathematics '89", EDITOR = "E. Kaltofen and S. M. Watt", YEAR = 1989, PAGES = "109-118", PUBLISHER = "Springer-Verlag, New York"} @TECHREPORT{Frick:82, AUTHOR = "I. G. Frick and R. Fogelholm", TITLE = "An Implementation of {Standard} {Lisp} Built on Top of {Franz Lisp}", INSTITUTION = "University of Stockholm, Institute of Physics", YEAR = 1982, TYPE = "Report", MONTH = "April", COMMENT = {A Standard {LISP} system has been built for the {VAX-11} large-address-space computer by embedding the required function definitions in the available Franz Lisp system for {VAX/UNIX}.}} @ARTICLE{Fujimoto:84, AUTHOR = "Y. Fujimoto and T. Garavaglia", TITLE = "Phase Diagrams in {Scalar QED}", JOURNAL = "Physics Letters", YEAR = 1984, VOLUME = "148B", NUMBER = "1,2,3", PAGES = "220-224", MONTH = "November"} @ARTICLE{Fuzio:85, AUTHOR = "P. M. Fuzio and G. E. Copeland", TITLE = "Partial Radiative-Recombination Cross Sections for Excited States of Hydrogen", JOURNAL = "Phys. Rev. A", YEAR = 1985, VOLUME = 31, NUMBER = 1, PAGES = "187-195", ABSTRACT = {The squares of the dipole and quadrupole matrix elements for the free-to-bond transitions of hydrogen uptp high bound states are derived in closed analytic form using a method suitable for computer algebra.}} % REDUCE BIBLIOGRAPHY % Part 2: G-L % Copyright (c) 1990 The RAND Corporation. All Rights Reserved. % Additions and corrections are solicited. Please send them, in the % same format as these entries if possible, to reduce at rand.org. @TECHREPORT{Gaemers, AUTHOR = "K. J. F. Gaemers and R. Gastmans and F. M. Renard", TITLE = "Neutrino Counting in e+ e- Collisions", INSTITUTION = "NIKHEF-H, Amsterdam", TYPE = "Preprint", ABSTRACT = {The possibility of counting the number of neutrino types in e+ e- $\rightarrow$ gamma nu nubar is re-examined by taking into account effects of the Z-pole.}} @TECHREPORT{Gaemers:78, AUTHOR = "K. J. F. Gaemers and G. J. Gounaris", TITLE = "Polarization Amplitudes For e+e- $\rightarrow$ W+W- $\rightarrow$ ZZ", INSTITUTION = "CERN", YEAR = 1978, TYPE = "Preprint", NUMBER = "TH.2548-CERN", MONTH = "August", ABSTRACT = {The main purpose of this work is to study the three weak boson vertex. We give explicit formulae for all polarization amplitudes of the processes e+e- $\rightarrow$ W+W- and e+e- $\rightarrow$ ZZ, with arbitrary couplings between the various intermediate vector bosons.}} @INPROCEEDINGS{Ganzha:89, AUTHOR = "V. Ganzha and R. Liska", TITLE = "Application of the {REDUCE} Computer Algebra System to Stability Analysis of Difference Schemes", BOOKTITLE = "Proc. Computers and Mathematics '89", EDITOR = "E. Kaltofen and S. M. Watt", YEAR = 1989, PAGES = "119-129", PUBLISHER = "Springer-Verlag, New York"} @InProceedings{Ganzha90, author = "Victor G. Ganzha and Michail Yu. Shaskov", title = "Local Approximation Study of Difference Operators by means of {REDUCE} System", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "185-192", organization = "ACM", publisher = "Addison-Wesley" } @InProceedings{Ganzha90a, author = "V. G. Ganzha and S. V. Meleshko and V. P. Shelest", title = "Application of {REDUCE} System for Analyzing Consistency of Systems of {P.D.E.'s}", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "301", organization = "ACM", publisher = "Addison-Wesley" } @INPROCEEDINGS{Ganzha:91, AUTHOR = "V.G. Ganzha and B. Yu. Scobelev and E.V. Vorozhtsov", TITLE = "Stability Analysis of Difference Schemes by the Catastrophe Theory Methods and by Means of Computer Algebra", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "427-428", YEAR = 1991} @TECHREPORT{Garavaglia, AUTHOR = "Theodore Garavaglia", TITLE = "Polarized Electron Scattering on Spin Zero and Polarized Spin $\frac{1}{2}$ Targets: Deep Inelastic Scattering, Elastic Electron-muon Scattering, and Elastic Electron-Nucleon Scattering", INSTITUTION = "Inst. Teich. Bhaile Atha Cliath, Eire", TYPE = "Preprint", ABSTRACT = {A covariant formulation is developed and used to derive cross-sections for the analysis of experiments in which polarized electrons(muons) are scattered from spin zero and from polarized spin 1/2 targets.}} @ARTICLE{Garavaglia:80, AUTHOR = "T. Garavaglia", TITLE = "A Covariant Formulation for Polarized Electron (Muon) Scattering on Spin-Zero and Polarized Spin-$\frac{1}{2}$ Targets", JOURNAL = "Il Nuovo Cimento", YEAR = 1980, VOLUME = "56A", PAGES = "121-128", COMMENT = {{REDUCE} used in quantum mechanics.}} @ARTICLE{Garavaglia:84, AUTHOR = "Theodore Garavaglia", TITLE = "{Dirac-} and {Majorana-neutrino-mass} effects in {neutrino-electron} elastic scattering", JOURNAL = "Physical Review {D}", YEAR = 1984, VOLUME = 29, NUMBER = 3, PAGES = "387-392", MONTH = "February"} @ARTICLE{Garcia:86, AUTHOR = "Arnaldo Garcia and Paulo Viana", TITLE = "Weierstrass Points on Certain Non-Classical Curves", JOURNAL = "Arch. Math.", YEAR = 1986, VOLUME = 46, PAGES = "315-322"} @ARTICLE{Garrad:86, AUTHOR = "A. D. Garrad and D. C. Quarton", TITLE = "Symbolic Computing as a Tool in Wind Turbine Dynamics", JOURNAL = "Journ. of Sound and Vibration", YEAR = 1986, VOLUME = 109, NUMBER = 1, PAGES = "65-78", COMMENT = {{REDUCE} as a tool in turbine design, in particular present a program for part of a stability analysis for a turbine tower.}} @ARTICLE{Gastmans:79, AUTHOR = "R. Gastmans and A. van Proeyen and P. Verbaeten", TITLE = "Symbolic Evaluations of Dimensionally Regularized {Feynman} Diagrams", JOURNAL = "Comp. Phys. Comm.", YEAR = 1979, VOLUME = 18, PAGES = "201-203", ABSTRACT = {A modification of the symbolic and algebraic manipulation program {REDUCE} is reported which allows the treatment of vector and gamma algebra in an arbitrary number of dimensions.}} @TECHREPORT{Gatermann:90, AUTHOR = "Karin Gatermann", TITLE = "Gruppentheoretische {Konstruktion} von symmetrischen {Kubaturformeln}", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1990, TYPE = "Preprint", NUMBER = "TR 90-1", MONTH = "January"} @InProceedings{Gatermann90a, author = "Karin Gatermann", title = "Symbolic solution of polynomial equation systems with symmetry", booktitle = "Proceedings of the 1990 International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "112-119", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Gatermann:91, AUTHOR = "Karin Gatermann and Andreas Hohmann", TITLE = "Symbolic Exploitation of Symmetry in Numerical Pathfollowing", JOURNAL = "IMPACT of Computing in Science and Engineering", YEAR = 1991, MONTH = "December", VOLUME = 3, NUMBER = 4, PAGES = "330-365", ABSTRACT = {{Parameter-dependent} systems of nonlinear equations with symmetry are treated by a combination of symbolic and numerical computations. In the symbolic part of the algorithm the complete analysis of the symmetry occurs, and it is here where symmetrical normal forms, symmetry reduced systems, and block diagonal Jacobians are computed. Given a particular problem, the symbolic algorithm can create and compute through the list of possible bifurcations thereby forming a {so-called} tree of decisions correlated to the different types of symmetry breaking bifurcation points. The remaining part of the algorithm deals with the numerical pathfollowing based on the implicit reparametrisation as suggested and worked out by {Deuflhard/Fiedler/Kunkel}. The symmetry preserving bifurcation points are computed using recently developed augmented systems incorporating the use of symmetry.}} @INPROCEEDINGS{Gatermann:91a, AUTHOR = "Karin Gatermann", TITLE = "Mixed symbolic-numeric solution of symmetrical nonlinear systems", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", ORGANIZATION = "ACM", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "431-432", YEAR = 1991, ABSTRACT = {The mixed symbolic-numeric algorithm {SYMCON} for the fully automatical treatment of equivariant systems is presented. The global aspects of the theory of Vanderbauwhede for these systems are viewed with regard to the full bifurcation scenario containing solution paths with different isotropy groups and symmetry preserving and symmetry breaking bifurcation points. The advanced exploitation of symmetry in the numerical computations causes an comprehensive symmetry analysis and complicated organization of numerical work which is done by the symbolic part of the algorithm.}} @TECHREPORT{Gatermann:91b, AUTHOR = "Karin Gatermann and Andreas Hohmann", TITLE = "Hexagonal Lattice Dome--Illustration of a Nontrivial Bifurcation Problem", INSTITUTION = "Konrad-Zuse-Zentrum {f\"u}r Informationstechnik Berlin", YEAR = 1991, MONTH = "July", TYPE = "Preprint", NUMBER = "SC-91-8"} ABSTRACT = {The deformation of a hexagonal lattice dome under an external load is an example of a parameter dependent system which is equivariant under the symmetry group of a regular hexagon. In this paper the mixed symbolic-numerical algorithm SYMCON is applied to analyze its steady state solutions automatically showing their different symmetry and stability properties.}} @INPROCEEDINGS{Gates:85, AUTHOR = "Barbara L. Gates and J. A. van Hulzen", TITLE = "Automatic Generation of Optimized Programs", BOOKTITLE = "Proc. {EUROCAL} '85", YEAR = 1985, MONTH = "April"} @ARTICLE{Gates:85a, AUTHOR = "Barbara L. Gates", TITLE = "Gentran: An Automatic Code Generation Facility for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "24-42", MONTH = "August"} @TECHREPORT{Gates:85b, AUTHOR = "Barbara L. Gates", TITLE = "Gentran User's Manual - {REDUCE} Version", INSTITUTION = "Twente University of Technology, Department of Computer Science, The Netherlands", TYPE = "Memorandum", YEAR = 1985, NUMBER = "INF-85-11", MONTH = "June"} @TECHREPORT{Gates:85c, AUTHOR = "Barbara L. Gates", TITLE = "Gentran Design and Implementation, {REDUCE} Version", INSTITUTION = "Twente University of Technology, Department of Computer Science, The Netherlands", YEAR = 1985, TYPE = "Memorandum", NUMBER = "INF-85-12", MONTH = "August"} @INPROCEEDINGS{Gates:86, AUTHOR = "Barbara L. Gates", TITLE = "A Numerical Code Generation Facility for {REDUCE}", BOOKTITLE = "Proc. {SYMSAC} '86", YEAR = 1986, PAGES = "94-99", MONTH = "July"} @TECHREPORT{Gebauer:85, AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller", TITLE = "A Fast Variant of {Buchberger's} Algorithm", INSTITUTION = "Universit{\"a}t Heidelberg and Fernuniversit{\"a}t {Hagen}", YEAR = 1985, MONTH = "October"} @ARTICLE{Gebauer:88, AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller", TITLE = "On an Installation of {Buchberger's} Algorithm", JOURNAL = "J. Symbolic Computation", YEAR = 1988, VOLUME = 6, NUMBER = "2 and 3", PAGES = "275-286"} @ARTICLE{George:68, AUTHOR = "D. J. George", TITLE = "A Covariant Theory of the Disintegration of the Deuteron by Pions and Photons at High Energy", JOURNAL = "Phys. Rev.", YEAR = 1968, VOLUME = 167, PAGES = "1357-1364"} @ARTICLE{Gerdt:80, AUTHOR = "V. P. Gerdt", TITLE = "Analytical Calculations in High Energy Physics by Computer", JOURNAL = "Comp. Phys. Comm.", YEAR = 1980, VOLUME = 20, PAGES = "85-90", COMMENT = {A review, comparing {SCHOONSCHIP, ASHMEDAI and REDUCE-2}.}} @ARTICLE{Gerdt:80a, AUTHOR = "V. P. Gerdt and O. V. Tarasov and D. V. Shirkov", TITLE = "Analytical Calculations on Digital Computers for Applications in Physics and Mathematics", JOURNAL = "Sov. Phys. USP", YEAR = 1980, VOLUME = 23, PAGES = "59-77", COMMENT = {General review of applications in many languages.}} @TECHREPORT{Gerdt:80b, AUTHOR = "V. P. Gerdt", TITLE = "On Global Structure of the General Solution of the {Chew-Low} Equations", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1980, TYPE = "Preprint", NUMBER = "P2-80-436"} @ARTICLE{Gerdt:85, AUTHOR = "V. P. Gerdt and A. B. Shvachka and A. Yu. Zharkov", TITLE = "Computer Algebra Application for Classification of Integrable Non-Linear Evolution Equations", JOURNAL = "J. Symb. Comp.", YEAR = 1985, VOLUME = 1, PAGES = "101-107"} @TECHREPORT{Gerdt:85a, AUTHOR = "V. P. Gerdt and N. A. Kostov and P. P. Raychev and R. P. Roussev", TITLE = "Calculation of the Matrix Elements of the {Hamiltonian} of the Interacting Vector Boson Model Using Computer Algebra - Basic Concepts of the Interacting Vector Boson Model and Matrix Elements of the {SU(3)-Quadrupole} Operator", INSTITUTION = "Institute for Nuclear Research and Nuclear Energy, Bulgarian Academy of Sciences, Sofia, Bulgaria", YEAR = 1985, NUMBER = "E4-85-262"} @TECHREPORT{Gerdt:85b, AUTHOR = "V. P. Gerdt and N. A. Kostov and P. P. Raychev", TITLE = "Calculation of the Matrix Elements of the {Hamiltonian} of the Interacting Vector Boson Model Using Computer Algebra - Matrix Elements of the {Hamiltonian} and Some {U(6)-Clebsch-Gordon} Coefficients", INSTITUTION = "Institute for Nuclear Research and Nuclear Energy, Bulgarian Academy of Sciences, Sofia, Bulgaria", YEAR = 1985, NUMBER = "E4-85-263"} @TECHREPORT{Gerdt:85c, AUTHOR = "V. P. Gerdt and N. A. Kostov and P. P. Raychev and R. P. Roussev", TITLE = "Calculation of the Matrix Elements of the {Hamiltonian} of the Interacting Vector Boson Model Using Computer Algebra - Matrix Elements of the {Hamiltonian} - Analytical Results", INSTITUTION = "Institute for Nuclear Research and Nuclear Energy, Bulgarian Academy of Sciences, Sofia, Bulgaria", YEAR = 1985, NUMBER = "E4-85-264"} @TECHREPORT{Gerdt:86, AUTHOR = "V. P. Gerdt and M. G. Meshcheryakov and D. V. Shirkov", TITLE = "Computers in Theoretical Physics", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1986, NUMBER = "P2-86-848", ABSTRACT = {The paper is written on the basis of the report presented by two authors ({M.G. Meshcheryakov} and {D.V. Shirkov}) at the 60th session of the JINR Scientific Council, June 5, 1986. It reviews the usage of computer mathematics in theoretical and mathematical investigations carried out in the Joint Institute. Recommendations are given on further development of the JINR Computer Center in accordance with the program of theoretical researches in nearest Five-Year Plan.}} @INPROCEEDINGS{Gerdt:87, AUTHOR = "V. P. Gerdt and A. B. Shabat and S. I. Svinolupov and A. Yu. Zharkov", TITLE = "Computer Algebra Application for Investigating Integrability of Nonlinear Evolution Systems", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "81-92", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Gerdt:87a, AUTHOR = "V. P. Gerdt and N. A. Kostov and Z. T. Kostova", TITLE = "Computer Algebra and Computation of {Puiseux} Expansions of Algebraic Functions", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "206-207", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Gerdt:89, AUTHOR = "V. P. Gerdt and N. A. Kostov", TITLE = "Computer Algebra in the theory of Ordinary Differential Equations of Halphen type", BOOKTITLE = "Proc. Computers and Mathematics '89", EDITOR = "E. Kaltofen and S. M. Watt", YEAR = 1989, PAGES = "279-288", PUBLISHER = "Springer-Verlag, New York"} @TECHREPORT{Gerdt:89a, AUTHOR = "V. P. Gerdt and Z. T. Kostova and N. A. Kostov and I. P. Yudin", TITLE = "Algebraic-Numeric Calculations of Proton Trajectories in Bending Magnets of Synchrotron Accelerator", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1989, TYPE = "Preprint", NUMBER = "E11-89-755", ABSTRACT = {We study a solution of nonlinear differential equation of the second degree which describes the trajectories of the charged particles in the fully inhomogeneous field of cyclic accelerator. We give the clear mathematical statement of the problem and algorithm of solving it. We realize this algorithm on the Computer Algebra System {REDUCE 3.2}. Our algorithm is based both on the existence of exact solution in terms of hyperelliptic integral and on the existence of power series solution of specific inversion problem. We use the known {REDUCE} procedures of operation on generalized power series. Using the {FORTRAN} code we give the numerical analysis of these series in the close relation to the concrete physical situation. We apply our results to the beam dynamics modeling of the protons in the bending magnets in synchrotron accelerator.}} @TECHREPORT{Gerdt:89b, AUTHOR = "V. P. Gerdt and A. Yu. Zharkov", TITLE = "Solving the Polynomial System Arising in Classification of Integrable Coupled {KdV-like} Systems", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1989, TYPE = "Preprint", NUMBER = "P5-89-231", ABSTRACT = {A system of algebraic equations which follows from the necessary integrability conditions for the {ten-parametric} family of coupled {KdV-like} nonlinear evolution systems is considered. The method for solving this system based on the structure of the canonical local conservation laws densities is described. Computer algebra system {REDUCE} was used to find all the solutions. As a result we obtain the complete list of integrable coupled {KdV-like} systems.}} @InProceedings{Gerdt90, author = "V. P. Gerdt and A. Yu. Zharkov", title = "Computer Generation of Necessary Integrability Conditions for Polynomial-Nonlinear Evolution Systems", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "250-254", organization = "ACM", publisher = "Addison-Wesley" } @InProceedings{Gerdt90a, author = "Vladimar P. Gerdt and Nikolai V. Khutornoy and Alexey Yu. Zharkov", title = "Solving Algebraic Systems which arise as Necessary Integrability Conditions for Polynomial-Nonlinear evolution Equations", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "299", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Gerdt:90b, AUTHOR = "V. P. Gerdt and A. Yu. Zharkov", TITLE = "Computer Classification of Integrable Coupled {KdV-Like} Systems", JOURNAL = "J. Symb. Comp.", YEAR = 1990, VOLUME = 10, PAGES = "203-207", ABSTRACT = {The foundations of the symmetry approach to the classification problem of integrable {non-linear} evolution systems are briefly described. Within the framework of the symmetry approach the {ten-parametric} family of the third order {non-linear} evolution coupled {KdV-like} systems is investigated. The necessary integrability conditions lead to an {over-determined} {non-linear} algebraic system. To solve that system an effective method based on its structure has been used. This allows us to obtain the complete list of integrable systems of a given type. All computation has been completed on the basis of computer algebra systems {FORMAC} and {REDUCE}.}} @INPROCEEDINGS{Gerdt:90c, AUTHOR = "V. P. Gerdt and N. A. Kostov and A. Yu. Zharkov", TITLE = "Nonlinear Evolution Equations and Solving Algebraic Systems: The Importance of Computer Algebra", YEAR = 1990, BOOKTITLE = "International Conference on Solitons and Its Applications", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "120-128"} ABSTRACT = {In the present paper we study the application of computer algebra to solve the nonlinear polynomial systems which arise in investigation of nonlinear evolution equations. We consider several systems which are obtained in classification of integrable nonlinear evolution equations with uniform rank. Other polynomial systems are related with the finding of algebraic curves for finite-gap elliptic potentials of {Lame} type and generalizations. All systems under consideration are solved using the method based on construction of the {Groebner} basis for corresponding polynomial ideals. The computations have been carried out using computer algebra systems.}} @INPROCEEDINGS{Gerdt:91, AUTHOR = "V. P. Gerdt and A. Yu. Zharkov", TITLE = "Lie-B{\"a}cklund Symmetries of Coupled Nonlinear Schr{\"o}dinger Equations", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "313-314", YEAR = 1991} @TECHREPORT{Gerdt:91a, AUTHOR = "V. P. Gerdt and P. Tiller", TITLE = "A Reduce Program for Symbolic Computation of Puiseux Expansions", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1991, TYPE = "Preprint", NUMBER = "E5-91-401"} ABSTRACT = {The program is described for computation of Puiseux expansions of alebraic functions. The Newton polygon method is used for construction of initial coefficients of all the Puiseux series at the given point. The program is written in computer algebra language Reduce. Some illustrative examples are given.}} @TECHREPORT{Gerdt:91b, AUTHOR = "V. P. Gerdt", TITLE = "Computer Algebra Tools for Higher Symmetry Analysis of Nonlinear Evolution Equations", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1991, TYPE = "Preprint", NUMBER = "E5-91-402"} ABSTRACT = {This paper presents a computer-aided approach and a software package for symbolic algebraic computation to solve the problem of verifying the existence of the canonical Lie-B{\"a}cklund symmetries for multicomponent quasilinear evolution equations with polynomial- nonlinearity and computing a given order symmetry if any. In the presence of arbitrary numerical parameters the problem is reduced to investigation and solving of nonlinear algebraic equations in those parameters. It is remarkable that in all the known cases these algebraic equations are completely solvable by the Gr{\"o}bner basis technique implemented as a part of the software package.}} @ARTICLE{Gervois:74, AUTHOR = "A Gervois and Y. Pomeau", TITLE = "Logarithmic Divergence in the Virial Expansion of Transport Coefficients of Hard Spheres", JOURNAL = "Phys. Rev. A", YEAR = 1974, VOLUME = 9, PAGES = "2196-2213"} @TECHREPORT{Gladd:82, AUTHOR = "N. T. Gladd", TITLE = "Computational Aspects of Research on the Relativistic {Whistler} Instability", INSTITUTION = "Jaycor", YEAR = 1982, NUMBER = "J530-82-020", MONTH = "June"} @INPROCEEDINGS{Gladkih:83, AUTHOR = "I. Gladkih and E. Lovas", TITLE = "On the Application of Computer Algebra Languages in the {Central Research Institute for Physics}", BOOKTITLE = "Proceedings of the International Conference on Systems and Techniques of Analytical Computing and Their Applications in Theoretical Physics, {D11-83-511, Dubna}", YEAR = 1983} @INPROCEEDINGS{Gladkih:84, AUTHOR = "I. Gladkih and M. Zimanyi", TITLE = "Comparison of systems for Symbolic Computing in use in the {Central Research Institute for Physics} (in {Russian})", BOOKTITLE = "Proceedings of the International Conference on {Computer-Based} Scientific Research, Plovdiv", YEAR = 1984} @ARTICLE{Goldman:89, AUTHOR = "V. V. Goldman and J. A. van Hulzen", TITLE = "Automatic Code Vectorization of Arithmetic Expressions by Bottom-Up Structure Recognition", JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora and J. Fitch", YEAR = 1989, PAGES = "119-132", PUBLISHER = "Academic Press, London"} @INPROCEEDINGS{Golley, AUTHOR = "Bruce W. Golley and Joseph Petrolito", TITLE = "An Alternative Finite Strip Technique for the Static Analysis of Single-Span, Multi-Span and Continuous Plates", YEAR = 1982, BOOKTITLE = "Proc. International Conference on Finite Element Methods"} @ARTICLE{Good:75, AUTHOR = "D. Good and R. L. London and W. W. Bledsoe", TITLE = "An Interactive Program Verification System", JOURNAL = "Sigplan Notices", YEAR = 1975, VOLUME = 10, NUMBER = 6, PAGES = "482-492"} @ARTICLE{Goto:77, AUTHOR = "E. Goto and T. Soma", TITLE = "{MOL} (Moving Objective Lens) Formulation of Deflective Aberration Free System", JOURNAL = "Optik", YEAR = 1977, VOLUME = 48, PAGES = "255-270"} @INPROCEEDINGS{Goto:78, AUTHOR = "E. Goto and T. Soma", TITLE = "Electron Beam Lithography for Advanced {LSI} Fabrication", YEAR = 1978, PAGES = "1223-1228", BOOKTITLE = "Proc. 1978 National Computer Conference, {AFIPS} Press, New Jersey"} @ARTICLE{Gould:84, AUTHOR = "H. W. Gould and M. E. Mays", TITLE = "Series Expansions of Means", JOURNAL = "Journ. of Mathematical Analysis and Applications", YEAR = 1984, VOLUME = 101, NUMBER = 2, PAGES = "611-621", MONTH = "July"} @PHDTHESIS{Gragert:81, AUTHOR = "Peter Gragert", TITLE = "Symbolic Computations in Prolongation Theory", SCHOOL = "Twente University of Technology, The Netherlands", YEAR = 1981} @BOOK{Grammaticos, AUTHOR = "B. Grammaticos and A. Voros", TITLE = "Semi-Classical Approximations for Nuclear {Hamiltonians}: {II}. {Spin-dependent} Potentials", ABSTRACT = {A systematic semi-classical expansion procedure for physical quantities in nuclei, based on the Thomas-Fermi approximation to the Hartree-Fock equations and constructed in a previous work, is extended here to the realistic case where the effective one-body {Hamiltonian} for nucleons contains spin-dependent terms.}} @TECHREPORT{Grammaticos:78, AUTHOR = "B. Grammaticos and A. Voros", TITLE = "Semi-classical Approximations for Nuclear {Hamiltonians} {I}. {Spin-independent} Potentials", INSTITUTION = "CEN, Saclay", YEAR = 1978, TYPE = "Preprint", NUMBER = "DPh-T/78-75", MONTH = "August", COMMENT = {Submitted to Annals of Physics}, ABSTRACT = {A systematic procedure for calculating semi-classical expansions of physically interesting quantities is presented.}} @ARTICLE{Grammaticos:85, AUTHOR = "B. Grammaticos and B. Dorizzi and A. Ramani and J. Hietarinta", TITLE = "Extending integrable {Hamiltonian} systems from 2 to {N} dimensions", JOURNAL = "Phys. Lett.", YEAR = 1985, VOLUME = "109A", PAGES = "81-84", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Greenland:84, AUTHOR = "P. T. Greenland", TITLE = "Comparison Between Phase Diffusion and Random Telegraph Signal Models of Laser Bandwidth", JOURNAL = "Journ. Phys. B", YEAR = 1984, VOLUME = 17, PAGES = "1919-1925", COMMENT = {{REDUCE} calculation of correlation matrix for molecular physics. Tedious, but simple result.}} @ARTICLE{Grimm, AUTHOR = "R. Grimm and H. K{\"u}hnelt", TITLE = "Using {REDUCE} in Problems of Supersymmetry and Supergravity", JOURNAL = "Comp. Phys. Comm.", YEAR = 1980, VOLUME = 20, PAGES = "77", COMMENT = {Describes how {REDUCE} may be used with advantage in tedious calculations of supersymmetry and supergravity.}} @INPROCEEDINGS{Griss:74, AUTHOR = "M. L. Griss", TITLE = "The Algebraic Solution of Large Sparse Systems of Linear Equations Using {REDUCE} 2", YEAR = 1974, PAGES = "105-111", BOOKTITLE = "Proc. ACM 74", ABSTRACT = {This paper discusses some of the problems encountered during the solution of a large system of sparse linear equations with algebraic coefficients, using {REDUCE} 2.}} @ARTICLE{Griss:74a, AUTHOR = "M. L. Griss", TITLE = "The Algebraic Solution of Sparse Linear Systems Via Minor Expansion", JOURNAL = "ACM TOMS 2", YEAR = 1976, PAGES = "31-49", ABSTRACT = {An improved algorithm for computing the determinants of a (large) sparse matrix of polynomials is described.}} @INPROCEEDINGS{Griss:75, AUTHOR = "Martin L. Griss", TITLE = "The {REDUCE} System for Computer Algebra", BOOKTITLE = "Proc. ACM 75", YEAR = 1975, PAGES = "4-5", ABSTRACT = {A brief description of {REDUCE} is presented.}} @INPROCEEDINGS{Griss:76, AUTHOR = "Martin L. Griss", TITLE = "The Definition and Use of Data-Structures in {REDUCE}", BOOKTITLE = "Proc. SYMSAC 76", YEAR = 1976, PAGES = "53-59", ABSTRACT = {This paper gives a brief description and motivation of the mode analyzing and data-structuring extensions to the algebraic language {REDUCE}.}} @INPROCEEDINGS{Griss:76a, AUTHOR = "Martin L. Griss", TITLE = "An Efficient Sparse Minor Expansion Algorithm", BOOKTITLE = "Proc. ACM 76", YEAR = 1976, PAGES = "429-434", ABSTRACT = {An improved algorithm for computing the minors of a (large) sparse matrix of polynomials is described, with emphasis on efficiency and optimal ordering. A possible application to polynomial resultant computation is discussed.}} @INPROCEEDINGS{Griss:77, AUTHOR = "Martin L. Griss", TITLE = "Efficient Expression Evaluation in Sparse Minor Expansion, Using Hashing and Deferred Evaluation", YEAR = 1977, PAGES = "169-172", BOOKTITLE = "Proc. 10th Hawaii International Conference on Systems Sciences, Western Periodicals, Calif.", ABSTRACT = {Efficient computation of the determinant of a matrix with symbolic entries using minor expansion requires careful control of expression evaluation. The use of hashing and deferred evaluation to avoid excess computation is explored.}} @ARTICLE{Griss:77a, AUTHOR = "M. L. Griss", TITLE = "Efficient Recursive Minor Expansion", JOURNAL = "ACM TOMS", YEAR = 1977, ABSTRACT = {The use of a "memo" facility to develop an efficient recursive minor expansion algorithm (RMEM) is discussed. The method is simple and efficient, and can be implemented as an interesting non-trivial recursive procedure. The method is particularly attractive for sparse symbolic matrices, and can also be used to enhance other minor expansion methods developed for sparse symbolic matrices.}} @ARTICLE{Griss:78, AUTHOR = "Martin L. Griss", TITLE = "Using an Efficient Sparse Minor Expansion Algorithm to Compute Polynomial Subresultants and the Greatest Common Denominator", JOURNAL = "IEEE Trans on Computers", YEAR = 1978, VOLUME = "C-27", NUMBER = 10, PAGES = "945-950", ABSTRACT = {In this paper, the use of an efficient sparse minor expansion method to directly compute the subresultants needed for the {GCD} of two polynomials is described. The sparse minor expansion method (applied either to Sylvester's or Bezout's matrix) naturally computes the coefficients of the subresultants in the order corresponding to a {PRS}, avoiding wasteful recomputation as much as possible. It is suggested that this is an efficient method to compute the Resultant and {GCD} of Sparse Polynomials.}} @INPROCEEDINGS{Griss:78a, AUTHOR = "Martin L. Griss and Robert R. Kessler", TITLE = "{REDUCE}/1700: A Micro-coded Algebra System", YEAR = 1978, VOLUME = 11, PAGES = "130-138", BOOKTITLE = "Proc. Micro, {IEEE}", ABSTRACT = {In this paper, we report on the status of an ongoing project aimed at producing a micro-coded Algebra machine.}} @ARTICLE{Griss:79, AUTHOR = "Martin L. Griss and Anthony C. Hearn", TITLE = "Portable {LISP} Compiler", JOURNAL = "Software - Practice and Experience", VOLUME = 11, PAGES = "541-605", YEAR = 1979, ABSTRACT = {This paper describes the development of a portable {LISP} compiler in the sense that only Standard {LISP} functions are used in its definition and the output is a sequence of standard macro calls easily implementable on current computers.}} @TECHREPORT{Griss:79a, AUTHOR = "Martin L. Griss and Robert R. Kessler", TITLE = "A Micro-programmed Implementation of {Standard} {LISP} and {REDUCE} on the {Burroughs B1700/B1800} Computer", INSTITUTION = "University of Utah", YEAR = 1979, TYPE = "Report", MONTH = "February", ABSTRACT = {This paper describes the implementation of a microcoded {LISP} "machine" (the MTLISP) for the Burroughs B1700/B1800 computers. This interpreter supports a complete Standard {LISP} and {REDUCE} Algebra system, as well as a variety of experimental {LISP-like} systems.}} @INPROCEEDINGS{Grozin:83, AUTHOR={A.G.Grozin}, TITLE={Calculation of one-loop diagrams of {$1 \to 2$} decays with REDUCE}, BOOKTITLE={Proc. Int. Conf. on Computer Algebra in Theoretical Physics, Dubna}, YEAR = 1983, PAGES = {226-231}, COMMENT = {To appear in Phys. Lett. B}} @TECHREPORT{Grozin:88, AUTHOR = "A. G. Grozin", TITLE = "Solving Physical Problems with {REDUCE.} {1. REDUCE} Language {2. Classical} Nonlinear Oscillator", INSTITUTION = "Institute of Nuclear Physics 630090, Novosibirsk, {USSR}", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-115", ABSTRACT = {This preprint is the first part of the problem book on using {REDUCE} in physics. It contains many examples useful for the construction of programs for solving physical problems of very different nature. This part contains examples illustrating {REDUCE} language (sect. 1) and the problem of classical nonlinear oscillator (sect. 2). To be published (with additions) as a book with "Nauka" publishers, Moscow.}} @TECHREPORT{Grozin:88a, AUTHOR = "A. G. Grozin", TITLE = "Solving Physical Problems with {REDUCE.} {3. Nonlinear} Water Waves {4. Calculation} of the Curvature Tensor {5. Angular} Momentum Addition", INSTITUTION = "Institute of Nuclear Physics 630090, Novosibirsk, {USSR}", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-136", ABSTRACT = {This preprint is the second part of the problem book on using {REDUCE} in physics. It contains many examples useful for the construction of programs for solving physical problems of very different nature. This part contains the problem of nonlinear water waves (sect. 3), the calculation of the curvature tensor (sect. 4) and angular momentum addition (sect. 5).}} @TECHREPORT{Grozin:88b, AUTHOR = "A. G. Grozin", TITLE = "Solving Physical Problems with {REDUCE.} {6. Quantum} Nonlinear Oscillator {7. Rotator} in a Weak Field {8. Radiative} Transitions in Charmonium", INSTITUTION = "Institute of Nuclear Physics 630090, Novosibirsk, {USSR}", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-140", ABSTRACT = {This preprint is the last part of the problem book on using {REDUCE} in physics. It contains many examples useful for the construction of programs for solving physical problems of very different nature. This part contains the problem of quantum nonlinear oscillator (sect. 6), rotator in a weak field (sect. 7) and radiative transitions in charmonium (sect. 8).}} @TECHREPORT{Grozin:90, AUTHOR = {A.G.Grozin}, TITLE = {{REDUCE} in elementary particle physics. Introduction}, INSTITUTION = {Institute of Nuclear Physics, Novosibirsk}, YEAR = 1990, NUMBER = {INP 90-42}, COMMENT = {These 5 preprints together with the previous 3 will be published as a book "Solving physical problems with REDUCE"}} @TECHREPORT{Grozin:90a, AUTHOR = {A.G.Grozin}, TITLE = {{REDUCE} in elementary particle physics. Quantum electrodynamics}, INSTITUTION = {Institute of Nuclear Physics, Novosibirsk}, YEAR = 1990, NUMBER = {INP 90-71}} @TECHREPORT{Grozin:90b, AUTHOR = {A.G.Grozin}, TITLE = {{REDUCE} in elementary particle physics. Quantum chromodynamics}, INSTITUTION = {Institute of Nuclear Physics, Novosibirsk}, YEAR = 1990, NUMBER = {INP 90-62}} @TECHREPORT{Grozin:91, AUTHOR = {A.G.Grozin}, TITLE = {{REDUCE} in elementary particle physics. Weak interactions}, INSTITUTION = {Institute of Nuclear Physics, Novosibirsk}, YEAR = 1991, NUMBER = {INP 91-56}} @TECHREPORT{Grozin:91a, AUTHOR = {A.G.Grozin}, TITLE = {{REDUCE} in elementary particle physics. Radiative corrections}, INSTITUTION = {Institute of Nuclear Physics, Novosibirsk}, YEAR = 1991, NUMBER = {INP 91-46}} @ARTICLE{Gunion:72, AUTHOR = "J. F. Gunion and S. J. Brodsky and R. Blankenbecler", TITLE = "Composite Theory of Large Angle Scattering and New Tests of Parton Concepts", JOURNAL = "Phys. Lett.", YEAR = 1972, VOLUME = "39B", PAGES = "649-653"} @TECHREPORT{Gunion:73, AUTHOR = "J. F. Gunion and S. J. Brodsky and R. Blankenbecler", TITLE = "Large Angle Scattering and the Interchange Force", INSTITUTION = "SLAC", YEAR = 1973, TYPE = "Report", NUMBER = "SLAC-PUB-1183"} @ARTICLE{Gunion:85, AUTHOR = "J. F. Gunion and Z. Kunszt", TITLE = "Improved Analytic Techniques for Tree Graph Calculations and the $g g q {\bar q} l {\bar l}$ subprocess", JOURNAL = "Phys. Lett.", YEAR = 1985, VOLUME = "161B", PAGES = "333-340"} @ARTICLE{Hadinger:87, AUTHOR = "G. Hadinger and Y. S. Tergimen", TITLE = "Recurrence Relations for the {Dunham} Coefficients and Analytic Expressions of the Diagonal Radial Matrix Elements for an Anharmonic Oscillator", JOURNAL = "Journ. Chem. Phys.", YEAR = 1987, VOLUME = 87, NUMBER = 4, PAGES = "2143-2150", COMMENT = {"As an illustrative application, all the set of $Y_{n}$ coefficients previously published are found again by using the computer algebraic manipulation language {REDUCE}. A number of diagonal matrix elements of {CO, HBr and HCl} have been symbolically computed and compared with previous available results." Their method depends on some algebraic manipulation, and the main point is that automation gives a simpler formulation of the problem.}} @ARTICLE{Handy:87, AUTHOR = "N. C. Handy", TITLE = "The Derivation of Vibration-Rotation Kinetic Energy Operators, in Internal Coordinates", JOURNAL = "Mol. Phys.", YEAR = 1987, VOLUME = 61, PAGES = "207-223", COMMENT = {{REDUCE USED} to produce a straightforward method for the derivation of kinetic energy operators in molecular vibration-rotation. He notes in the introduction "The purpose of this paper is to derive a simple and straightforward procedure for which it is possible to make the computer do all the hard work. After many years of investigating this problem, this author believes that this must be the reliable way to proceed."}} @PHDTHESIS{Harper:87, AUTHOR = "David Harper", TITLE = "Dynamics of the Outer Satellites of Saturn", SCHOOL = "Univ. of Liverpool, England", YEAR = 1987} @TECHREPORT{Harper:89, AUTHOR = "David Harper and Chris Wooff and David Hodgkinson", TITLE = "A Guide to Computer Algebra Systems", INSTITUTION = "Computer Laboratory, The University of Liverpool, Liverpool, England", YEAR = 1989, MONTH = "September", TYPE = "Report"} @ARTICLE{Harper:89a, AUTHOR = "David Harper", TITLE = "{Vector33:} A {REDUCE} Program for Vector Algebra and Calculus in Orthogonal Curvilinear Coordinates", JOURNAL = "Comp. Phys. Comm.", YEAR = 1989, VOLUME = 54, NUMBER = "2 and 3", PAGES = "295-305", MONTH = "June and July"} @ARTICLE{Harrington:77, AUTHOR = "Steven J. Harrington", TITLE = "A Symbolic Limit Evaluation Program in {REDUCE}", YEAR = 1977, ABSTRACT = {A program for the automatic evaluation of algebraic limits, implemented in {MODE-REDUCE}, is described. The program incorporates many of the techniques previously employed, including the top-down recursive evaluation, power series expansion, and L'Hopital's rule. It also introduces the concept of a special algebraic form for limits.}} @ARTICLE{Harrington:77a, AUTHOR = "S. J. Harrington", TITLE = "{REDUCE} Solution to Problem \#8", JOURNAL = "{SIGSAM} Bulletin", YEAR = "1977 and 1978", VOLUME = "11 and 12", NUMBER = "4 and 1", PAGES = "7-8", MONTH = "November and February"} @ARTICLE{Harrington:79, AUTHOR = "Steven J. Harrington", TITLE = "A New Symbolic Integration System in {REDUCE}", JOURNAL = "Comp. Journ.", YEAR = 1979, VOLUME = 22, NUMBER = 2, PAGE = "127-131", ABSTRACT = {A new integration system, employing both algorithmic and pattern match integration schemes is presented. The organization of the system differs from that of earlier programs in its emphasis on the algorithmic approach to integration, its modularity, and its ease of revision. The new {Norman-Risch} algorithm and its implementation at the University of Cambridge are employed, supplemented by a powerful collection of simplification and transformation rules. The facility for user defined integrals and functions is also included. The program is both fast and powerful, and can be easily modified to incorporate anticipated developments in symbolic integration.}} @ARTICLE{Harrington:79a, AUTHOR = "Steven J. Harrington", TITLE = "A Symbolic Limit Evaluation Program in {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1979, VOLUME = 13, NUMBER = 1, PAGES = "27-31", MONTH = "February"} @ARTICLE{Hartley:91, AUTHOR = "David Hartley and Robin W. Tucker", TITLE = "A Constructive Implementation of the {Cartan-K{\"a}hler} Theory of Exterior Differential Systems", JOURNAL = "J. Symb. Comp.", YEAR = 1991, VOLUME = 12, NUMBER = 6, PAGES = "655-667", MONTH = "December", ABSTRACT = {An efficient algorithm for the construction of a regular chain of involutive integral elements for a general exterior differential system is presented. It is based upon the existence theorems of the {Cartan-}K{"\a}hler theory, and may be used to analyse partial differential equations by formulating them as exterior differential systems.}} @ARTICLE{Hasenfratz:80, AUTHOR = "Anna Hasenfratz and Peter Hasenfratz", TITLE = "The Connection Between the Parameters of Lattice and Continuum {QCD}", JOURNAL = "Phys. Lett.", YEAR = 1980, VOLUME = "93B", NUMBER = "1,2", PAGES = "165-169", MONTH = "June"} @INPROCEEDINGS{Hearn:68, AUTHOR = "Anthony C. Hearn", TITLE = "{REDUCE}: A User-Oriented Interactive System for Algebraic Simplification", YEAR = 1968, PAGES = "79-90", EDITOR = "M. Klerer and J. Reinfelds", BOOKTITLE = "Interactive Systems for Experimental Applied Mathematics", PUBLISHER = "Academic Press", ADDRESS = "New York"} @ARTICLE{Hearn:69, AUTHOR = "A. C. Hearn and P. K. Kuo and D. R. Yennie", TITLE = "Radiative Corrections to an Electron-Positron Scattering Experiment", JOURNAL = "Phys. Rev.", YEAR = 1969, VOLUME = 187, PAGES = "2088-2096"} @INPROCEEDINGS{Hearn:69a, AUTHOR = "Anthony C. Hearn", TITLE = "The Problem of Substitution", YEAR = 1969, PAGES = "3-19", EDITOR = "R.G. Tobey", BOOKTITLE = "Proc. of the 1968 Summer Institute on Symbolic Mathematical Computation", PUBLISHER = "IBM Boston Prog. Center", ADDRESS = "Cambridge, Mass", COMMENT = "IBM Programming Laboratory Report No. FSC-69-0312"} @ARTICLE{Hearn:71, AUTHOR = "Anthony C. Hearn", TITLE = "Applications of Symbolic Manipulation in Theoretical Physics", JOURNAL = "Comm. ACM", YEAR = 1971, VOLUME = 14, PAGES = "511-516"} @INPROCEEDINGS{Hearn:71a, AUTHOR = "Anthony C. Hearn", TITLE = "REDUCE 2: A System and Language for Algebraic Manipulation", YEAR = 1971, PAGES = "128-133", EDITOR = "S.R. Petrick", BOOKTITLE = "Proc. of Second Symposium on Symbolic and Algebraic Manipulation", PUBLISHER = "ACM, New York"} @INPROCEEDINGS{Hearn:71b, AUTHOR = "Anthony C. Hearn", TITLE = "Calculation of Traces of Products of Gamma Matrices", YEAR = 1971, PAGES = "I-30 - I-44", BOOKTITLE = "Proc. of the Second Colloquium on Advanced Computing Methods in Theoretical Physics, {CNRS}, Marseilles", ABSTRACT = {A survey of the algorithms available for the calculation of traces of products of Dirac gamma matrices is presented.}} @INPROCEEDINGS{Hearn:71c, AUTHOR = "Anthony C. Hearn", TITLE = "The Computer Solution of Algebraic Problems by Pattern Matching", YEAR = 1971, PAGES = "I-45 - I-57", BOOKTITLE = "Proc. of the Second Colloquium on Advanced Computing Methods in Theoretical Physics, {CNRS}, Marseilles", ABSTRACT = {This paper discusses computer techniques for the solution of algebraic problems in theoretical physics and related areas by pattern matching.}} @INPROCEEDINGS{Hearn:72, AUTHOR = "Anthony C. Hearn", TITLE = "Computer Solution of Symbolic Problems in Theoretical Physics", YEAR = 1972, PAGES = "567-596", BOOKTITLE = "Computing as a Language of Physics, {IAEA}, Vienna", ABSTRACT = {A survey of the computing techniques currently available for the solution of nonnumerical problems in theoretical physics and related areas is presented.}} @ARTICLE{Hearn:72a, AUTHOR = "Anthony C. Hearn", TITLE = "Improved Non-modular Polynomial {GCD} Algorithm", JOURNAL = "SIGSAM Bulletin", YEAR = 1972, PAGES = "10-15", ABSTRACT = {An improved non-modular algorithm for the calculation of the greatest common divisor of two multivariate polynomials is presented.}} @ARTICLE{Hearn:72b, AUTHOR = "Anthony C. Hearn", TITLE = "A {REDUCE} Solution of Problem \#2 - The {Y(2n)} Functions", JOURNAL = "SIGSAM Bulletin", YEAR = 1972, VOLUME = 14, ABSTRACT = {A {REDUCE} solution to {SIGSAM} Problem \#2 is described.}} @INPROCEEDINGS{Hearn:73, AUTHOR = "Anthony C. Hearn and R{\"u}diger G. K. Loos", TITLE = "Extended Polynomial Algorithms", YEAR = 1973, PAGES = "147-152", BOOKTITLE = "Proc. {ACM} 73", ABSTRACT = {It is shown that standard polynomial algorithms may be applied to a much wider class of functions by making a straightforward generalization of the concept of the exponent. The implementation of a computer algebra system from a standard set of polynomial programs which allows for any coefficient or exponent structure is also discussed.}} @INPROCEEDINGS{Hearn:73a, AUTHOR = "Anthony C. Hearn", TITLE = "The {REDUCE} Program for Computer Algebra", YEAR = 1973, BOOKTITLE = "Proc. of the Third Colloquium on Advanced Computing Methods in Theoretical Physics, {CNRS}, Marseilles", ABSTRACT = {The status of the {REDUCE} program for computer algebra in 1973 is illustrated by a discussion of some aspects of its design philosophy.}} @INPROCEEDINGS{Hearn:74, AUTHOR = "Anthony C. Hearn", TITLE = " Polynomial and Rational Function Representations", YEAR = 1974, PAGE = "211", BOOKTITLE = "Proc. Math Software II, Purdue University", ABSTRACT = {A survey of some current methods for computer manipulation of polynomials and rational functions is presented. Particular emphasis is placed on the desirability of writing programs which avoid explicit reference to the data structures used in the manipulation."}} @INPROCEEDINGS{Hearn:74a, AUTHOR = "Anthony C. Hearn", TITLE = "A Mode Analyzing Algebraic Manipulation Program", YEAR = 1974, PAGES = "722-724", BOOKTITLE = "Proc. {ACM} 74", COMMENT = {Describes a version of the {REDUCE} program for algebraic manipulation which performs a complete mode analysis as a separate extension of the parse.}} @ARTICLE{Hearn:76, AUTHOR = "Anthony C. Hearn", TITLE = "Scientific Applications of Symbolic Computation", JOURNAL = "Computer Science and Scientific Comp.", YEAR = 1976, PAGES = "83-108", ABSTRACT = {This paper reviews the use of symbolic computation systems for problem solving in scientific research.}} @INPROCEEDINGS{Hearn:76a, AUTHOR = "A. C. Hearn", TITLE = "A New {REDUCE} Model for Algebraic Simplification", YEAR = 1976, PAGES = "46-52", BOOKTITLE = "Proc. {SYMSAC} 76, {ACM}", ABSTRACT = {This paper shows how the general concepts of mode analysis can play a useful role in the design and implementation of programs for algebraic simplification.}} @INPROCEEDINGS{Hearn:76b, AUTHOR = "A. C. Hearn", TITLE = "Symbolic Computation", YEAR = 1976, PAGES = "201-211", BOOKTITLE = "Proc. {CERN} 1976 Computing School, {CERN} Geneva", COMMENT = {Lecture Notes.}} @INPROCEEDINGS{Hearn:77, AUTHOR = "A. C. Hearn", TITLE = "The Structure of Algebraic Computations", YEAR = 1977, PAGES = "1-15", BOOKTITLE = "Proc. of the Fourth Colloquium on Advanced Comp. Methods in Theor. Physics. St. Maximin, France", ABSTRACT = {Most algebraic computations which arise from physical problems have considerable structure in their specification because of the many physical conservation laws and the nature of our approximation techniques. The exploitation of this structure is often the reason why hand calculations of non-trivial problems are possible. However, most available algebra systems do not preserve such structure in a consistent manner, and consequently produce results which are far less comprehensible than equivalent hand calculations. In this paper we shall describe techniques which can utilize the algebraic structure more effectively and apply them to several examples.}} @INPROCEEDINGS{Hearn:78, AUTHOR = "Anthony C. Hearn", TITLE = "Algebraic Manipulation by Computer", YEAR = 1978, PAGES = "96-116", BOOKTITLE = "Proc. Intern. Meeting on Programm. and Math. Meth. for Solving Phys. Probs., Dubna, USSR", ABSTRACT = {This paper reviews the use of algebraic manipulation by computer as a tool for scientific problem solving.}} @INPROCEEDINGS{Hearn:79, AUTHOR = "Anthony C. Hearn", TITLE = "Non-Modular Computation of Polynomial {GCDs} Using Trial Division", YEAR = 1979, VOLUME = 72, PAGES = "227-239", BOOKTITLE = "Proc. {EUROSAM} 79", ABSTRACT = {This paper describes a new algorithm for the determination of the {GCD} of two multivariate polynomials by non-modular means.}} @ARTICLE{Hearn:79a, AUTHOR = "Anthony C. Hearn and Arthur C. Norman", TITLE = "A One-Pass Prettyprinter", JOURNAL = "Sigplan Notices, ACM 12", YEAR = 1979, VOLUME = 14, PAGES = "50-58", ABSTRACT = {We propose a new method for program formatting which is described in terms of two coroutines.}} @INPROCEEDINGS{Hearn:80, AUTHOR = "Anthony C. Hearn", TITLE = "The Personal Algebra Machine", YEAR = 1980, PAGES = "621-628", BOOKTITLE = "Information Processing 80, Proc. {IFIP} Congress 80"} @ARTICLE{Hearn:81, AUTHOR = "Anthony C. Hearn and S. Watanabe", TITLE = "Analytic Integration by Computer", JOURNAL = "Information Processing Society of Japan 22", YEAR = 1981, PAGES = "639-650"} @INPROCEEDINGS{Hearn:81a, AUTHOR = "Anthony C. Hearn", TITLE = "Symbolic Computation and its Application to High-Energy Physics", YEAR = 1981, PAGES = "390-406", BOOKTITLE = "Proc. 1980 {CERN} School of Computing, Geneva"} @INPROCEEDINGS{Hearn:82, AUTHOR = "Anthony C. Hearn", TITLE = "{REDUCE} - A Case Study in Algebra System Development", YEAR = 1982, VOLUME = 144, PAGES = "263-272", BOOKTITLE = "Proc. of {EUROCAM} '82, Lecture Notes on Comp. Science"} @INPROCEEDINGS{Hearn:82a, AUTHOR = "Anthony C. Hearn and M. L. Griss and E. Benson", TITLE = "Current Status of a Portable {LISP} Compiler", YEAR = 1982, BOOKTITLE = "Proc. {SIGPLAN} '82 Symp. on Compiler Construction, ACM", PAGES = "276-283"} @INPROCEEDINGS{Hearn:85, AUTHOR = "Anthony C. Hearn", TITLE = "Structure: The Key to Improved Algebraic Computation", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "215-230"} @INPROCEEDINGS{Hearn:86, AUTHOR = "Anthony C. Hearn", TITLE = "Optimal Evaluation of Algebraic Expressions", BOOKTITLE = "Proc. of {AAECC}-3, Lecture Notes on Comp. Science", PUBLISHER = "Springer Verlag", YEAR = 1986, VOLUME = 229, PAGES = "392-403"} @TECHREPORT{Hearn:91, AUTHOR = "Anthony C. Hearn", TITLE = "{REDUCE} User's Manual, {Version} 3.4", INSTITUTION = "RAND", YEAR = 1991, TYPE = "Report", NUMBER = "CP 78", MONTH = "July"} @ARTICLE{Hermann:83, AUTHOR = "R. Hermann", TITLE = "Geometric Construction and Properties of Some Families of Solutions of Nonlinear Partial Differential Equations", JOURNAL = "J. Math. Phys.", YEAR = 1983, VOLUME = 24, NUMBER = "3", PAGES = "510-521", COMMENT = {First of series of papers on 19th century pde theory. The presentation is aimed at including systems such as {MACSYMA} and {REDUCE} as tools. This paper is on Lagrange-Charpit method. "I have in mind developing the differential algebraic aspects of the formalism, going beyond the 19th century with the aid of symbolic computer systems".}} @ARTICLE{Hess:84, AUTHOR = "P. O. Hess and W. Greiner", TITLE = "The Collective Modes of Nuclear Molecules", JOURNAL = "Il Nuovo Cimento", YEAR = 1984, VOLUME = "83A", PAGES = "76-177", COMMENT = {A long paper, admits use of {REDUCE} (on page 101) to invert 11 x 11 matrix.}} @TECHREPORT{Hettich:77, AUTHOR = "R. P. Hettich and J. A. van Hulzen", TITLE = "Approximation with a Class of Rational Functions", INSTITUTION = "Department of Applied Mathematics, Twente University of Technology, The Netherlands", YEAR = 1977, TYPE = "Memorandum", NUMBER = 165, MONTH = "May"} @ARTICLE{Hietarinta:83, AUTHOR = "J. Hietarinta", TITLE = "A search for integrable two-dimensional {Hamiltonian} systems with polynomial potential", JOURNAL = "Phys. Lett.", YEAR = 1983, VOLUME = "96A", PAGES = "273-278", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:83a, AUTHOR = "J. Hietarinta", TITLE = "Integrable Families of {Henon-Heiles} Type {Hamiltonians} and a New Duality", JOURNAL = "Phys. Rev. A", YEAR = 1983, VOLUME = 28, PAGES = "3670-3672", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:84, AUTHOR = "J. Hietarinta", TITLE = "Classical versus quantum integrability", JOURNAL = "J. Math. Phys.", YEAR = 1984, VOLUME = 25, PAGES = "1833-1840", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:84a, AUTHOR = "J. Hietarinta", TITLE = "New integrable {Hamiltonians} with transcendental invariants", JOURNAL = "Phys. Rev. Lett.", YEAR = 1984, VOLUME = 52, PAGES = "1057-1060", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:84b, AUTHOR = "J. Hietarinta and B. Grammaticos and B. Dorizzi and A. Ramani", TITLE = "Coupling-Constant Metamorphosis and Duality between Integrable {Hamiltonian} Systems", JOURNAL = "Phys. Rev. Lett.", YEAR = 1984, VOLUME = 53, PAGES = "1707-1710", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:85, AUTHOR = "J. Hietarinta", TITLE = "How to construct integrable {Fokker-Planck} and electromagnetic {Hamiltonians} from ordinary integrable {Hamiltonians}", JOURNAL = "J. Math. Phys.", YEAR = 1985, VOLUME = 26, PAGES = "1970-1975", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:87, AUTHOR = "J. Hietarinta", TITLE = "Direct methods for the search of the second invariant", JOURNAL = "Physics Reports", YEAR = 1987, VOLUME = 147, PAGES = "87-154", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @ARTICLE{Hietarinta:87a, AUTHOR = "J. Hietarinta", TITLE = "A search of bilinear equations passing {Hirota's} three-soliton condition: {I.} {KdV}-type bilinear equations", JOURNAL = "J. Math. Phys.", YEAR = 1987, VOLUME = 28, PAGES = "1732-1742", COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables vanish on a affine manifold defined by {LET-rules}. Large scale computation.}} @ARTICLE{Hietarinta:87b, AUTHOR = "J. Hietarinta", TITLE = "A search of bilinear equations passing {Hirota's} three-soliton condition: {II.} {mKdV}-type bilinear equations", JOURNAL = "J. Math. Phys.", YEAR = 1987, VOLUME = 28, PAGES = "2094-2101", COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables vanish on a affine manifold defined by {LET-rules}. Large scale computation.}} @ARTICLE{Hietarinta:87c, AUTHOR = "J. Hietarinta", TITLE = "A search of bilinear equations passing {Hirota's} three-soliton condition: {III.} {Sine-Gordon}-type bilinear equations", JOURNAL = "J. Math. Phys.", YEAR = 1987, VOLUME = 28, PAGES = "2586-2592", COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables vanish on a affine manifold defined by {LET-rules}. Large scale computation.}} @ARTICLE{Hietarinta:88, AUTHOR = "J. Hietarinta", TITLE = "A search of bilinear equations passing {Hirota's} three-soliton condition: {IV.} Complex bilinear equations", JOURNAL = "J. Math. Phys.", YEAR = 1988, VOLUME = 29, PAGES = "628-635", COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables vanish on a affine manifold defined by {LET-rules}. Large scale computation. computation.}} @ARTICLE{Hietarinta:89, AUTHOR = "J. Hietarinta and B. Grammaticos", TITLE = "On the $\hbar^{2}$-correction terms in quantum integrability", JOURNAL = "J. Phys. A: Mat. Gen.", YEAR = 1989, VOLUME = "TBD", PAGES = "TBD", COMMENT = {{REDUCE} is used to construct and verify constants of motion.}} @INPROCEEDINGS{Hietarinta:91, AUTHOR = "J. Hietarinta", TITLE = "From an analytical formula to a movie by way of {REDUCE} and {C}", BOOKTITLE = "Proc. of the Workshop on Symbolic and Numeric Computation", PUBLISHER = "Research Reports, Computing Centre of Helsinki University", YEAR = 1991, PAGES = "117-126"} @TECHREPORT{Hietarinta:92, AUTHOR = "Jarmo Hietarinta", TITLE = "Solving the {Yang-Baxter} equation in 2 dimensions with massive use of factorizing Gr{"\o}bner basis computations", INSTITUTION = "University of Turku, Finland", YEAR = 1992, MONTH = "January", TYPE = "Preprint", COMMENT = {Submitted to ISSAC '92}, ABSTRACT = {The complete solution to the constant (quantum) Yang-Baxter equation was recently obtained in the two dimensional case (= all indices range over 1,2). This amounts to solving a set of 64 equations in 16 variables. We describe here how the problem was solved, first by breaking it into smaller subproblems by using the symmetries of the equation, and then by solving each subproblem by computing the factorized Gr{"\o}bner basis using the {'grobner'-}package written by Melenk, M{"\o}ller and Neun for REDUCE 3.4.}}. @TECHREPORT{Hietarinta:92a, AUTHOR = "Jarmo Hietarinta", TITLE = "Solving the two-dimensional constant quantum {Yang-Baxter} equation", INSTITUTION = "University of Turku, Finland", YEAR = 1992, MONTH = "May", TYPE = "Report", NUMBER = "TURKU-FL-R7"} @BOOK{Hirota:89, AUTHOR = "Ryogo Hirota and Masaaki Ito", TITLE = "Introduction to {REDUCE --- Doing} Symbolic Computation on {PC}", PUBLISHER = "Science sha, Tokyo", MONTH = "June", YEAR = 1989, COMMENT = {(In Japanese).}} @TECHREPORT{Horowitz:75, AUTHOR = "E. Horowitz and D. R. Musser", TITLE = "The Synthesis and Use of Algebraic Specifications of Data Structures", INSTITUTION = "University of Southern California", YEAR = 1975, TYPE = "Preprint"} @ARTICLE{Horwitz:83, AUTHOR = "B. Horwitz", TITLE = "Unequal Diameters and Their Effects on Time Varying Voltages in Branched Neurons", JOURNAL = "BioPhys. J.", YEAR = 1983, VOLUME = 41, PAGES = "51-66", COMMENT = {Theoretical biophysics. Much algebra, and used {REDUCE} to decrease mental labor. "Crucial point is that the existence of such computer techniques allows higher-order correction terms to be used."}} @ARTICLE{Hughes:90, AUTHOR = "D. I. Hughes", TITLE = "Symbolic Computation with Fermions", JOURNAL = "J. Symbolic Computation", YEAR = 1990, VOLUME = 10, NUMBER = 6, PAGES = "657-664", MONTH = "December", ABSTRACT = {A set of {REDUCE} routines for manipulating operators which anticommute amongst themselves is described. These routines have applications in theories such as supergravity where anticommuting operators are used to represent fermions. The Dirac bracket of the supersymmetry constraints arising in a quantum cosmological model based on N = 1 supergravtiy coupled to a massless scalar multiplet is calculated as an example.}} @INPROCEEDINGS{Hulshof:84, AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen", TITLE = "Automatic Error Cumulation Control", BOOKTITLE = "Proc. {EUROSAM} 1984, Lecture Notes in Computer Science", YEAR = 1984, VOLUME = 174, PAGES = "260-271", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Hulshof:85, AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen", TITLE = "An Expression Compression Package for {REDUCE} based on Factorization and Controlled Expansion", BOOKTITLE = "Proc. {EUROCAL} 1985, Lecture Notes in Computer Science", YEAR = 1985, VOLUME = 204, PAGES = "315-316", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Hulshof:81, AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen and J. Smit", TITLE = "Code Optimization Facilities Applied in the {Netform} Context", INSTITUTION = "Department of Applied Mathematics, Twente University of Technology, The Netherlands", YEAR = 1981, TYPE = "Memorandum", NUMBER = 368, MONTH = "December"} @ARTICLE{Hulshof:83, AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen", TITLE = "Some {REDUCE} Facilities for Pretty Printing Subscripts and Formal Derivatives", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "16-20", MONTH = "February"} @TECHREPORT{Husberg:81, AUTHOR = "N. Husberg", TITLE = "Preliminary {II} {REDUCE}-2 and {Analitik-74}, a Comparison", INSTITUTION = "Helsinki University of Technology Computing Center", YEAR = 1981, MONTH = "November"} @TECHREPORT{Idesawa:77, AUTHOR = "M. Idesawa and T. Yatagai", TITLE = "General Theory of Projection-Type {Moir\'e} Topography", INSTITUTION = "Institute of Physical and Chemical Research, Wako-Shi, Saitama", YEAR = 1977, TYPE = "Scientific Papers", NUMBER = 71, ABSTRACT = {The configuration of equi-order surfaces in the projection-type {Moire} topography is described in terms of system parameters without any restrictions on the measurement condition.}} @INPROCEEDINGS{Ilyin:87, AUTHOR = "V. A. Ilyin and A. P. Kryukov", TITLE = "{DIMREG} - The Package for Calculations in the Dimensional Regularization with {4-dimensional} $\gamma^{5}$ -matrix in Quantum Field Theory", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "225-232", PUBLISHER = "Springer-Verlag"} @ARTICLE{Ilyin:89, AUTHOR = "V. A. Ilyin and A. P. Kryukov and A. Ya. Rodioniov and A. Yu. Taranov", TITLE = "Fast Algorithm for Calculation of {Dirac}'s Gamma-Matrices Traces", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1989, VOLUME = 23, NUMBER = 4, PAGES = "15-24", MONTH = "October"} @INPROCEEDINGS{Ilyin:91, AUTHOR = "V. A. Ilyin and A. P. Kryukov", TITLE = "Symbolic Simplification of Tensor Expressions Using Symmetries, Dummy Indices and Identities", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "224-228", YEAR = 1991, ABSTRACT = {The algorithm based on simple geometrical ideas is suggested for simplification of tensor expressions which takes into account symmetries, dummy indices, and linear identities with many terms. The results of the realization in REDUCE system are adduced.}} @INPROCEEDINGS{Ilyin:91a, AUTHOR = "V. A. Ilyin and A. P. Kryukov and A. Ya. Rodionov and A Yu. Taranov", TITLE = "{PC} Implementation of Fast {Dirac} Matrix Trace Calculations", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "456-457", YEAR = 1991, COMMENT = {We present an implementation of fast algorithm for Dirac matrix trace calculations. This implementation is made for {IBM} i compatible {PC} and works under {REDUCE 3.3.1}. Name of package is {CVIT}. The algorithm itself was described in [1]. It is based on intense use of Fierz identities in N-dimensional space (N is arbitrary natural number or symbol) and may be considered as an extension of well known Kahane algorithm [2] on higher space dimensions.}} @TECHREPORT{Inada:80, AUTHOR = "Nobuyuki Inada", TITLE = "Fortran-Based {LISP} System for {REDUCE}", INSTITUTION = "Information Science Laboratory, The Institute of Physical and Chemical Research", YEAR = 1980} @TECHREPORT{Ioakimidis:90, AUTHOR = "N. I. Ioakimidis", TITLE = "Construction of the Equation of Caustics in Dynamic Plane Elasticity Problems with the Help of {REDUCE}", INSTITUTION = "Division of Applied Mathematics and Mechanics, School of Engineering, University of Patras, Greece", YEAR = 1990} ABSTRACT = {The method of caustics has become a very efficient tool in crack, hole and many additional plane elasticity problems. Unfortunately, the fundamental equation of the caustics frequently requires complicated algebraic computations including that of a Jacobian determinant. Here we show that computer algebra software can prove very efficient in these computations, using as a vehicle for this illustration the already known fundamental equation of caustics in dynamic plane elasticity (both for crack problems in fracture mechanics as well as for hole and additional problems). We have used the programming capabilities of {REDUCE}, a very popular computer algebra system, for our algebraic computations. Moreover, we illustrate the "learning" abilities of {REDUCE} especially for the derivation of the complex form of this equation. The case of static plane elasticity results simply as a special case of dynamic plane elasticity. Additional possibilities are suggested in brief.}} @TECHREPORT{Ioakimidis:90a, AUTHOR = "N. I. Ioakimidis", TITLE = "Construction of Singular Integral Equations for Interacting Straight Cracks by Using {REDUCE}", INSTITUTION = "Division of Applied Mathematics and Mechanics, School of Engineering, University of Patras, Greece", YEAR = 1990} ABSTRACT = {The method of singular integral equations has been applied to the solution of crack problems in plane and antiplane elasticity hundreds of times during the last twenty years. Here we revisit the case of an arbitrary number of interacting straight cracks in plane elasticity and we illustrate the possibility of constructing (algebraically) the corresponding system of singular integral equations by using computer algebra software. We present a procedure (computer program) by using {REDUCE} as well as several examples of application of the present approach, extensions and generalizations of which follow rather trivially.}} @ARTICLE{Ito:85, AUTHOR = "M. Ito", TITLE = "A {REDUCE} Program for Evaluating a {Lax} Pair Form", JOURNAL = "Comp. Phys. Comm.", YEAR = 1985, VOLUME = 34, PAGES = "325-331", COMMENT = {{REDUCE} in nonlinear equations.}} @ARTICLE{Ito:85a, AUTHOR = "M. Ito and F. Kako", TITLE = "A {REDUCE} Program for Finding Conserved Densities of Partial Differential Equations with Uniform Rank", JOURNAL = "Comp. Phys. Comm.", YEAR = 1985, VOLUME = 38, PAGES = "415-419"} @ARTICLE{Ito:88, AUTHOR = "Masaaki Ito", TITLE = "A {REDUCE} Program for {Hirota's} Bilinear Operator and {Wronskian} Operations", JOURNAL = "Comp. Phys. Comm.", YEAR = 1988, VOLUME = 50, NUMBER = 3, PAGES = "321-330", MONTH = "August"} @ARTICLE{Ito:90, AUTHOR = "Nobuyasu Ito and Tetsuhiko Chikyu", TITLE = "Multi-Spin-Flip Dynamics of the {Ising} Chain", JOURNAL = "Physica A", YEAR = 1990, VOLUME = 166, PAGES = "193-205", ABSTRACT = {Two kinds of multi-spin-flip discrete-time dynamics of the Ising chain are solved analytically. One dynamics is the two sublattice type flip and each sublattice contains {\em n} sequential spins alternately. The other has the overlapped multi-spin-flip sequence. The state of {\em n} spins at the next time step is selected from ${2}^{n}$ states using the heat-bath type transition probability. These dynamics of the Ising chain are equivalent to the statics of the square-lattice Ising model with a 1 x 2 unit cell or of the triangular-lattice Ising model. The analytic solutions of the single spin relaxation time of these dynamics are obtained using these equivalences.}} @ARTICLE{Ito:90a, AUTHOR = "Nobuyasu Ito", TITLE = "Discrete-Time and Single-Spin-Flip Dynamics of the {Ising} Chain", JOURNAL = "Progress of Theoretical Physics", YEAR = 1990, VOLUME = 83, NUMBER = 4, PAGES = "682-692", MONTH = "April", ABSTRACT = {Some stochastic dynamics of the Ising chain are discussed analytically and their flip-sequence dependences are studied in the present paper. The dynamics are the discrete-time and single-spin-flip dynamics. The flip sequence is of sequential or sublattice-type. Their relaxation times of single spin expectation functions are calculated. The sequential-flip dynamics of {\em n}-site chain has the same correlation time as the {\em n}-sublattice dynamics. The relaxation becomes slow when this {\em n} is made large. The static models equivalent to these dynamic models are the Ising models on a triangular lattice with a skew boundary condition which has the same couplings in two directions. Spin-spin correlation lengths in the direction perpendicular to the anisotropic direction are obtained for these equivalent models. They depend only on the ratio of the lattice width to boundary skew.}} @ARTICLE{Jansen:86, AUTHOR = "Paul Jansen and Peter Weidner", TITLE = "High-Accuracy Arithmetic Software--Some Tests of the {ACRITH} Problem-Solving Routines", JOURNAL = "{ACM} {TOMS}", YEAR = 1986, VOLUME = 12, NUMBER = 1, PAGES = "62-70", MONTH = "March", COMMENT = {A criticism of {ACRITH}, shows {REDUCE} bigfloats are more accurate and comparable in speed.}} @ARTICLE{Janssen:87, AUTHOR = "M. H. M. Janssen and D. H. Parker and S. Stolte", TITLE = "Saturation in Laser-Induced Fluorescence: Effects on Alignment Parameters", JOURNAL = "Chemical Phys.", YEAR = 1987, VOLUME = 113, PAGES = "357-382", COMMENT = {"Computer algebra programs are used to generate simple analytical expressions which account for the influence of saturation on determining alignment parameters." The system is {REDUCE}.}} @ARTICLE{Jeffrey:84, AUTHOR = "D. J. Jeffrey and Y. Onishi", TITLE = "The Forces and Couples Acting on Two Nearly Touching Spheres in Low-{Reynolds}-Number Flow", JOURNAL = "Z. Ang. Math. Phys.", YEAR = 1984, VOLUME = 35, PAGES = "634-641", COMMENT = {Extends previous result from linear term to O$\epsilon$ in $\epsilon$. "Otherwise the only new principle in the calculation is the handling of long algebraic expressions, which was accomplished by using the computer algebra systems {CAMAL} and {REDUCE}."}} @ARTICLE{Kadlecsik:88, AUTHOR = "J. Kadlecsik", TITLE = "New Approaches to the Axisymmetric Vacuum", JOURNAL = "Zeitschrift {f\"{u}r} Physik C. Particles and Fields", YEAR = 1988, VOLUME = 41, PAGES = "265-269"} @TECHREPORT{Kadlecsik:92, AUTHOR = "Jo{\'o}zsef Kadlecsik", TITLE = "Tensor Manipulation Package for General Relativity Calculations", INSTITUTION = "Central Research Institute for Physics, Budapest", YEAR = 1992, TYPE = "Preprint", NUMBER = "KFKI-1992-05/B+M", ABSTRACT = {An experimental computer program is presented, which manipulates tensor expressions symbolically in general relativity calculations.}} @ARTICLE{Kagan:85, AUTHOR = "Y. Y. Kagan and L. Knopoff", TITLE = "The First-Order Statistical Moment of the Seismic Moment Tensor", JOURNAL = "Geophys. J. R. Astron. Soc.", YEAR = 1985, VOLUME = 81, PAGES = "429-444"} @ARTICLE{Kagan:88, AUTHOR = "Y. Y. Kagan", TITLE = "Static Sources of Elastic Deformation in a Homogeneous Half-Space", JOURNAL = "J. Geophys. Res.", YEAR = 1988, VOLUME = 93, NUMBER = "B9", PAGES = "10,560-10,574", MONTH = "September"} @TECHREPORT{Kahn:69, AUTHOR = "M. E. Kahn", TITLE = "The Near-Minimum-Time Control of Open Loop Articulated Kinematic Chains", INSTITUTION = "Stanford University, Computer Science Dept.", YEAR = 1969, TYPE = "Report", NUMBER = "AIM-106"} @TECHREPORT{Kamal:81, AUTHOR = "A. N. Kamal and J. Kodaira and T. Muta", TITLE = "Gluon Jets From Heavy Paraquarkonium", INSTITUTION = "University of Alberta, Canada and Stanford University, California and Fermi National Accelerator Laboratory, Illinois", YEAR = 1981, NUMBER = "SLAC-PUB-2725", MONTH = "April"} @TECHREPORT{Kamel:69, AUTHOR = "A. A. Kamel", TITLE = "Perturbation Method in the Theory of Non-Linear Oscillations", INSTITUTION = "Stanford University, Dept. of Aeronautics and Astronautics", YEAR = 1969, TYPE = "Report"} @TECHREPORT{Kamel:69a, AUTHOR = "A. A. Kamel", TITLE = "Perturbation Theory Based on {Lie} Transforms and Its Application to the Stability of Motion Near {Sun}-Perturbed {Earth-Moon} Triangular Libration Points", INSTITUTION = "Stanford University, Dept. of Aeronautics and Astronautics", YEAR = 1969, TYPE = "Report", NUMBER = "391"} @INPROCEEDINGS{Kamel:78, AUTHOR = "A. A. Kamel", TITLE = "Synchronous Satellite Ephemeris Due to Earth's Triaxiality and Luni-Solar Effects", YEAR = 1978, MONTH = "August", BOOKTITLE = "{AIAA/AAS} Astrodynamics Conference, Palo Alto, CA", COMMENT = {Synchronous satellite ephemeris is developed in terms of non-singular orbital elements.}} @ARTICLE{Kanada:81, AUTHOR = "Yasumasa Kanada and Tateaki Sasaki", TITLE = "{LISP-based} {big-float} system is not slow", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1981, VOLUME = 15, NUMBER = 2, PAGES = "13-19", MONTH = "May"} @TECHREPORT{Kanada:75, AUTHOR = "Y. Kanada", TITLE = "Implementation of {HLISP} and Algebraic Manipulation Language {REDUCE} 2", INSTITUTION = "University of Tokyo Information Science Lab", YEAR = 1975, TYPE = "Report", NUMBER = "75-01"} @ARTICLE{Kaneko:89, AUTHOR = "Toshiaki Kaneko and Setsuya Kawabata", TITLE = "A Preprocessor for {Fortran} Source Code Produced by {REDUCE}", JOURNAL = "Comp. Phys. Comm.", YEAR = 1989, VOLUME = 55, NUMBER = 2, PAGES = "141-147", MONTH = "September", PUBLISHER = "North Holland Publishing Company"} @ARTICLE{Kaps:85, AUTHOR = "P. Kaps and S. W. H. Poon and T. D. Bui", TITLE = "Rosenbrock Methods for Stiff {ODEs}: A Comparison of {Richardson} Extrapolation and Embedding Techniques", JOURNAL = "Computing", YEAR = 1985, VOLUME = 34, PAGES = "17-40", COMMENT = {Reference to {REDUCE} but not in text.}} @INPROCEEDINGS{Karr:85, AUTHOR = "Michael Karr", TITLE = "Canonical Form for Rational Exponential Expressions", BOOKTITLE = "Proc. {EUROCAL} 1985, Lecture Notes in Computer Science", YEAR = 1985, VOLUME = 204, PAGES = "585-594", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Katsura:85, AUTHOR = "Shigetoshi Katsura", TITLE = "Application of the Formula Manipulating System to Statistical Mechanics", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "155-180"} @PHDTHESIS{Kauffman:73, AUTHOR = "S. K. Kauffman", TITLE = "Ortho-Positronium Annihilation: Steps Toward Computing the First Order Radiative Corrections", SCHOOL = "California Institute of Technology", YEAR = 1973} @INPROCEEDINGS{Kazasov:87, AUTHOR = "C. Kazasov", TITLE = "Laplace Transformations in {REDUCE} 3", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "132-133", PUBLISHER = "Springer-Verlag"} @ARTICLE{Keady:85, AUTHOR = "Grant Keady", TITLE = "The Power Concavity of Solutions of Some Semilinear Elliptic {Boundary-Value} Problems", JOURNAL = "Bull. Austral. Math. Soc.", YEAR = 1985, VOLUME = 31, PAGES = "181-184"} @ARTICLE{Keener:83, AUTHOR = "James P. Keener", TITLE = "Oscillatory coexistence in the {chemostat:} a codimension two unfolding", JOURNAL = "{SIAM} J. Appl. Math.", YEAR = 1983, VOLUME = 43, NUMBER = 5, PAGES = "1005-1018"} @ARTICLE{Keener:85, AUTHOR = "James P. Keener", TITLE = "Oscillatory coexistence in a food chain model with competing predators", JOURNAL = "J. Math. Biology", YEAR = 1985, VOLUME = 22, PAGES = "123-135"} @ARTICLE{Keener:89, AUTHOR = "James P. Keener", TITLE = "Knotted scroll wave filaments in excitable media", JOURNAL = "Physica D 34", YEAR = 1989, PAGES = "378-390"} @ARTICLE{Keener:90, AUTHOR = "James P. Keener", TITLE = "Knotted vortex filaments in an ideal fluid", JOURNAL = "J. Fluid Mech.", YEAR = 1990, VOLUME = 211, PAGES = "629-651"} @ARTICLE{Kendall:88, AUTHOR = "W. S. Kendall", TITLE = "Symbolic Computation and the Diffusion of Shapes of Triads", JOURNAL = "Adv. Appl. Prob.", YEAR = 1988, VOLUME = 20, PAGES = "775-797"} @TECHREPORT{Kendall:89, AUTHOR = "W. S. Kendall", TITLE = "The Diffusion of {Euclidean} Shape", INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1989, TYPE = "Research Report", NUMBER = 161} @TECHREPORT{Kendall:89a, AUTHOR = "W. S. Kendall", TITLE = "Probability, Convexity, and Harmonic Maps with Small Image I: Uniqueness and Fine Existence", INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1989, TYPE = "Research Report", NUMBER = 162} @ARTICLE{Kendall:90, AUTHOR = "W. S. Kendall", TITLE = "Computer Algebra and Stochastic Calculus", JOURNAL = "Notices A.M.S.", YEAR = 1990, VOLUME = 37, PAGES = "1254-1256"} @TECHREPORT{Kendall:91, AUTHOR = "Wilfred S. Kendall", TITLE = "Computer Algebra and Stochastic Calculus", INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1991, TYPE = "Research Report", NUMBER = 203} @TECHREPORT{Kendall:91a, AUTHOR = "Wilfred S. Kendall", TITLE = "Symbolic {It\^{o}} Calculus: An Introduction", INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1991, TYPE = "Research Report", NUMBER = 217} ABSTRACT = {The ito procedures are an implementation of stochastic calculus for the computer algebra package {REDUCE}. In this paper it is explained how the implementation of ito grows naturally out of the formulation of stochastic calculus using modules of stochastic differentials. Two examples are given of ito in action: a simple example concerning various exponential martingales and a more involved example concerning the escape rate of the Bessel process of dimension exceeding 2. A basic subset of the ito procedures is listed in six appendices; details are given of how to obtain the full set from the author.}} @INPROCEEDINGS{Kerner:75, AUTHOR = "W. Kerner and R. C. Grimm", TITLE = "{MHD} Spectra for {Tokamaks} with Non-circular Cross Sections", YEAR = 1975, BOOKTITLE = "Proc. Seventh Conference on Numerical Simulation of Plasmas, Courant Institute, {NYU}"} @ARTICLE{Kersten:83, AUTHOR = "P. H. M. Kersten", TITLE = "Infinitesimal Symmetries and Conserved Currents for Nonlinear {Dirac} Equation", JOURNAL = "J. Math. Phys.", YEAR = 1983, VOLUME = 24, PAGES = "2374-2376", COMMENT = {Harrison-Estabrook and computer algebra, in {REDUCE}. Very like {EXCALC} but predates it.}} @ARTICLE{Kersten:84, AUTHOR = "P. Kersten and R. Martini", TITLE = "The Harmonic Map and Killing Fields for Self-Dual {SU(3)} {Yang-Mills} Equations", JOURNAL = "J. Phys. A", YEAR = 1984, VOLUME = 17, PAGES = "L227-L230", COMMENT = {%"{\ldots}and the determination of the general solution of the killing fields have been achieved by symbolic computations in a semi-automatic way using software developed in the symbolic language {REDUCE}{\ldots}"}} @ARTICLE{Kersten:86, AUTHOR = "P. H. M. Kersten", TITLE = "Creating and Annihilating {Lie-B\"acklund} Transformations of the {Federbush} Model", JOURNAL = "J. Math. Phys.", YEAR = 1986, VOLUME = 27, PAGES = "1139-1144", COMMENT = {"We want to stress that all computations have been worked out on a {DEC-20} computer using {REDUCE} and a software package to do these calculations." Lie algebra and Gragert's package.}} @ARTICLE{Kersten:86a, AUTHOR = "P. H. M. Kersten and H. M. M. Ten Eikelder", TITLE = "Infinite Hierarchies of t-independent and t-dependent Conserved Functionals of the {Federbush} Model", JOURNAL = "J. Math. Phys.", YEAR = 1986, VOLUME = 27, PAGES = "2140-2145", COMMENT = {"We want to stress that all computations have been worked out on a {DEC-20} computer using {REDUCE} and a software package to do these calculations."}} @ARTICLE{Kersten:86b, AUTHOR = "P. H. M. Kersten and H. M. M. Ten Eikelder", TITLE = "An Infinite Number of Infinite Hierarchies of Conserved Quantities of the {Federbush} Model", JOURNAL = "J. Math. Phys.", YEAR = 1986, VOLUME = 27, PAGES = "2791-2796"} @ARTICLE{Killalea:80, AUTHOR = "M. K. Killalea and B. J. McCoy", TITLE = "Concentration Distribution and Spatial Moments of Moving Macromolecules Undergoing Isomerization", JOURNAL = "Biopolymers", YEAR = 1980, VOLUME = 19, PAGES = "1875-1886"} @TECHREPORT{Kinoshita:72, AUTHOR = "T. Kinoshita and P. Cvitanovic", TITLE = "Sixth Order Radiative Corrections to the Electron Magnetic Moment", INSTITUTION = "Cornell Lab. for Nuclear Studies", YEAR = 1972, TYPE = "Report", NUMBER = "CLNS-197", MONTH = "October"} @TECHREPORT{Kinoshita:73, AUTHOR = "T. Kinoshita and P. Cvitanovic", TITLE = "Feynman-{Dyson} Rules in Parametric Space", INSTITUTION = "Cornell Lab. for Nuclear Studies", YEAR = 1973, TYPE = "Report", NUMBER = "CLNS-209", MONTH = "January"} @ARTICLE{Kitatani:86, AUTHOR = "H. Kitatani and S. Miyashita and M. Suzuki", TITLE = "Reentrant Phenomena in Some {Ising} Spin Systems - Rigorous Results and Effects of an External Field", JOURNAL = "J. Phys. S. Japan", YEAR = 1986, VOLUME = 55, NUMBER = 3, PAGES = "865-876", COMMENT = {{REDUCE} used to calculate formula before numerical calculation.}} @TECHREPORT{Kobayashi:84, AUTHOR = "Hidestune Kobayashi", TITLE = "Weierstrass Points on a Curve, $X^{7}_{0}+X^{7}_{1} +X^{7}_{2}=0$", INSTITUTION = "Research Institute of Science and Technology, Nihon University", YEAR = 1984, TYPE = "Preprint", NUMBER = 28, MONTH = "March"} @INPROCEEDINGS{Kobayashi:88, AUTHOR = "H. Kobayashi and S. Moritsugu and R. W. Hogan", TITLE = "Solving Systems of Algebraic Equations", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "139-149"} @INPROCEEDINGS{Kodaira:85, AUTHOR = "Hiroshi Kodaira and Hiroshi Toshima", TITLE = "Gini Coefficient of Wealth in Life Cycle Model", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "119-151"} @ARTICLE{Koh:82, AUTHOR = "I. G. Koh and Y. D. Kim and Y. J. Park and C. H. Kim and Y. S. Kim", TITLE = "Complete Set of {SU(5)} Monopole Solution", JOURNAL = "J. Math. Phys.", YEAR = 1982, VOLUME = 23, PAGES = "1210-1212", COMMENT = {Calculation checked by {REDUCE} after hand calculation.}} @ARTICLE{Koelbig:81, AUTHOR = "K. S. K{\"o}lbig and F. Schwarz", TITLE = "On Positive Function Series", JOURNAL = "Computing", YEAR = 1981, VOLUME = 27, PAGES = "319-337", COMMENT = {{REDUCE} for algebra on constraints on a functional form and Jacobi polynomials.}} @ARTICLE{Koelbig:81b, AUTHOR = "K. S. K{\"o}lbig", TITLE = "A Program for Computing the Conical functions of the First Kind ${P}^{m}_{-1/2+i\tau}(x)$ for $m = 0$ and $m = 1$", JOURNAL = "Comp. Phys. Comm.", YEAR = 1981, VOLUME = 23, PAGES = "51-61", PUBLISHER = "North Holland Publishing Company"} @ARTICLE{Koelbig:82, AUTHOR = "K. S. K{\"o}lbig", TITLE = "Closed Expressions for $\int_{0}^{1} t^{-1} $log$^{n-1}t\, $log$^{p}(1 - t) dt$", JOURNAL = "Math. Comp.", YEAR = 1982, VOLUME = 39, NUMBER = 160, PAGES = "647-654", MONTH = "October", COMMENT = {Closed form of integral for easy calculation. Used {REDUCE} for manipulations. This class includes dilog, Spence functions etc. Remarks that {REDUCE} is easier than {FORTRAN}.}} @ARTICLE{Koelbig:82a, AUTHOR = "K. S. K{\"o}lbig and W. R{\"u}hl", TITLE = "Complex Zeros of the Partition Function for Two-Dimensional {U(N)} Lattice Gauge Theories", JOURNAL = "Z. Phys. C - Particles and Fields", YEAR = 1982, VOLUME = 12, PAGES = "135-143", COMMENT = {The Complex Zeros of the Partition Function for Two-Dimensional U(N) Lattice Gauge Theories.}} @ARTICLE{Koelbig:83, AUTHOR = "K. S. K{\"o}lbig", TITLE = "On the Integral $\int_{0}^{\pi/2} $log$^{n}$cos$\,x\,$ log$^{p}$sin$\,x\,dx$", JOURNAL = "Math. Comp.", MONTH = "April", YEAR = 1983, VOLUME = 40, PAGES = "565-570", COMMENT = {A formula is derived for the integral in the title which allows easy evaluation by formula manipulation on a computer.}} @ARTICLE{Koelbig:83a, AUTHOR = "K. S. K{\"o}lbig", TITLE = "On the Integral $\int_{0}^{\infty} e^{-\mu t} t^{\nu -1} $log$^{m} t dt$", JOURNAL = "Math. Comp.", YEAR = 1983, VOLUME = 41, PAGES = "171-182", COMMENT = {A recurrence relation is given for the integral in the title.}} @ARTICLE{Koelbig:84, AUTHOR = "K. S. K{\"o}lbig and B. Schorr", TITLE = "Asymptotic Expansions for the {Landau} Density and Distribution Function", JOURNAL = "Comp. Phys. Comm.", YEAR = 1984, VOLUME = 32, PAGES = "121-131"} @ARTICLE{Koelbig:84a, AUTHOR = "K. S. K{\"o}lbig and B. Schorr", TITLE = "A Program Package for the {Landau} Distribution", JOURNAL = "Comp. Phys. Comm.", YEAR = 1984, VOLUME = 31, PAGES = "97-111"} @TECHREPORT{Koelbig:84b, AUTHOR = "K. S. K{\"o}lbig", TITLE = "Some Problems Involving Special Functions Arising From Physics at {CERN}", INSTITUTION = "CERN, Data Handling Division", YEAR = 1984, NUMBER = "DD 84-14", MONTH = "September"} @TECHREPORT{Koelbig:85, AUTHOR = "K. S. K{\"o}lbig", TITLE = "On the Integral $\int_{0}^{1} x^{\nu -1} (1 - x)^{-\lambda} $ln$^{m} x dx$", INSTITUTION = "CERN, Data Handling Division", YEAR = 1985, NUMBER = "DD/85/18", MONTH = "September"} @ARTICLE{Koelbig:85a, AUTHOR = "K. S. K{\"o}lbig", TITLE = "Explicit Evaluation of Certain Definite Integrals Involving Powers of Logarithms", JOURNAL = "J. Symbolic Computation", YEAR = 1985, VOLUME = 1, NUMBER = 1, PAGES = "109-114", MONTH = "March"} @ARTICLE{Koelbig:86, AUTHOR = "K. S. K{\"o}lbig", TITLE = "On the Integral $\int_{0}^{\infty} x^{\nu -1} (1 + \beta x)^{-\lambda} $ln$^{m} x dx$", JOURNAL = "Journal of Comp. and Appl. Math.", YEAR = 1986, VOLUME = 14, PAGES = "319-344"} @ARTICLE{Kolar:90, AUTHOR = "M. Kol{\'a}\u{r} and M. K. Ali", TITLE = "Trace maps associated with general {two-letter} substitution rules", JOURNAL = "Physical Review {A}", YEAR = 1990, VOLUME = 42, NUMBER = 12, PAGES = "7112-7124", MONTH = "December", ABSTRACT = {Spectral properties, as determined by trace maps, of the one-dimensional chains (layered structures) constructed according to general two-letter substitution rules are investigated. In all trace maps thus obtained an important role is played by the quantity $I=x^{2}+y^{2}+z^{2}-xyz-4$ However, only a very small fraction of all such trace maps are similar to the Fibonacci golden-mean trace map in that I is their invariant. In addition to the known case of the precious-mean lattices (precious means are ratios of the form $^{1}_{2}[m+(m^{2}+4)^{1/2}]$, m being any positive integer; m=1 gives the golden mean), we have identified two new large clases of substitution rules that give trace maps with invariant I. One of them is a superset of the precious-mean lattices. All other cases represent a vast assortment of different trace maps (and thus the potential for various hitherto unexplored spectral properties) with a unifying feature that the set I=0 plays the role of an attractor in the trace space. In most (but not all) cases, two chains with identical trace maps (and thus identical spectra) are locally isomorphic. Generally, local isomorphism equivalence classes seem to be subsets of identical spectrum equivalence classes.}} @TECHREPORT{Kornyak:87, AUTHOR = "V. V. Kornyak and R. N. Fedorova", TITLE = "A {REDUCE} Program to Calculate Determining Equations of {Lie-Baecklund} Symmetries of Differential Equations", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1987, NUMBER = "P11-87-19"} @ARTICLE{Kotorynski:86, AUTHOR = "W. P. Kotorynski", TITLE = "Steady Laminar Flow Through a Twisted Pipe of Elliptical Cross-Section", JOURNAL = "Computers and Fluids", YEAR = 1986, VOLUME = 14, PAGES = "433-444", COMMENT = {Used {REDUCE} to perform the calculations for steady flow through twisted pipes, but who also remarked that the techniques he developed for this problem are applicable to a variety of other pipe flow tasks.}} @ARTICLE{Krack:82, AUTHOR = "K. Krack", TITLE = "Rechnerunterst{\"u}tzte {Entwicklung} der {Mittelbreitenformeln} und Absch{\"a}tzung ihrer ellipsoidischen {Anteile} zur L{\"o}sung der zweiten geod{\"a}tischen {Hauptaufgabe} auf dem {Rotationsellipsoid}", JOURNAL = "Z. Vermessungswes.", YEAR = 1982, VOLUME = 107, PAGES = "502-513", COMMENT = {(In German) Used {REDUCE} to develop the Gauss mid-latitude formulae for inverse positioning to the 7th order (Geodesy).}} @PHDTHESIS{Kraus:73, AUTHOR = "J. Kraus", TITLE = "Delbr{\"u}ckstreuung und Pr{\"u}fung der Quantenelektrodynamik", SCHOOL = "Ludwig-Maximilians-Universit{\"a}t zu M{\"u}nchen", YEAR = 1973} @ARTICLE{Kredel:88, AUTHOR = "Heinz Kredel", TITLE = "Admissible termorderings used in Computer Algebra Systems", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1988, VOLUME = 22, NUMBER = 1, PAGES = "28-31", MONTH = "January"} @ARTICLE{Kruse:83, AUTHOR = "Hans-Guenther Kruse and Karin Ohlsen", TITLE = "About the Realization of an Extended, but Really Interactive {REDUCE} by Integration of a Small Editing and Executing System", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "21-25", MONTH = "February"} @TECHREPORT{Kryukov, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov", TITLE = "Usage of {REDUCE} for Computations of Group-Theoretical Weight of {Feynman} Diagrams in Non-Abelian Gauge Theories", INSTITUTION = "Institute of Nuclear Physics, Moscow, USSR", YEAR = "TBD"} @ARTICLE{Kryukov:84, AUTHOR = "A. P. Kryukov", TITLE = "An Antitranslator of the {RLISP} Language", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1984, VOLUME = 18, NUMBER = 3, PAGES = "12-15", MONTH = "August"} @ARTICLE{Kryukov:85, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov", TITLE = "Dynamic-Debugging System for the {REDUCE} Programs", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "34-37", MONTH = "May"} @ARTICLE{Kryukov:85a, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov", TITLE = "Interactive {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "43-45", MONTH = "August"} @TECHREPORT{Kryukov:87, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov and V. A. Rostovtsev", TITLE = "Pattern Compilation in {REDUCE}", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1987, NUMBER = "P11-87-302"} @INPROCEEDINGS{Kryukov:87a, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov", TITLE = "{CTS} - Algebraic Debugging System for {REDUCE} Programs", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "233-243", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Kryukov:88, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov and V. A. Rostovtsev", TITLE = "New Programming Tools for Computing Substitution Rules in {REDUCE} System", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1988, NUMBER = "P11-88-402", COMMENT = {New programming tools allowing to compile patterns in {REDUCE} system are described. A guide for using these tools and examples of their working are presented.}} @ARTICLE{Kryukov:88a, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov", TITLE = "Program {``COLOR''} for Computing the Group-Theoretic Weight of {Feynman} Diagrams in {Non-Abelian} Gauge Theories", JOURNAL = "Comp. Phys. Commun.", YEAR = 1988, VOLUME = 48, NUMBER = 2, PAGES = "327-334", MONTH = "February"} @TECHREPORT{Kryukov:88b, AUTHOR = "A. P. Kryukov and D. A. Slavnov", TITLE = "The Role of the $gg \rightarrow c\overline{c}g$ Process in the Cross Section of Production of Charmed Particles (in {Russian})", INSTITUTION = "Moscow State University", YEAR = 1988, NUMBER = "88-49/70", TYPE = "Preprint"} @BOOK{Kryukov:91, AUTHOR = "A. P. Kryukov and A. Ya. Rodionov and A. Yu. Taranov and E. Shablygin", TITLE = "Programming in R-Lisp", PUBLISHER = "Radio and Connective Publishers, Moscow", YEAR = 1991, ABSTRACT = {Various Lisp dialects become more and more popular as high-level programming languages. In this book basic Lisp concepts, its data structures and build in functions are introduced using R-Lisp. R-Lisp is the implementation language of a famous REDUCE computer algebra system. All concepts are illustrated by simple but by no means trivial programming examples. The description of compiler and full function reference are included. The book will be interesting for beginners as well as Lisp programmers. In Russian}} @TECHREPORT{Kuppers:71, AUTHOR = "G. Kuppers and D. Pfirsch and H. Tasso", TITLE = "{M.H.D.} - Stability of Axisymmetric Plasmas", INSTITUTION = "Max-Planck-Institut fuer Plasmaphysik", YEAR = 1971, TYPE = "Report", NUMBER = "CN -28/F-14"} @ARTICLE{Lambin:84, AUTHOR = "P. Lambin and J. P. Vigneron", TITLE = "Computation of Crystal {Green's} Functions in the Complex-Energy Plane with the Use of the Analytical Tetrahedron Method", JOURNAL = "Phys. Rev. B", YEAR = 1984, VOLUME = 29, NUMBER = 6, PAGES = "3430-3437", COMMENT = {Crystallography, {REDUCE}, quantum theory.}} @TECHREPORT{Lang:79, AUTHOR = "C. B. Lang and W. Porod", TITLE = "Symmetry Breaking and $\pi$ {K} Amplitudes in the Unphysical Region", INSTITUTION = "Institut f{\"u}r Theor. Physik, Univ. Graz", YEAR = 1979, TYPE = "Report", NUMBER = "UNIGRAZ-UTP 08/79", ABSTRACT = {We apply two different methods of analytic continuation (fixed-t and hyperbolic dispersion relations with discrepancy) to determine the expansion parameters of the pi K amplitudes in the unphysical region near the symmetry point.}, COMMENT = {To be published in Phys. Rev. D, September, 1979.}} @TECHREPORT{Laursen:79, AUTHOR = "M. L. Laursen and M. A. Samuel", TITLE = "The n-Bubble Diagram Contribution to the g-2 of the Electron - {Mathematical} Structure of the Analytical Expression", INSTITUTION = "Oklahoma State Univ. Quantum Theoretical Research Group", YEAR = 1979, TYPE = "Research Note", NUMBER = "96", ABSTRACT = {We obtain an exact integrated expression for the contribution of the mass-independent n-bubble diagram to the leptonic g-2.}} @TECHREPORT{Laursen:80, AUTHOR = "Morten L. Laursen and Mark A. Samuel", TITLE = "Borel Transform Technique and the {n-Bubble} Diagram Contribution to the Lepton Anomaly", INSTITUTION = "Oklahoma State Univ. Quantum Theoretical Research Group", YEAR = 1980, TYPE = "Research Note", NUMBER = 10, MONTH = "August", ABSTRACT = {By using the {Borel} transform technique we calculate analytically the muon anomaly from the mass-dependent n-bubble diagram in the limit where the mass ratio is large.}} @ARTICLE{Laursen:81, AUTHOR = "M. L. Laursen and M. A. Samuel", TITLE = "The n-bubble Diagram Contribution to g-2", JOURNAL = "J. Maths. Phys.", YEAR = 1981, VOLUME = 22, PAGES = "1114-1126", COMMENT = {Exact integration for contribution to mass indep. {n-bubble} diagram to {leptonic g-2}. {REDUCE} used to calculate explicitly to {n=13}, involves summing series and rational coefficients.}} @ARTICLE{Lecourtier:85, AUTHOR = "Y. Lecourtier and A. Raksanyi", TITLE = "Algebraic Manipulation Routines for Testing Structural Properties", JOURNAL = "IFAC Identification and System Parameter Estimation", YEAR = 1985, PAGES = "543-549"} @ARTICLE{Lee:85, AUTHOR = "H-C Lee and M. S. Milgram", TITLE = "On the Axial Gauge: Ward Identities and the Separation of Infrared and Ultraviolet Singularities by Analytical Regularization", JOURNAL = "J. Math. Phys.", YEAR = 1985, VOLUME = 26, PAGES = "1793-1804", COMMENT = {Yang-Mills theories on the axial gauge. Uses {SCHOONSCHIP} and {REDUCE}.}} @ARTICLE{Leler:85, AUTHOR = "Wm Leler and Neil Soiffer", TITLE = "An Interactive Graphical Interface for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "17-23", MONTH = "August"} @ARTICLE{Lepage:83, AUTHOR = "G. P. Lepage and P. B. Mackenzie and K. H. Streng and P. M. Zernas", TITLE = "Multiphoton Decays of Positronium", JOURNAL = "Phys. Rev. A", YEAR = 1983, VOLUME = 28, PAGES = "3090-3091", COMMENT = {Same as Adkins and Brown (1983) but independent of it.}} @INPROCEEDINGS{Levi:70, AUTHOR = "I. Levi and N. Hoff", TITLE = "Non-Symmetric Creep Buckling of Circular Cylindrical Shells in Axial Compression", YEAR = 1970, MONTH = "August", BOOKTITLE = "Proc. Intern. Symp. in Creep Effect in Structures, Gotenburg, Sweden"} @INPROCEEDINGS{Levi:71, AUTHOR = "I. M. Levi", TITLE = "Symbolic Algebra by Computer - Applications to Structural Mechanics", YEAR = 1971, MONTH = "April", BOOKTITLE = "{AIAA/ASME} 12th Structures, Structural Dynamics and Materials Conference, Anaheim, California"} @ARTICLE{Liebermann:75, AUTHOR = "R. Liebermann", TITLE = "Traces of High Energy Processes in Strong Magnetic Fields", JOURNAL = "J. Comp. Phys.", YEAR = 1975} @ARTICLE{Liska:84, AUTHOR = "R. Liska", TITLE = "Program for Stability and Accuracy Analysis of Finite Difference Methods", JOURNAL = "Comp. Phys. Comm.", YEAR = 1984, VOLUME = 34, PAGES = "175-186"} @INPROCEEDINGS{Liska:87, AUTHOR = "R. Liska and D. Drska", TITLE = "Evaluation of Plasma Fluid Equations Collision Integrals Using {REDUCE}", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = 178, PUBLISHER = "Springer-Verlag"} @InProceedings{Liska90, author = "R. Liska and L. Drska", title = "{FIDE}: A {REDUCE} package for automation of {FI}nite difference method for solving {pDE}", booktitle = "Proceedings of the 1990 International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "169-176", organization = "ACM", publisher = "Addison-Wesley" } @INPROCEEDINGS{Liska:91, AUTHOR = "Richard Liska and Michail Yu. Shashkov", TITLE = "Algorithms for Difference Schemes Construction on Non-orthogonal Logically Rectangular Meshes", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "419-426", YEAR = 1991, ABSTRACT = {The paper deals with the formalization of the basic operator method for construction of difference schemes for the numerical solving of partial differential equations. The strength of the basic operator method lies on the fact that it produces fully conservative difference schemes. The difference mesh can be non-orthogonal but has to be logically orthogonal. Algorithms for working with grid functions and grid operators in symbolic form which are necessary in the basic operator method are described. The algorithms have been implemented in the computer algebra system REDUCE.}} @ARTICLE{Lloyd:90, AUTHOR = "N. G. Lloyd and J. M. Pearson", TITLE = "{REDUCE} and the Bifurcation of Limit Cycles", JOURNAL = "J. Symbolic Computation", YEAR = 1990, VOLUME = 9, NUMBER = 2, PAGES = "215-224", MONTH = "February"} @INPROCEEDINGS{Loe:85, AUTHOR = "Kia Fock Loe and Noritaka Ohsawa and Eiichi Goto", TITLE = "Circuit Simulation Code Generation by Computer Algebra", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "87-103"} @INPROCEEDINGS{London:74, AUTHOR = "R. London and D. R. Musser", TITLE = "The Application of a Symbolic Mathematical System to Program Verification", YEAR = 1974, PAGES = "265-273", BOOKTITLE = "Proc. {ACM} 74"} @ARTICLE{Loos:72, AUTHOR = "R{\"u}diger Loos", TITLE = "Analytic Treatment of Three Similar {Fredholm} Integral Equations", JOURNAL = "SIGSAM Bulletin", YEAR = 1972, VOLUME = 11, PAGES = "32-40", ABSTRACT = {A {REDUCE} solution to {SIGSAM} Problem \#1 is presented.}} @INPROCEEDINGS{Lottati, AUTHOR = "Itzhak Lottati and Isaac Elishakoff", TITLE = "Refined Dynamical Theories of Beams, Plates and Shells and Their Applications", BOOKTITLE = "Proc. Euromech-Colloquium 219"} @ARTICLE{Louw:86, AUTHOR = "J. A. Louw and F. Schwarz and W. H. Steeb", TITLE = "First Integrals and {Yoshida} Analysis of {Nahm}'s Equation", JOURNAL = "J. Phys. A", YEAR = 1986, VOLUME = 19, PAGES = "L569-L573", COMMENT = {Monopole solutions in Yang-Mills theories explicitely given in special cases. {REDUCE} used for polynomial first integrals and Kowalewski exponents. An application of spde.}} @ARTICLE{Luegger:73, AUTHOR = "J. Luegger and H. Melenk", TITLE = "Darstellung und {Bearbeitung} Umfangreicher {LISP-Programme}", JOURNAL = "Angewandte Informatik", YEAR = 1973, MONTH = "June", PAGES = "257-263"} @TECHREPORT{Luegger:91, AUTHOR = "Joachim L{\"u}gger and Wolfgang Dalitz", TITLE = "Verteilung mathematischer {Software} mittels elektronischer {Netze:} {Die} elektronische {Softwarebibliothek} {eLib}", INSTITUTION = "Konrad-Zuse-Zentrum {f\"u}r Informationstechnik Berlin", YEAR = 1991, MONTH = "February", TYPE = "Preprint", NUMBER = "TR 91-2"} @TECHREPORT{Lukacs, AUTHOR = "B. Luk{\'a}cs and Z. Perj{\'e}s and A. Sebesty{\'e}n and A. Valentini", TITLE = "Stationary Vacuum Fields with a Conformally Flat Three-Space, II. Proof of Axial Symmetry", INSTITUTION = "Central Research Institute for Physics, Budapest, Hungary", YEAR = 1982, NUMBER = "KFKI-1982-19"} @ARTICLE{Lukaszuk:87, AUTHOR = "L. L{\'u}kaszuk and D. M. Siemienczuk and L. Szymanowski", TITLE = "Evaluation of Helicity Amplitudes", JOURNAL = "Phys. Rev. D", YEAR = 1987, VOLUME = 35, PAGES = "326-329"} @PHDTHESIS{Lux:75, AUTHOR = "Augustin Lux", TITLE = "Etude d'un Modele Abstrait pour une Machine {LISP} et de son Implantation", SCHOOL = "Universit{\'e} Scientifique et Medicale de Grenoble", YEAR = 1975, MONTH = "March", COMMENT = {Thesis presented to Universit{\'e} Scientifique et Medicale de Grenoble, Institut National Polytechnique de Grenoble.}} % REDUCE BIBLIOGRAPHY % Part 3: M-Z % Copyright (c) 1990 The RAND Corporation. All Rights Reserved. % Additions and corrections are solicited. Please send them, in the % same format as these entries if possible, to reduce at rand.org. @BOOK{MacCallum:86, AUTHOR = "M. A. H. MacCallum", TITLE = "Dynamical Spacetimes and Numerical Relativity", PUBLISHER = "Cambridge UP", YEAR = 1986} @TECHREPORT{MacCallum:86a, AUTHOR = "M. A. H. MacCallum", TITLE = "Algebraic Computing in Relativity", INSTITUTION = "Queen Mary College, University of London", YEAR = 1986, NUMBER = "TAU 86-04"} @INPROCEEDINGS{MacCallum:87, AUTHOR = "M. A. H. MacCallum", TITLE = "Symbolic Computation in Relativity Theory", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "34-43", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{MacCallum:88, AUTHOR = "M. A. H. MacCallum", TITLE = "An Ordinary Differential Equation Solver for {REDUCE}", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "196-205"} @ARTICLE{MacCallum:89, AUTHOR = "Malcolm A. H. MacCallum", TITLE = "Comments on the performance of algebra systems in general relativity and a recent paper by {Nielsen} and {Pedersen}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1989, VOLUME = 23, NUMBER = 2, PAGES = "22-25", MONTH = "April"} @BOOK{MacCallum:91, AUTHOR = "Malcolm MacCallum and Francis Wright", TITLE = "Algebraic Computing with {REDUCE}", PUBLISHER = "Oxford University Press", YEAR = 1991} @PHDTHESIS{Mack:73, AUTHOR = "D. Mack", TITLE = "Nichtnumerische Verfahren und deren Anwendung in der Elementarteilchen-Physik", SCHOOL = "University of Tuebingen", YEAR = 1973} @ARTICLE{Mack:73a, AUTHOR = "D. Mack and H. Mitter", TITLE = "Calculation of Electron-Electron-Bremsstrahlung Cross-Sections", JOURNAL = "Phys. Lett.", YEAR = 1973, VOLUME = "44A", PAGES = "71-72"} @ARTICLE{Maclaren:89, AUTHOR = "N. M. Maclaren", TITLE = "The Generation of Sequences of Multiple Independent Sequences of Pseudorandom Numbers", JOURNAL = "Applied Statistics {JRSS Series C}", YEAR = 1989, VOLUME = 38, NUMBERS = 2, PAGES = "351-359"} @MASTERSTHESIS{Maguire:81, AUTHOR = "Gerald Quentin {Maguire Jr.}", TITLE = "Program Transformation in {REDUCE} Using Rule Sequencing", SCHOOL = "Department of Computer Science, The University of Utah", YEAR = 1981, MONTH = "March"} @INPROCEEDINGS{Malm:82, AUTHOR = "Bengt Malm", TITLE = "A Program in {REDUCE} for Finding Explicit Solutions", BOOKTITLE = "Proc. {EUROCAM} 1982, Lecture Notes in Computer Science", YEAR = 1982, VOLUME = 144, PAGES = "289-293", PUBLISHER = "Springer-Verlag"} @ARTICLE{Marti:78, AUTHOR = "Jed Marti", TITLE = "The {META/REDUCE} Translator Writing System", JOURNAL = "Sigplan Notices", YEAR = 1978, VOLUME = 13, PAGES = "42-49", COMMENT = {The {META/REDUCE} translator writing system operates in a {LISP} and {REDUCE} syntax. The language supports: {BNF} like syntax, recursive descent parsing schemes, lexical primitives, symbol table primitives and automatic syntax error message generation.}} @ARTICLE{Marti:79, AUTHOR = "J. B. Marti and A. C. Hearn and M. L. Griss and C. Griss", TITLE = "Standard {Lisp} Report", JOURNAL = "Sigplan Notices, ACM", YEAR = 1979, VOLUME = 14, NUMBER = 10, PAGES = "48-68", ABSTRACT = {A description of Standard {LISP} primitive data structures and functions is presented.}} @ARTICLE{Marti:80, AUTHOR = "J. Marti and A. C. Hearn and M. L. Griss and C. Griss", TITLE = "Standard {Lisp} Report", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1980, VOLUME = 14, NUMBER = 1, PAGES = "23-41", MONTH = "February"} @ARTICLE{Marti:83, AUTHOR = "Jed Marti and John Fitch", TITLE = "{REDUCE} 2 for {CP/M}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "26-27", MONTH = "February"} @ARTICLE{Marti:85, AUTHOR = "Jed B. Marti and Anthony C. Hearn", TITLE = "{REDUCE} as a {LISP} Benchmark", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "8-16", MONTH = "August"} @INPROCEEDINGS{Marti:85a, AUTHOR = "Jed B. Marti", TITLE = "The Role of Explanation in Symbolic Computation", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "13-34"} @INPROCEEDINGS{Marti:88, AUTHOR = "J. Marti", TITLE = "A Graphics Interface to {REDUCE}", BOOKTITLE = "Proc. {AAECC-6} 1988, Lecture Notes in Computer Science", YEAR = 1988, VOLUME = 357, PAGES = "274-296", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Marzinkewitsch:91, AUTHOR = "Reiner Marzinkewitsch", TITLE = "Operating Computer Algebra Systems by Handprinted Input", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "411-413", ABSTRACT = {A prototype of a workstation is presented for calculation with mathematical formulas by hand and support by computer algebra systems. Keywords: Character recognition, neural network, computer algebra system, context free grammar, parsing of two dimensional structures.}} @ARTICLE{Matveev:87, AUTHOR = "V. A. Matveev and Ya. Z. Darbaidze and Z. V. Merebashvili and L. A. Slepchenko", TITLE = "Gluon Fusion in {SUSY QCD}", JOURNAL = "Phys. Lett. B", YEAR = 1987, VOLUME = 191, NUMBER = "1 and 2", PAGES = "179-181", MONTH = "June"} @ARTICLE{Maurer:86, AUTHOR = "M. Maurer and A. Hayd and H. J. Kaeppeler", TITLE = "Quasi-Analytical Method for Solving Nonlinear Differential Equations for Turbulent Self-Confined Magneto-Plasma", JOURNAL = "J. Comp. Phys.", YEAR = 1986, VOLUME = 66, PAGES = "151-172", COMMENT = {Mixed {REDUCE} and {FORTRAN}. Enthusiastic about this style of mixed working.}} @TECHREPORT{Mazepa:85, AUTHOR = "N. E. Mazepa and S. I. Serdyukova", TITLE = "The Stability Investigation of Some Difference Boundary Problem with the Application of Symbolic Computation System", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1985, NUMBER = "E5-85-39"} @ARTICLE{Mazzarella:85, AUTHOR = "Giuseppe Mazzarella", TITLE = "Improved Simplification of Odd and Even Functions in {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "29-30", MONTH = "May"} @ARTICLE{McCrea:81, AUTHOR = "J. D. McCrea", TITLE = "The {Petrov} Type of a Static Vacuum Spacetime Near a Normal-Dominated Singularity", JOURNAL = "J. Phys.", YEAR = 1981, VOLUME = "A14", PAGES = "1351-1356"} @ARTICLE{McCrea:82, AUTHOR = "J. D. McCrea", TITLE = "A Stationary Cylindrically Symmetric Electrovac Spacetime", JOURNAL = "J. Phys.", YEAR = 1982, VOLUME = "A15", PAGES = "1587-1590"} @ARTICLE{McCrea:83, AUTHOR = "J. D. McCrea", TITLE = "Static, Vacuum, Cylindrical and Plane Symmetric Solutions of the Quadratic {Poincar{\'e}} Gauge Field Equations", JOURNAL = "J. Phys.", YEAR = 1983, VOLUME = "A16", PAGES = "997-1004"} @ARTICLE{McCrea:84, AUTHOR = "J. D. McCrea", TITLE = "A {NUT}-Like Solution of the Quadratic-{Poincar{\'e}} Gauge Field Equations", JOURNAL = "Phys. Lett.", YEAR = 1984, VOLUME = "100A", PAGES = "397-399"} @INPROCEEDINGS{McCrea:84a, AUTHOR = "J. D. McCrea", TITLE = "The Use of {REDUCE} in Finding Exact Solutions of the Quadratic {Poincar{\'e}} Gauge Field Equations", BOOKTITLE = "Classical General Relativity", PUBLISHER = "Cambridge University", YEAR = 1984, PAGES = "173-182"} @INPROCEEDINGS{McCrea:87, AUTHOR = "J. D. McCrea", TITLE = "{Poincar{\'e}} Gauge Theory of Gravitation: Foundations, Exact Solutions and Computer Algebra", YEAR = 1987, PAGES = "16", BOOKTITLE = "Differential Geometric Methods in Mathematical Physics, Proc. {14th} International Conference, Salamanca, 1985 (Springer Lecture Notes in Mathematics, No. 1251)"} @ARTICLE{McCrea:87a, AUTHOR = "J. D. McCrea and P. Baekler and M. Guerses", TITLE = "A {Kerr}-Like Solution of the {Poincar{\'e}} Gauge Field Equations", JOURNAL = "Il Nuovo Cim", YEAR = 1987, VOLUME = "99B", PAGES = "171-177"} @ARTICLE{McCrea:88, AUTHOR = "J. D. McCrea and E. W. Mielke and F. W. Hehl", TITLE = "A Remark on the Axisymmetric {Chen} et al. Solution of the {Poincar{\'e}} Gauge Theory", JOURNAL = "Phys. Lett.", YEAR = 1988, VOLUME = "127A", PAGES = "65-69"} @ARTICLE{McIsaac:85, AUTHOR = "Kevin McIsaac", TITLE = "Pattern Matching Algebraic Identities", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "4-13", MONTH = "May"} @TECHREPORT{Melenk:88, AUTHOR = "H. Melenk and H. M. M{\"o}ller and W. Neun", TITLE = "On {Gr{\"o}bner} Bases Computation on a Supercomputer Using {REDUCE}", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1988, TYPE = "Preprint", NUMBER = "SC 88-2", MONTH = "January"} @ARTICLE{Melenk:89, AUTHOR = "H. Melenk and H. M. M{\"o}ller and W. Neun", TITLE = "Symbolic Solution of Large Stationary Chemical Kinetics Problems", JOURNAL = "Impact of Computing in Science and Engineering", YEAR = 1989, VOLUME = 1, NUMBER = 2, PAGES = "138-167", MONTH = "June"} @TECHREPORT{Melenk:89a, AUTHOR = "Herbert Melenk and Winfried Neun", TITLE = "Implementation of {Portable Standard LISP} for the {SPARC} Processor", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1989, TYPE = "Preprint", NUMBER = "SC 89-6", MONTH = "July"} @ARTICLE{Melenk:89b, AUTHOR = "Herbert Melenk and Winfried Neun", TITLE = "Parallel Polynomial Operations in the Large {Buchberger} Algorithm", JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora and J. Fitch", YEAR = 1989, PAGES = "143-158", PUBLISHER = "Academic Press, London"} @ARTICLE{Mirie:84, AUTHOR = "R. M. Mirie and C. H. Su", TITLE = "Internal Solitary Waves and Their Head-On Collision Part I", JOURNAL = "J. Fluid Mechanics", YEAR = 1984, VOLUME = 147, PAGES = "213-231", COMMENT = {Lengthy calculation "acknowledge the use of {REDUCE-2}." Perturbation and integration.}} @INPROCEEDINGS{Molenkamp:91, AUTHOR = "J.H.J. Molenkamp and V.V. Goldman and J.A. van Hulzen", TITLE = "An Improved Approach to Automatic Error Cumulation Control", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "414-418", ABSTRACT = {For evaluation of arithmetical expressions using multiple precision floating-point arithmetic, a method is given to automatically perform error cumulation control prior to the actual computations. Individual errors and their effects are identified, and it is shown how to compute these effects efficiently via automatic differentiation. In the presented approach these effects are used to determine which precisions have to be chosen during the real computations, in order to limit error cumulation to admissible, user chosen error bounds.}} @TECHREPORT{Moller:89, AUTHOR = "H. Michael M{\"o}ller", TITLE = "Multivariate Rational Interpolation Reconstruction of Rational Functions", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1989, TYPE = "Preprint", NUMBER = "SC 89-4", MONTH = "July"} @INPROCEEDINGS{Moritsugu:85, AUTHOR = "S. Moritsugu and N. Inada and E. Goto", TITLE = "Symbolic {Newton} Iteration and its Application", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "105-117"} @TECHREPORT{Moritsugu:88, AUTHOR = "S. Moritsugu and E. Goto", TITLE = "A Proposal for Improvement of Facilities of {REDUCE}", INSTITUTION = "Department of Information Science, University of Tokyo, Japan", YEAR = 1988, MONTH = "December"} @ARTICLE{Moritsugu:89, AUTHOR = "Shuichi Moritsugu and Eiichi Goto", TITLE = "A Note on the Preconditioning for Factorization of Homogeneous Polynomials", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1989, VOLUME = 23, NUMBER = 1, PAGES = "9-12", MONTH = "January"} @ARTICLE{Moritsugu:89a, AUTHOR = "Shuichi Moritsugu and Makoto Matsumoto", TITLE = "A Note on the Numerical Evaluation of Arctangent Function", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1989, VOLUME = 23, NUMBER = 3, PAGES = "8-12", MONTH = "July"} @ARTICLE{Muroa:91, AUTHOR = "Hirokazu Murao", TITLE = "Vectorization of symbolic determinant calculation", JOURNAL = "Supercomputer", YEAR = 1991, VOLUME = "43,VIII-3", PAGES = "36-48"} @ARTICLE{Mueller:81, AUTHOR = "R. M{\"u}ller and H. J. W. M{\"u}ller-Kirsten", TITLE = "Iteration of Single- and Two-Channel {Schr{\"o}dinger} Equations", JOURNAL = "J. Math. Phys.", YEAR = 1981, VOLUME = 22, PAGES = "733-749", ABSTRACT = {{\dots} we describe an iteration procedure which has already been applied to a large number of other problems. With the help of {REDUCE} it is now possible to do these algebraic computations on the computer, so that the necessary expressions are obtained within a reasonable time.}} @ARTICLE{Murzin:85, AUTHOR = "F. A. Murzin", TITLE = "Syntactic Properties of the {REFAL} Language", JOURNAL = "Int. J. Computer Maths.", YEAR = 1985, VOLUME = 17, PAGES = "123-139", COMMENT = {{SNOBOL-like} special purpose algebra system. Designed for Cartan work. "{REFAL} is rather an unusual programming language. It is natural to ask in which situations it is useful." Concludes {MACSYMA} or {REDUCE} for standard manipulations, {REFAL} for nonstandard.}} @TECHREPORT{Nagata:82, AUTHOR = "Morio Nagata and Makoto Shibayama", TITLE = "{COSMOS:} A Conversational Algebraic System", INSTITUTION = "Department of Administration Engineering, Keio University", YEAR = 1982, TYPE = "Technical Report", NUMBER = "No. 8201", MONTH = "March"} @INPROCEEDINGS{Nagata:85, AUTHOR = "Morio Nagata and Makoto Shibayama", TITLE = "An Interactive Algebraic System for Personal Computing", YEAR = 1985, BOOKTITLE = "IEEE International Symposium on New Directions in Computing"} @BOOK{Nakamura:89, AUTHOR = "Hideharu Nakamura and Shouichi Matsui", TITLE = "Symbolic Computation in Structural Mechanics using {REDUCE}", PUBLISHER = "Gihodo Shuppan Company Ltd.", ADDRESS = "1-11-41, Akasaka, Minato-Ku, 107 Tokyo, {Japan}", YEAR = 1989} @ARTICLE{Nakashima:84, AUTHOR = "T. T. Nakashima and R. E. D. McClung and B. K. John", TITLE = "A Simple Method for the Determination of the Deuterium Decoupler Pulse Angle", JOURNAL = "J. Magnetic Resonance", YEAR = 1984, VOLUME = 56, PAGES = "262-274", COMMENT = {{REDUCE} used in theoretical part. "All density matrix calculations presented here were performed on a digital computer using REDUCE-2." Essentially matrix products.}} @ARTICLE{Nakashima:84a, AUTHOR = "T. T. Nakashima and R. E. D. McClung and B. K. John", TITLE = "Experimental and Theoretical Investigation of $_{2}D-_{13}C$ DEPT Spectra on $CD_{N}$", JOURNAL = "J. Magnetic Resonance", YEAR = 1984, VOLUME = 58, PAGES = "27-36", COMMENT = {"All calculations were performed using {REDUCE-2}."}} @ARTICLE{Namba:86, AUTHOR = "Kenji Namba", TITLE = "Some Improvements on {Utah} {Standard} {Lisp}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1986, VOLUME = 20, NUMBER = "1 and 2", PAGES = "29-36", MONTH = "February and May"} @ARTICLE{Nemeth:82, AUTHOR = "G. N{\'e}meth and M. Zim{\'a}nyi", TITLE = "Polynomial Type {Pad\'e} Approximants", JOURNAL = "Math. Comp.", YEAR = 1982, VOLUME = 38, PAGES = "553-565", COMMENT = {Looking for approximants where $R_{n}(x)$ is $P_{n}(x)$/P_{n-1}(x)$. Applied in special functions. Used REDUCE and FORMAC mainly for bignum calculations.}} @INPROCEEDINGS{Nemeth:87, AUTHOR = "G. N{\'e}meth and M. Zim{\'a}nyi", TITLE = "Computation of Generalized {Pad\'e} Approximants", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "450-451", PUBLISHER = "Springer-Verlag"} @ARTICLE{Neun:89, AUTHOR = "W. Neun and H. Melenk", TITLE = "Implementation of the {LISP-}Arbitrary Precision Arithmetic for a {Vector} Processor", JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora and J. Fitch", YEAR = 1989, PAGES = "75-89", PUBLISHER = "Academic Press, London"} @ARTICLE{Neutsch:85, AUTHOR = "W. Neutsch and E. Schr{\"u}fer and A. Jessner", TITLE = "Note on Efficient Integration on the Hypersphere", JOURNAL = "J. Comp. Phys.", YEAR = 1985, VOLUME = 59, PAGES = "167-175", COMMENT = {{REDUCE} used for integration on 4-D hypersphere. {REDUCE} use rather small.}} @ARTICLE{Neutsch:86, AUTHOR = "W. Neutsch and E. Schr{\"u}fer", TITLE = "Simple Integrals for Solving {Kepler}'s Equation", JOURNAL = "Astrophysics and Space Science", YEAR = 1986, VOLUME = 125, PAGES = "77-83", COMMENT = {Uses {REDUCE} to verify calculations to give integral form which is numerically good, involving only rationals and exponentials.}} @ARTICLE{Ng:89, AUTHOR = "Tze Beng Ng", TITLE = "Computation of the Cohomology of ${B\hat{S}O_{n}<16>}$ for $23 \leq n \leq 26$ using {REDUCE}", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 7, NUMBER = 1, PAGES = "93-99", MONTH = "January"} @ARTICLE{Niki:84, AUTHOR = "Naoto Niki and Sadanori Konishi", TITLE = "Higher Order Asymptotic Expansions for the Distribution of the Sample Correlation Coefficient", JOURNAL = "Comm. Statist.-Simula. Comp.", YEAR = 1984, VOLUME = 13, NUMBER = 2, PAGES = "169-182"} @TECHREPORT{Nikityuk:87, AUTHOR = "N. M. Nikityuk", TITLE = "Some Questions of Using Coding Theory and Analytical Calculation Methods on Computers", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1987, NUMBER = "E11-87-10"} @ARTICLE{Noor:79, AUTHOR = "A. K. Noor and C. M. Andersen", TITLE = "Computerized Symbolic Manipulation in Structural Mechanics - Progress and Potential", JOURNAL = "Computers and Structures", YEAR = 1979, VOLUME = 10, PAGES = "95-118", COMMENT = {Concentrates on {MACSYMA} but mentions {FORMAC} and {REDUCE} as also having been used in structures. Mainly finite elements. Includes program and output.}} @INPROCEEDINGS{Norman:77, AUTHOR = "A. C. Norman and P. M. A. Moore", TITLE = "Implementing the New {Risch} Integration Algorithm", YEAR = 1977, MONTH = "March", BOOKTITLE = "Proc. of the Fourth Colloquium on Advanced Comp. Methods in Theor. Phys., St. Maximin, France"} @ARTICLE{Norman:78, AUTHOR = "Arthur Norman", TITLE = "Towards a {REDUCE} solution to {SIGSAM} Problem 7", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1978, VOLUME = 12, NUMBER = 4, PAGES = "14-18", MONTH = "November"} @INPROCEEDINGS{Norman:79, AUTHOR = "A. C. Norman and J. H. Davenport", TITLE = "Symbolic Integration - The Dust Settles?", BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "398-407", PUBLISHER = "Springer-Verlag"} @ARTICLE{Norman:83, AUTHOR = "Arthur C. Norman and Paul S. Wang", TITLE = "A Comparison of the {Vaxima} and {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "28-30", MONTH = "February"} @InProceedings{Norman90, author = "A. C. Norman", title = "A Critical-Pair/Completion based Integration Algorithm", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "201-205", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Norton:80, AUTHOR = "Lewis M. Norton", TITLE = "A Note About {Laplace} Transform Tables for Computer Use", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1980, VOLUME = 14, NUMBER = 2, PAGES = "30-31", MONTH = "May"} @TECHREPORT{Nucci:90, AUTHOR = "M. C. Nucci", TITLE = "Interactive {REDUCE} Programs for Calculating Classical, Non-Classical and {Lie-B{\"a}cklund} Symmetries of Differential Equations", INSTITUTION = "Georgia Institute of Technology, School of Mathematics", YEAR = 1990, TYPE = "Preprint", NUMBER = "Math: 062090-051"} @BOOK{Ochiai:90, AUTHOR = "Mitsuyuki Ochiai and Kiyokazu Nagatomo", TITLE = "Linear Algebra using {REDUCE}", PUBLISHER = "Kindai Kagaku sha, Tokyo", MONTH = "January", YEAR = 1990, COMMENT = {In Japanese.}} @ARTICLE{Ogilvie:82, AUTHOR = "J. F. Ogilvie", TITLE = "Applications of Computer Algebra in Physical Chemistry", JOURNAL = "Computers in Chemistry", YEAR = 1982, VOLUME = 6, NUMBER = 4, PAGES = "169-172", COMMENT = {After distinguishing between algebraic and numerical computing, the author outlines the facilities of some algebraic or symbolic processors and provides some instances of how some important features can be applied to problems in physical chemistry.}} @ARTICLE{Ogilvie:89, AUTHOR = "J. F. Ogilvie", TITLE = "Computer algebra in modern physics", JOURNAL = "Computers in Physics", YEAR = 1989, MONTH = "January/February", PAGES = "66-74"} @TECHREPORT{Ono:1979, AUTHOR = "Kiyoshi Ono", TITLE = "{BFORT} -- A {Fortran} System with Arbitrary Precision Integer and Real Arithmetic", INSTITUTION = "Department of Physics, University of Tokyo", YEAR = 1979, MONTH = "January"} @TECHREPORT{Ozieblo, AUTHOR = "A. Ozieblo", TITLE = "Application of {REDUCE 2} in General Theory of Relativity", INSTITUTION = "Cyfronet - Krakow, Poland", COMMENT = {Application of {REDUCE 2} in all calculations typical for General Theory of Relativity is shown here. The most spectacular usage of {REDUCE 2} appears to be in various aspects of tensor calculus including differentiation operations.}} @InProceedings{Padget90, author = "Julian Padget and Alan Barnes", title = "Univariate Power Series Expansions in {REDUCE}", booktitle = "Proceedings of the International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "82-87", organization = "ACM", publisher = "Addison-Wesley" } @ARTICLE{Pankau:73, AUTHOR = "E. Pankau and W. Nakel", TITLE = "Measurement of the Absolute Cross Section of the Elementary Process of Electron-Electron Bremsstrahlung at 300 {keV}", JOURNAL = "Phys. Lett.", YEAR = 1973, VOLUME = "44A", PAGES = "65-67"} @ARTICLE{Pankau:73a, AUTHOR = "E. Pankau and W. Nakel", TITLE = "Eine {Koinzidenzmessung} zum {Elementarprozess} der {Elektron-Elektron-Bremsstrahlung} bei 300 {keV}", JOURNAL = "Z. Physik", YEAR = 1973, VOLUME = 264, PAGES = "139-153"} @ARTICLE{Parsons:68, AUTHOR = "R. G. Parsons", TITLE = "An Estimate of the Sixth Order Contribution to the Anomalous Magnetic Moment of the Electron", JOURNAL = "Phys. Rev.", YEAR = 1968, VOLUME = 168, PAGES = "1562-1567"} @TECHREPORT{Parsons:71, AUTHOR = "R. G. Parsons", TITLE = "S-Channel Transformation Matrices for Helicity and Invariant Amplitudes for lambda + N to O + B", INSTITUTION = "Center for Particle Theory, University of Texas", YEAR = 1971, TYPE = "Memo", NUMBER = "CPT-88", MONTH = "January"} @ARTICLE{Pasini:91, AUTHOR = "P. Pasini and F. Semeria and C. Zannoni", TITLE = "Symbolic computation of orientational correlation function moments", JOURNAL = "J. Symbolic Computation", YEAR = 1991, VOLUME = 12, NUMBER = 2, PAGES = "221-231", MONTH = "August"} COMMENTS = {Symbolic manipulation (REDUCE and SCHOONSCHIP) has been applied to the analytic evaluation of the coefficients in the Taylor series expansion of time-correlation functions. These expressions are derived for cylindrically and biaxially symmetric particles reorienting in a uniaxial fluid. The possibility of using computer algebra to determine correlation-function moments should make it applicable to various problems in statistical physics.}} @ARTICLE{Pattnaik:83, AUTHOR = "P. C. Pattnaik and G. Fletcher and J. L. Fry", TITLE = "Improved Numerical Stability for Norm-Conserving ion-{Ure} Pseudopotentials", JOURNAL = "Phys. Rev. B", YEAR = 1983, VOLUME = 28, NUMBER = 6, PAGES = "3364-3365", COMMENT = {{REDUCE} and {FORTRAN}; inverting a matrix algebraically would be more accurate than a numerical inverse, and used {REDUCE} for this part of their work.}} @ARTICLE{Pearce:81, AUTHOR = "P. D. Pearce and R. J. Hicks", TITLE = "The Application of Algebraic Optimisation Techniques to Algebraic Mode Programs for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1981, VOLUME = 15, NUMBER = 4, PAGES = "15-22", MONTH = "November"} @ARTICLE{Pearce:83, AUTHOR = "P. D. Pearce and R. J. Hicks", TITLE = "Data Structures and Execution Times of Algebraic Mode Programs for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "31-37", MONTH = "February"} @ARTICLE{Perjes:84, AUTHOR = "Z. Perj{\'e}s", TITLE = "Stationary Vacuum Fields with a Conformally Flat Three-Space. {III}. {Complete} Solution", JOURNAL = "General Relativity and Gravitation", YEAR = 1984, VOLUME = 18, PAGES = "531-547", COMMENT = {{REDUCE} used to perform the necessary calculations.}} @ARTICLE{Perjes:84a, AUTHOR = "Z. Perj{\'e}s and B. Luk{\'a}cs and A. Sebesty{\'e}n and A. Valentini", TITLE = "Solution of the Stationary Vacuum Equations of Relativity for Conformally Flat 3-Spaces", JOURNAL = "Phys. Lett.", YEAR = 1984, VOLUME = {100A}, NUMBER = 8, PAGES = "405-406", MONTH = "February"} @TECHREPORT{Perjes:84b, AUTHOR = "Z. Perj{\'e}s", TITLE = "Improved Characterization of the {Kerr} Metric", INSTITUTION = "Hungarian Academy of Sciences, Central Research Institute for Physics", YEAR = 1984, NUMBER = "KFKI-1984-115"} @TECHREPORT{Perjes:84c, AUTHOR = "Z. Perj{\'e}s", TITLE= "Stationary Vacuum Fields with a Conformally Flat Three-Space. {IV}. {Complete} Solution", INSTITUTE = "Institute for Nuclear Study, University of Tokyo", YEAR = 1984, NUMBER = "INS-REP.-487", MONTH = "January"} @TECHREPORT{Perjes:86, AUTHOR = "Z. Perj{\'e}s", TITLE = "Ernst Coordinates", INSTITUTION = "Hungarian Academy of Sciences, Central Research Institute for Physics", YEAR = 1986, TYPE = "Preprint", NUMBER = "KFKI-1986-33/B"} , @ARTICLE{Perjes:86a, AUTHOR = "Z. Perj{\'e}s", TITLE = "Stationary Vacuum Fields with a Conformally Flat Three-Space. {II}. {Proof} of Axial Symmetry", JOURNAL = "General Relativity and Gravitation", YEAR = 1986, VOLUME = 18, NUMBER = 5, PAGES = "511-530", MONTH = "May"} @ARTICLE{Perjes:88, AUTHOR = "Z. Perj{\'e}s", TITLE = "Approaches to Axisymmetry by Man and Machine", BOOK = "Relativity Today", YEAR = 1988, EDITOR = "Z. Perjes", PUBLISHER = "World Scientific, Singapore"} @ARTICLE{Perlt:90, AUTHOR = "H. Perlt and J. Ranft and J. Heinrich", TITLE = "Calculation of {QED} graphs with the {Spinor} technique", JOURNAL = "Comp. Phys. Commun.", YEAR = 1990, VOLUME = 56, NUMBER = 3, PAGES = "385-390", MONTH = "January"} @TECHREPORT{Perrottet:78, AUTHOR = "M. Perrottet", TITLE = "Signature for {W} Boson Production From Jet Analysis In e+e- $\rightarrow$ {W+W-} $\rightarrow$ Hadrons", INSTITUTION = "CPT 2, CNRS, Marseille", YEAR = 1978, TYPE = "Preprint", NUMBER = "78/P.1019", MONTH = "June", ABSTRACT = {We have computed the ratio o(e+e- $\rightarrow$ W+W- $\rightarrow$ Hadrons)/ o(e+e- $\rightarrow$ G,Z $\rightarrow$ Hadrons) as a function of the {CM} energy in the Weinberg-Salam model.}} @TECHREPORT{Pesic:73, AUTHOR = "P. D. Pesic", TITLE = "Two-Photon Cross Section for {W}-Pair Production by Colliding Beams", INSTITUTION = "Stanford University", YEAR = 1973, TYPE = "Report", NUMBER = "SLAC-PUB-1188", COMMENT = {Stanford University Linear Accelerator Report.}} @PHDTHESIS{Pictiaw:69, AUTHOR = "Chen Pictiaw", TITLE = "An Analytical Investigation of Infinitesimal Spatial Motion Theory and its Application to Three-Dimensional Linkages", SCHOOL = "Dept. of Mech. Eng., Stanford University", YEAR = 1969, MONTH = "March"} @ARTICLE{Piessens:84, AUTHOR = "R. Piessens", TITLE = "A Series Expansion for the First Positive Zero of the {Bessel} Function", JOURNAL = "Math. Comp.", YEAR = 1984, VOLUME = 42, PAGES = "195-197", COMMENT = {Gives explicit series for first positive zero for 4 terms, using {REDUCE}.}} @ARTICLE{Piessens:86, AUTHOR = "R. Piessens and S. Ahmed", TITLE = "Note on Approximation for the Turning Points of {Bessel} Functions", JOURNAL = "J. Comp. Phys.", YEAR = 1986, VOLUME = 64, PAGES = "253-257", COMMENT = {{REDUCE} used to differentiate and give expansions.}} @ARTICLE{Pignataro:85, AUTHOR = "M. Pignataro and A. Luongo and N. Rizzi", TITLE = "On the Effect of the Local Overall Interaction on the Postbuckling of Uniformly Compressed Channels", JOURNAL = "Thin-Walled Structures", YEAR = 1985, VOLUME = 3, PAGES = "292-321", COMMENT = {{REDUCE} generating {FORTRAN}, but also used to investigate the form of the solutions.}} @MASTERSTHESIS{Podgorzak:84, AUTHOR = "E. Podg{\'o}rak and I. Romanowska", TITLE = "Application of {REDUCE} 2 to the Construction of Recurrence Relations", SCHOOL = "Institute of Computer Science, University of Wroclaw", YEAR = "1984"} @ARTICLE{Price:84, AUTHOR = "S. L. Price and A. J. Stone and M. Alderton", TITLE = "Explicit Formulae for the Electrostatic Energy, Forces and Torques Between a Pair of Molecules of Arbitrary Symmetry", JOURNAL = "Molecular Phys.", YEAR = 1984, VOLUME = 52, PAGES = "987-1001", COMMENT = {"The substitution of the complex multipoles and the S functions into the expression for the electrostatic energy was facilitated by the use of the symbolic algebraic manipulation program {REDUCE}." Involves heavy calculations.}} @TECHREPORT{Quarton, AUTHOR = "D. C. Quarton and A. D. Garrad", TITLE = "Some Comments on the Stability Analysis of Horizontal Axis Wind Turbines", INSTITUTION = "Wind Energy Group, Taylor Woodrow Construction Ltd."} @TECHREPORT{Quarton:84, AUTHOR = "D. C. Quarton and A. D. Garrad", TITLE = "Symbolic Computing as a Tool in Wind Turbine Dynamics", INSTITUTION = "Wind Energy Group, Taylor Woodrow Construction Ltd.", YEAR = 1984, COMMENT = {Presented at the European Wind Energy Conference and Exhibition 22-26 Oct 1984, Hamburg.}} @MASTERSTHESIS{Rao:85, AUTHOR = "R. H. Rao", TITLE = "Deformation of a Fluid-Filled Cylindrical Membrane by a Slow Viscous Shear Flow", SCHOOL = "Washington University", ADDRESS = "Dept. of Mech. Eng., Washington University, St. Louis", YEAR = "1985", COMMENT = {Draws attention to the use of classical perturbation techniques combined with computer algebra as an alternative to numerical calculation.}} @BOOK{Rayna:87, AUTHOR = "G. Rayna", TITLE = "{REDUCE}: A System for Computer Algebra", PUBLISHER = "Springer-Verlag", YEAR = 1987} @INPROCEEDINGS{Renner:91, AUTHOR = "Friedrich Renner", TITLE = "Nonlinear Evolution Equations and the {Painlev{\'e}} Analysis: A constructive Approach with {REDUCE}", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "289-294", ABSTRACT = {A number of necessary conditions for a class of nonlinear partial differential equations to pass the Painlev{\'e} test with the Kruskal ansatz is given. Using these we can (theoretically) construct all evolution equations of certain form and this property with a computer algebra package based on {REDUCE}.}} @ARTICLE{Reusch:86, AUTHOR = "M. F. Reusch and G. H. Neilson", TITLE = "Torodially Symmetric Polynomial Multipole Solutions of the Vector {Laplace} Equation", JOURNAL = "J. Comp. Phys.", YEAR = 1986, VOLUME = 64, PAGES = "416-432", COMMENT = {{REDUCE} (plasma MHD) algebraic form of multipoles, then numerical.}} @PHDTHESIS{Rink:71, AUTHOR = "R. A. Rink", TITLE = "Application of a Digital Computer to Solve Analytically Special Classes of Linear and Nonlinear Differential Equations", SCHOOL = "Stanford University", YEAR = 1971} @ARTICLE{Rizzi:85, AUTHOR = "N. Rizzi and A. Tatone", TITLE = "Symbolic Manipulation in Buckling and Postbuckling Analysis", JOURNAL = "Computers and Structures", YEAR = 1985, VOLUME = 21, PAGES = "691-700", COMMENT = {Gives {REDUCE} program and output for generating {FORTRAN}.}} @ARTICLE{Rodionov:84, AUTHOR = "A. Ya. Rodionov", TITLE = "Work with {non-commutative} variables in the {REDUCE-2} system for analytical calculations", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1984, VOLUME = 18, NUMBER = 3, PAGES = "16-19", MONTH = "August"} @ARTICLE{Rodionov:87, AUTHOR = "A. Ya. Rodionov and A. Yu. Taranov", TITLE = "Computation of Covariant Derivatives of the Geodetic Interval within the Coincident Arguments", JOURNAL = "Class. Quantum Grav.", YEAR = 1987, VOLUME = 4, PAGES = "1767-1775", COMMENT = {Used {REDUCE} to calculate the geodetic interval of the Riemannian manifold by calculating the multiple covariant derivatives of orders 7 and 8. Direct use of {REDUCE} was not sufficient, but some investigations of the structure of the problem produced some recurrence relations.}} @INPROCEEDINGS{Rodionov:87a, AUTHOR = "A. Ya. Rodionov and A. Yu. Taranov", TITLE = "Combinatorial Aspects of Simplification of Algebraic Expressions", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "192-201", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Rodionov:88, AUTHOR = "A. Ya. Rodionov and A. Yu. Taranov", TITLE = "{RTENSOR - Packet} for work with tensoric expressions", INSTITUTION = "Moscow State University, Scientific Research Institute of Nuclear Physics", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-29/50"} @INPROCEEDINGS{Roelofs:91, AUTHOR = "Marcel Roelofs and Peter K.H. Gragert", TITLE = "Implementation of multilinear operators in {REDUCE} and applications in mathematics", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "390-396", ABSTRACT = {In this paper we introduce and implement a concept for dealing with mathematical bases of linear spaces and mappings (multi)linear with respect to such bases, in {REDUCE}. Using this concept we give some examples how to implement some well known (multi)linear mappings in mathematics with very little effort. Moreover we implement a procedure operatorcoeff similar to the standard {REDUCE} procedure coeff, but now for linear spaces instead of polynomial rings.}} @BOOK{Rogers:89, AUTHOR = "C. Rogers and W. F. Ames", TITLE = "Nonlinear Boundary Value Problems in Science and Engineering", PUBLISHER = "Academic Press, Inc.", YEAR = 1989} @ARTICLE{Roque:88, AUTHOR = "Waldir L. Roque and Renato P. dos Santos", TITLE = "Computa\c{c}\~{a}o alg\'{e}brica: ``um assistente matem\~{a}tico''", JOURNAL = "Ci\^{e}ncia e Cultura", YEAR = 1988, VOLUME = 40, NUMBER = 9, PAGES = "843-852", MONTH = "September", ABSTRACT = {In this paper we discuss in a simple and informative way the theme ``algebraic computing'' in an attempt to encourage the Brasilian scientific community to make use of this new tool{\ldots}. Many algebraic computing systems have been developed in a variety of research fields. Some of these systems, their main characteristics and applications will be discussed.}, COMMENT = {In Portuguese}} @ARTICLE{Roque:91, AUTHOR = "Waldir L. Roque and Renato P. dos Santos", TITLE = "Computer algebra in spacetime embedding", JOURNAL = "J. Symbolic Computation", YEAR = 1991, VOLUME = 12, NUMBER = 3, PAGES = "381-389", MONTH = "September", ABSTRACT = {In this paper we describe an algorithm to determine the vectors normal to a space-time ${V}_{4}$ embedded in a pseudo-Euclidean manifold ${M}_{4+N}$. An application of this algorithm is given considering the Schwarzchild spacetime geometry embedded in a 6 dimensional pseudo-Euclidean manifold, using the algebraic computing system REDUCE.}} @ARTICLE{Ronveaux:88, AUTHOR = "A. Ronveaux and G. Thiry", TITLE = "Polynomial Solution of Recurrence Relation and Differential Equation", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1988, VOLUME = 22, NUMBER = 4, PAGES = "9-19", MONTH = "October"} @ARTICLE{Ronveaux:89, AUTHOR = "A. Ronveaux and G. Thiry", TITLE = "Differential Equations of Some Orthogonal Families in {REDUCE}", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 8, NUMBER = 5, PAGES = "537-541", MONTH = "November"} @INPROCEEDINGS{Rudenko:91, AUTHOR = "V.M. Rudenko and V.V. Leonov and A.F. Bragazin and I.P Shmyglevsky", TITLE = "Application of Computer Algebra to the Investigation of the Orbital Satellite Motion", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "450-451"} @ARTICLE{Saez:83, AUTHOR = "A. E. Saez and B. J. McCoy", TITLE = "Transient Analysis of Packed-Bed Thermal Storage Systems", JOURNAL = "Int. J. Heat Mass Transfer", YEAR = 1983, VOLUME = 26, NUMBER = 1, PAGES = "49-54"} @ARTICLE{Sage:88, AUTHOR = "Martin L. Sage", TITLE = "An Algebraic Treatment of Quantum Vibrations", JOURNAL = "J. Symbolic Computation", YEAR = 1988, VOLUME = 5, NUMBER = 3, PAGES = "377-384", MONTH = "June"} @TECHREPORT{Sarlet:91, AUTHOR = "W. Sarlet and J. Vanden Bonne", TITLE = "{REDUCE-} procedures for the study of adjoint symmetries of second-order differential equations", INSTITUTION = "University of Gent, Cage Computer Algebra Group", NUMBER = 7, YEAR = 1991, TYPE = "Preprint"} @INPROCEEDINGS{Sasaki:79, AUTHOR = "Tateaki Sasaki", TITLE = "An Arbitrary Precision Real Arithmetic Package in {REDUCE}", BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "358-368", PUBLISHER = "Springer-Verlag", ABSTRACT = {A {REDUCE} arbitrary precision real arithmetic package is described which will become a part of the kernel of an algebraic-numeric system being developed for {REDUCE}.}} @ARTICLE{Savage:90, AUTHOR = "Stuart B. Savage", TITLE = "Symbolic computation of the flow of granular avalanches", JOURNAL = "J. Symbolic Computation", YEAR = 1990, VOLUME = 9, NUMBER = 4, PAGES = "515-530", MONTH = "April"} @ARTICLE{Sayers:87, AUTHOR = "C. M. Sayers", TITLE = "The Elastic Anisotropy of Polycrystalline Aggregates of Zirconium and Its Alloys", JOURNAL = "J. Nuclear Materials", YEAR = 1987, VOLUME = 144, PAGES = "211-213", COMMENT = {Used {REDUCE} for calculations of tensor products.}} @ARTICLE{Sayers:87a, AUTHOR = "C. M. Sayers", TITLE = "Elastic Wave Anisotropy in the Upper Mantle", JOURNAL = "Geophysical J. R. Ast. Soc.", YEAR = 1987, VOLUME = 88, PAGES = "417-424", COMMENT = {Used {REDUCE} in calculations. "Theoretical expressions for angular dependence of the longitudinal and shear wave velocities in an axially symmetric aggregate{\ldots}"}} @INPROCEEDINGS{Schlegel:91, AUTHOR = "H. Schlegel", TITLE = "Determination of the Root System of Semisimple {Lie} Algbras from the {Dynkin} Diagram", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "239-240"} @INPROCEEDINGS{Schmuck:77, AUTHOR = "P. Schmuck", TITLE = "Verification of the Transient, Two Phase Fluid Flow Program {Kachina} using Computerized Similarity Analysis", YEAR = 1977, MONTH = "October", BOOKTITLE = "Second {GAMM} Conference on Numerical Methods in Fluid Mechanics, k{\"o}ln"} @TECHREPORT{Schoepf:91, AUTHOR = "Rainer Sch{\"o}pf and Peter Deuflhard", TITLE = "{OCCAL} A mixed symbolic-numeric Optimal Control {CALculator}", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1991, TYPE = "Preprint", NUMBER = "SC 91-13", MONTH = "December", ABSTRACT = {The numerical solution of optimal control problems by indirect methods (such as multiple shooting or collocation) requires a considerable amount of analytic calculation to establish a numerically tractable system. These analytic calculations, though being rather tedious in realistic examples, are nowadays mostly still done by hand--and thus prone to calculation errors. The paper aims at automating this analytic processing to a reasonable extent by means of a modern symbolic manipulation language (here: REDUCE). In its present stage of development the package OCCAL (mnemotechnically for Optimal Control CALculator) permits an interactive use, covering tasks like automatic determination of control and, in case of a singular control, of its order. In simpler problems, the present version of OCCAL automatically produces the full subroutine input for a MULtiple shooting code (MULCON) with adaptive numerical CONtinuation. In more complicated problems where singular sub-arcs may occur or where the sequence of sub-arcs of the optimal trajectory is unclear OCCAL is a significant help in reducing analytic pre-processing. Examples illustrate the performance of OCCAL/MULCON.}} @ARTICLE{Schruefer:81, AUTHOR = "E. Schr{\"u}fer and H. Heintzmann", TITLE = "Lorentz-Covariant Eikonal Method in Magnetohydrodynamics {II} - The Determination of the Wave Amplitude", JOURNAL = "Phys. Lett.", YEAR = 1981, VOLUME = {81A}, NUMBER = 9, PAGES = "501-506", MONTH = "February", COMMENT = {Used {REDUCE} for "rather tedious algebra."}} @ARTICLE{Schruefer:82, AUTHOR = "E. Schr{\"u}fer", TITLE = "An Implementation of the Exterior Calculus in {REDUCE:} A Status Report", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "27-31", MONTH = "November"} @ARTICLE{Schruefer:87, AUTHOR = "E. Schr{\"u}fer and F. W. Hehl and J. D. McCrea", TITLE = "Exterior Calculus on the Computer: The {REDUCE}-Package {EXCALC} Applied to General Relativity and to the {Poincar{\'e}} Gauge Theory", JOURNAL = "General Relativity and Gravitation", YEAR = 1987, VOLUME = 19, NUMBER = 2, PAGES = "197-218", MONTH = "February", COMMENT = {Application of {EXCALC/REDUCE}, including review of other systems, and description of {EXCALC}.}} @ARTICLE{Schruefer:88, AUTHOR = "E. Schr{\"u}fer", TITLE = "A Note on {Einstein} Metrics", JOURNAL = "SIGSAM Bulletin", YEAR = 1988, VOLUME = 22, NUMBER = 3, PAGES = "22-26", MONTH = "July"} @ARTICLE{Schwarz:80, AUTHOR = "F. Schwarz", TITLE = "An Approximation Scheme for Constructing $\pi_{0}\pi$ Amplitudes from {ACU} Requirements", JOURNAL = "Fortschritte der Physik", YEAR = 1980, VOLUME = 28, PAGES = "201-235", COMMENT = {"To derive the equations expressing the threshold and the asymptotic behaviour one relies heavily on the programming system {REDUCE}."}} @ARTICLE{Schwarz:82, AUTHOR = "F. Schwarz", TITLE = "Symmetries of the Two Dimensional {Korteweg-De Vries} Equation", JOURNAL = "J. Phys. S. Japan", YEAR = 1982, VOLUME = 51, NUMBER = 8, PAGES = "2387-2388", COMMENT = {{REDUCE} used in the {SPDE} package.}} @ARTICLE{Schwarz:82a, AUTHOR = "F. Schwarz", TITLE = "A {REDUCE} Package for Determining {Lie} Symmetries of Ordinary and Partial Differential Equations", JOURNAL = "Computer Physics Communications", YEAR = 1982, VOLUME = 27, PAGES = "179-186", COMMENT = {Preliminary description of {REDUCE} packages {SODE} and {SPDE}.}} @ARTICLE{Schwarz:83, AUTHOR = "Fritz Schwarz", TITLE = "A {REDUCE} Package for Series Analysis by {Hadamard's} Theorem and {QD} Schemes", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "38-44", MONTH = "February"} @INPROCEEDINGS{Schwarz:83a, AUTHOR = "Fritz Schwarz", TITLE = "Automatically Determining Symmetries of Ordinary Differential Equations", BOOKTITLE = "Proc. {EUROCAL} 1983, Lecture Notes in Computer Science", YEAR = 1983, VOLUME = 162, PAGES = "45-54", PUBLISHER = "Springer-Verlag"} @ARTICLE{Schwarz:84, AUTHOR = "F. Schwarz", TITLE = "The {Riquier-Janet} Theory and Its Application to Nonlinear Evolution Equations", JOURNAL = "Physica", YEAR = 1984, VOLUME = "11D", PAGES = "243-251", COMMENT = {Prologation methods in {REDUCE}. Points to existence of {REDUCE} system.}} @ARTICLE{Schwarz:84a, AUTHOR = "F. Schwarz and W. H. Steeb", TITLE = "Symmetries and First Integrals for Dissipative Systems", JOURNAL = "J. Phys. {A:} Math. Gen.", YEAR = 1984, VOLUME = 17, PAGES = "L819-L823"} @ARTICLE{Schwarz:85, AUTHOR = "F. Schwarz", TITLE = "Automatically Determining Symmetries of Partial Differential Equations", JOURNAL = "Computing", YEAR = 1985, VOLUME = 34, PAGES = "91-106", COMMENT = {Describes the {SPDE} package for {REDUCE}.}} @ARTICLE{Schwarz:85a, AUTHOR = "Fritz Schwarz", TITLE = "An Algorithm for Determining Polynomial First Integrals of Autonomous Systems of Ordinary Differential Equations", JOURNAL = "J. Symbolic Computation", YEAR = 1985, VOLUME = 1, NUMBER = 2, PAGES = "229-233", MONTH = "June"} @ARTICLE{Schwarz:86, AUTHOR = "F. Schwarz", TITLE = "A {REDUCE} Package for Determining First Integrals of Autonomous Systems of Ordinary Differential Equations", JOURNAL = "Computer Physics Communications", YEAR = 1986, VOLUME = 39, PAGES = "285-296", COMMENT = {Description of package {DISSYS} in {REDUCE}.}} @INPROCEEDINGS{Schwarz:87, AUTHOR = "F. Schwarz", TITLE = "Symmetries and Involution Systems: Some Experiments in Computer Algebra", YEAR = 1987, MONTH = "August", BOOKTITLE = "Topics in Soliton Theory and Exactly Solvable Nonlinear Equations", PUBLISHER = "World Science Press", ADDRESS = "Singapore", COMMENT = {Description of algorithm {INVSYS} and applications.}} @ARTICLE{Schwarz:88, AUTHOR = "F. Schwarz", TITLE = "Symmetries of Differential Equations: From {Sophus Lie} to Computer Algebra", JOURNAL = "Siam Review", YEAR = 1988, VOLUME = 30, PAGES = "450-481", COMMENT = {Review article on applying the {REDUCE} package {SPDE}.}} @ARTICLE{Seiler:91, AUTHOR = "Werner M. Seiler", TITLE = "{SUPERCALC-} a {REDUCE} package for commutator calculations", JOURNAL = "Computer Physics Communications", YEAR = 1991, VOLUME = 66, PAGES = "363-376", COMMENT = {A {REDUCE} package for commutator calculations in sypersymmetric theories (including ordered products) and for infinite sums is presented and an application to the computation of anomalies in string theory is given.}} @INPROCEEDINGS{Shablygin:87, AUTHOR = "E. Shablygin", TITLE = "Integral Equation with Hidden Eigenparameter Solver: {REDUCE} and {FORTRAN} in Tandem", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "186-191", PUBLISHER = "Springer-Verlag"} @ARTICLE{Shmueli:83, AUTHOR = "U. Shmueli and A. J. C. Wilson", TITLE = "Generalized Intensity Studies: The Subcentric Distribution and Effects of Dispersion", JOURNAL = "Acta Cryst.", YEAR = 1983, VOLUME = "A39", PAGES = "225-233", COMMENT = {Uses {REDUCE} for series expansion to high order as convergence is slow.}} @ARTICLE{Shmueli:83a, AUTHOR = "U. Shmueli and U. Kaldor", TITLE = "Moments of the Trigonometric Structure Factor", JOURNAL = "Acta Cryst.", YEAR = 1983, VOLUME = "A39", PAGES = "615-621", COMMENT = {Eight moment of magnitude of trigonometric structure factor. Used {REDUCE}. Description of {REDUCE} in appendix.}} @TECHREPORT{Shtokhamer:75, AUTHOR = "R. Shtokhamer", TITLE = "Canonical Form of Polynomials in the Presence of Side Relations", INSTITUTION = "Technion", YEAR = 1975, NUMBER = "Technion-PH-76-25"} @TECHREPORT{Shtokhamer:77, AUTHOR = "R. Shtokhamer", TITLE = "The Use of {``LET''} Statements in Producing Short Comprehended Outputs", INSTITUTION = "Department of Physics, Technion-Israel Institute of Technology, Haifa, Israel", YEAR = 1977, NUMBER = "Technion-PH-77-36", ABSTRACT = {It is shown that an algebraic implementation of {"LET"} statements may be useful in producing comprehended outputs. The suggested algorithm is based on solving large set of linear equations over a field.}} @INPROCEEDINGS{Smit:79, AUTHOR = "J. Smit", TITLE = "New Recursive Minor Expansion Algorithms, A Presentation in a Comparative Context", BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "74-87", PUBLISHER = "Springer-Verlag"} @ARTICLE{Smit:81, AUTHOR = "J. Smit and J. A. van Hulzen and B. J. A. Hulshof", TITLE = "{NETFORM} and Code Optimizer Manual", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1981, VOLUME = 15, NUMBER = 4, PAGES = "23-32", MONTH = "November"} @INPROCEEDINGS{Smit:82, AUTHOR = "J. Smit and J. A. van Hulzen", TITLE = "Symbolic Numeric Methods in Microwave Technology", BOOKTITLE = "Proc. {EUROCAM} 1982, Lecture Notes in Computer Science", YEAR = 1982, VOLUME = 144, PAGES = "281-288", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{Smit:87, AUTHOR = "J. Smit and S. H Gerez and R. Mulder", TITLE = "Application of a Structured {LISP} System to Computer Algebra", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "149-160", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Soderstrand:72, AUTHOR = "M. A. Soderstrand and D. C. Huey", TITLE = "Sensitivities of Fourth-Order Filters Obtained by a Low-Pass to Band-Pass Transformation", INSTITUTION = "University of California, Davis", YEAR = 1972, TYPE = "Report"} @INPROCEEDINGS{Soderstrand:72a, AUTHOR = "M. A. Soderstrand and S. K. Mitra", TITLE = "Computer-aided Sensitivity Analysis of Higher Filters", YEAR = 1972, MONTH = "July", BOOKTITLE = "Proc. Second Symposium on Network Theory, Herzegnovia, Yugoslavia"} @TECHREPORT{Soderstrand:74, AUTHOR = "M. A. Soderstrand and J. F. Lathrop", TITLE = "Two Computer Programs for the Sensitivity Analysis of Higher Order Filters", INSTITUTION = "Sandia Laboratories", YEAR = 1974, TYPE = "Report", NUMBER = "SLL-73-0225", MONTH = "January"} @ARTICLE{Soma:77, AUTHOR = "T. Soma", TITLE = "Relativistic Aberration Formulas for Combined Electric-Magnetic Focusing-Deflection System", JOURNAL = "Optik", YEAR = 1977, VOLUME = 49, PAGES = "255-262", COMMENT = {Existence of a vertical landing electron beam deflecting system free of all deflection induced aberrations is presented analytically.}} @INPROCEEDINGS{Soma:85, AUTHOR = "Takashi Soma", TITLE = "Recent Applications of {REDUCE} in {RIKEN}", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "181-182"} @INPROCEEDINGS{Spiridonova:87, AUTHOR = "M. Spiridonova", TITLE = "Some extensions and Applications of {REDUCE} System", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "136-137", PUBLISHER = "Springer-Verlag"} @TECHREPORT{Squire, AUTHOR = "W. Squire", TITLE = "Some Applications of Symbolic Matrix Inversion", INSTITUTION = "Dept. of Mechanical and Aerospace Engineering, West Virginia University"} @ARTICLE{Steinberg:82, AUTHOR = "Stanly Steinberg", TITLE = "Mathematics and Symbol Manipulation", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 3, PAGES = "11-15", MONTH = "August"} @ARTICLE{Steuerwald, AUTHOR = "J. Steuerwald and W. Kerner", TITLE = "A Contribution to the Efficient Solution of Extensive Symbolic Computations", JOURNAL = "Comp. Phys. Comm."} @ARTICLE{Stoutemyer:74, AUTHOR = "D. Stoutemyer", TITLE = "Automatic Error Analysis Using the Computer Symbolic Manipulation Language", JOURNAL = "TOMS 3", YEAR = 1977, VOLUME = 3, NUMBER = 1, PAGES = "26-43", MONTH = "March", ABSTRACT = {This paper shows how the inherent error and the fixed-point or floating-point roundoff of chopoff error of an expression can be determined automatically using a computer algebra language such as {REDUCE}.}} @TECHREPORT{Stoutemyer:75, AUTHOR = "David R. Stoutemyer", TITLE = "Symbolic Computer Solution of an Equation in Finite Terms", INSTITUTION = "Dept. of Comp. Science, Univ. of Utah", TYPE = "Report", YEAR = 1975, NUMBER = "UCP-33", ABSTRACT = {This report contains a program listing together with documentation, a demonstration, and discussion of a {REDUCE} program for the exact solution of an equation in finite terms. Capable of treating certain equations involving elementary transcendental functions, radicals, and polynomials, the program incorporates several solution techniques not implemented in existing analogous programs written in other computer algebra languages. The program is also capable of solving linear or linear fractional in the unknowns. In this case it simply used the built-in matrix equation solver, but permitting input as lists of expressions rather than matrices, which is convenient for sparse or small linear systems.}} @ARTICLE{Stoutemyer:77, AUTHOR = "David R. Stoutemyer", TITLE = "Analytically Solving Integral Equations by Using Computer Algebra", JOURNAL = "TOMS", YEAR = 1977, VOLUME = 3, NUMBER = 2, PAGES = "128-146", MONTH = "June", ABSTRACT = {This report describes how a computer algebra language, such as {REDUCE}, may be used to automatically construct closed-form and series analytical solutions of integral equations.}} @ARTICLE{Stroscio:74, AUTHOR = "M. A. Stroscio and J. M. Holt", TITLE = "Radiative Corrections to the Decay Rate of Orthopositronium", JOURNAL = "Phys. Rev. A", YEAR = 1974, MONTH = "September", VOLUME = 10, PAGES = "749-755"} @ARTICLE{Stuart:88, AUTHOR = "Robin G. Stuart", TITLE = "Algebraic Reduction of one-loop {Feynman} Diagrams to Scalar Integrals", JOURNAL = "Comp. Phys. Commun.", YEAR = 1988, VOLUME = 48, NUMBER = 3, PAGES = "367-389", MONTH = "March"} @ARTICLE{Stuart:90, AUTHOR = "Robin G. Stuart and A. G{\'o}ngora-T", TITLE = "Algebraic Reduction of one-loop {Feynman} Diagrams to Scalar Integrals II", JOURNAL = "Comp. Phys. Commun.", YEAR = 1990, VOLUME = 56, NUMBER = 3, PAGES = "337-350", MONTH = "January"} @ARTICLE{Suppes:89, AUTHOR = "Patrick Suppes and Shuzo Takahashi", TITLE = "An Interactive Calculus Theorem-prover for Continuity Properties", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 7, NUMBER = 6, PAGES = "573-590", MONTH = "June"} @ARTICLE{Surguladze:89, AUTHOR = "L.R. Surguladze and F.V. Tkachov", TITLE = "{LOOPS:} Procedures for Multiloop Calculations in Quantum Field Theory for the {REDUCE} System", JOURNAL = "Comp. Phys. Comm.", YEAR = 1989, VOLUME = 55, NUMBER = 2, PAGES = "205-215", MONTH = "September", PUBLISHER = "North Holland Publishing Company"} @INPROCEEDINGS{Surguladze:91, AUTHOR = "Levan R. Surguladze and Mark A. Samuel", TITLE = "Algebraic Perturbative Calculations in High Energy Physics Methods, algorithms, computer programs and physical applications", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "439-447", ABSTRACT = {The methods and algorithms for high order algebraic perturbative calculations in theoretical high energy physics are briefly reviewed. The {SCHOONSCHIP} program {MINCER} and the {REDUCE} program {LOOPS} for analytical computation of arbitrary massless, one-, two- and three-loop Feynman diagrams of the propagator type are described. The version of the program {LOOPS} for personal computers and the extended version of the program {MINCER} for four-loop renormalization group calculations are presented. The new program for algebraic perturbative calculations is also discussed. This program is written on the new algebraic programming system {FORM}. Some recent results of application to the high energy physics are given.}} @ARTICLE{Tallents:84, AUTHOR = "G. J. Tallents", TITLE = "The Relative Intensities of Hydrogen-Like Fine Structure", JOURNAL = "J. Phys. B", YEAR = 1984, VOLUME = 17, PAGES = "3677-3691", COMMENT = {{REDUCE} used to check a formula; also checked numerically.}} @InProceedings{Tao90, author = "Qingsheng Tao", title = "Symbolic and Algebraic manipulation for Formulae of Interpolation and Quadrature", booktitle = "Proceedings of the 1990 International Symposium on Symbolic and Algebraic Computation", year = "1990", editor = "S. Watanabe and Morio Nagata", pages = "306", organization = "ACM", publisher = "Addison-Wesley" } @TECHREPORT{Tasso:76, AUTHOR = "H. Tasso and J. Steuerwald", TITLE = "Subroutine for Series Solutions of Linear Differential Equations", INSTITUTION = "Max Planck Institut for Plasmaphysik", YEAR = 1976, NUMBER = "IPP 6/143"} @TECHREPORT{Thas:89, AUTHOR = "C. Thas", TITLE = "A collection of {REDUCE} and {MACSYMA} programs about college geometry. Part 1", INSTITUTION = "State University of Gent", YEAR = 1989, NUMBER = 5, MONTH = "September"} @TECHREPORT{Thas:89a, AUTHOR = "C. Thas", TITLE = "A collection of {REDUCE} and {MACSYMA} programs about college geometry. Part 2", INSTITUTION = "State University of Gent", YEAR = 1989, NUMBER = 5, MONTH = "September"} @INPROCEEDINGS{Todd:88, AUTHOR = "P. H. Todd and G. W. Cherry", TITLE = "Symbolic Analysis of Planar Drawings", BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag", YEAR = 1988, VOLUME = 358, PAGES = "344-355"} @ARTICLE{Toth:86, AUTHOR = "{K. T{\'o}th and K. Szeg{\"o} and A. Margaritis}", TITLE = "Radiative Corrections for Semileptonic Decays of {Hyperons: `Model-Independent' Part}", JOURNAL = "Physical Review D", YEAR = 1986, VOLUME = 33, NUMBER = 11, PAGES = "3306-3315", MONTH ="June"} @INPROCEEDINGS{Tournier:79, AUTHOR = "Evelyne Tournier", TITLE = "An Algebraic Form of a Solution of a System of Linear Differential Equations with Constant Coefficients", BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "153-163", PUBLISHER = "Springer-Verlag", ABSTRACT = {In this paper we describe an algorithm for finding an algebraic form for the solution of a system of linear differential equations with constant coefficients, using the properties of elementary divisors of a polynomial matrix.}} @PHDTHESIS{Tournier:87, AUTHOR = "Evelyne Tournier", TITLE = "Solutions Formelles D'Equations Differentielles, le Logiciel de Calcul Formel: {DESIR} Etude Theorique et Realisation", SCHOOL = "L'Universit{\'e} Scientifique, Technologique et Medicale de Grenoble", YEAR = 1987, MONTH = "April"} @INPROCEEDINGS{Trenkov:91, AUTHOR = "I. Trenkov and M. Spiridonova and M. Daskalova", TITLE = "An Application of the {REDUCE} System for Solving a Mathematical Geodesy Problem", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "448-449"} @INPROCEEDINGS{Trotter:89, AUTHOR = "H. F. Trotter", TITLE = "Use of Symbolic Methods in Analyzing an Integral Operator", BOOKTITLE = "Proc. of Computers and Mathematics '89", EDITOR = "E. Kaltofen and S. M. Watt", YEAR = 1989, PAGES = "82-90", PUBLISHER = "Springer-Verlag, New York"} @ARTICLE{Tsai:65, AUTHOR = "Y. S. Tsai and A. C. Hearn", TITLE = "Differential Cross-Section for e+ + e- $\rightarrow$ {W+} + {W-} $\rightarrow$ e- + $\overline{\nu}_{e} + \mu + \nu_{\mu}$", JOURNAL = "Phys. Rev.", YEAR = 1965, VOLUME = 140, PAGES = "B721-B729"} @ARTICLE{Tsai:74, AUTHOR = "Y. S. Tsai", TITLE = "Pair Production and Bremsstrahlung of Charged Leptons", JOURNAL = "Rev. Mod. Phys.", YEAR = 1974, VOLUME = 46, PAGES = "815-851"} @ARTICLE{Ucoluk:82, AUTHOR = "{G. \"{U}\c{c}oluk} and A. Hacinliyan", TITLE = "A Proposal for Extensions to {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 2, PAGES = "4-14", MONTH = "May", ABSTRACT = {Three classes of extensions are proposed for {REDUCE}: A facility for evaluating arbitrary functions of matrices; a facility for grouping, modifying or restoring the status of various flags in {REDUCE}; further extensions and modifications for separating terms, coefficients of expressions, concatenation, and non- commuting algebra.}} @ARTICLE{Umeno:89, AUTHOR = "Takaji Umeno and Syuichi Yamashita and Osami Saito and Kenichi Abe", TITLE = "Symbolic Computation Application for the Design of Linear Multivariable Control Systems", JOURNAL = "J. Symbolic Computation", YEAR = 1989, VOLUME = 8, NUMBER = 6, PAGES = "581-588", MONTH = "December"} @INPROCEEDINGS{Urintsev:91, AUTHOR = "A.L. Urintsev and A.V. Samoilov", TITLE = "Complex Reduce-programs for analytic solution of some problems of beam transport systems", YEAR = 1991, BOOKTITLE = "In: 4th International Conference on Computer Algebra in Physical Research", EDITOR = "D.V. Shirkov and V.A. Rostovtsev and V.P. Gerdt", PUBLISHER = "World Scientific", ADDRESS = "Singapore, New Jersey, London, Hong Kong", PAGES = "438-442"} @ARTICLE{vandenHeuvel:86, AUTHOR = "Pim van den Heuvel", TITLE = "Adding Statements to {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1986, VOLUME = 20, NUMBER = "1 and 2", PAGES = "8-14", MONTH = "February and May"} @TECHREPORT{vandenHeuvel:86a, AUTHOR = "Pim van den Heuvel", TITLE = "Some Experiments in {REDUCE} Related to the Calculation of {Groebner} Bases", INSTITUTION = "Department of Computer Science, Twente University of Technology, The Netherlands", YEAR = 1986, MONTH = "June"} @INPROCEEDINGS{vandenHeuvel:87, AUTHOR = "P. van den Heuvel and J. A. van Hulzen and V. V. Goldman", TITLE = "Automatic Generation of {FORTRAN}-Coded {Jacobians} and {Hessians}", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "120-131", PUBLISHER = "Springer-Verlag"} @ARTICLE{vandenHeuvel:87a, AUTHOR = "P. van den Heuvel and B. J. A. Hulshof and J. A. van Hulzen", TITLE = "Some Simple Pretty-Print Facilities for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1987, VOLUME = 21, NUMBER = 1, PAGES = "14-17", MONTH = "February"} @TECHREPORT{vanHeerwaarden, AUTHOR = "M. C. van Heerwaarden and J. A. van Hulzen", TITLE = "Pretty Print Facilities for {REDUCE}", INSTITUTION = "Department of Computer Science, University of Twente, The Netherlands", YEAR = 1988, TYPE = "Memorandum", NUMBER = "INF-88-36", MONTH = "August"} @ARTICLE{vanHulzen:80, AUTHOR = "J. A. van Hulzen", TITLE = "Computational Problems in Producing {Taylor} Coefficients for the Rotating Disk Problem", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1980, VOLUME = 14, NUMBER = 2, PAGES = "36-49", MONTH = "May"} @TECHREPORT{vanHulzen:81, AUTHOR = "J. A. van Hulzen", TITLE = "Breuer's Grow Factor Algorithm in Computer Algebra", INSTITUTION = "Department of Applied Mathematics, Twente University of Technology, The Netherlands", YEAR = 1981, TYPE = "Memorandum", NUMBER = 332, MONTH = "April", COMMENT = {A shorter version appears in: Proceedings SYMSAC 81 (Paul S. Wang, ed.) ACM, August 1981.}} @ARTICLE{vanHulzen:82, AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof", TITLE = "An Expression Analysis Package for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "32-44", MONTH = "November"} @INPROCEEDINGS{vanHulzen:82a, AUTHOR = "J. A. van Hulzen", TITLE = "Computer Algebra Systems Viewed by a Notorious User", BOOKTITLE = "Proc. {EUROCAM} 1982, Lecture Notes in Computer Science", YEAR = 1982, VOLUME = 144, PAGES = "166-180"} @INCOLLECTION{vanHulzen:83, AUTHOR = "J. A. van Hulzen and J. Calmet", TITLE = "Computer Algebra Systems", EDITOR = "B. Buchberger and G. E. Collins and R. Loos and R. Albrecht", BOOKTITLE = "Computer Algebra and Symbolic and Algebraic Computation", EDITION = "2nd", PUBLISHER = "Springer-Verlag", YEAR = 1983} @INPROCEEDINGS{vanHulzen:83a, AUTHOR = "J. A. van Hulzen", TITLE = "Code Optimization of Multivariate Polynomial Schemes: A Pragmatic Approach", BOOKTITLE = "Proc. {EUROCAL} 1983, Lecture Notes in Computer Science", YEAR = 1983, VOLUME = 162, PAGES = "286-300", PUBLISHER = "Springer-Verlag"} @INPROCEEDINGS{vanHulzen:87, AUTHOR = "J. A. van Hulzen", TITLE = "Program Generation Aspects of the Symbolic-Numeric Interface", BOOKTITLE = "Proc. Third Intern. Conf. on Computer Algebra and its applications in Theor. Phys, 1985", YEAR = 1987, PAGES = "104-113", PUBLISHER = "{J.I.N.R., Dubna, USSR}"} @TECHREPORT{vanHulzen:88, AUTHOR = "J. A. van Hulzen", TITLE = "Formule Manipulatie m.b.v. {REDUCE} (in {Dutch})", INSTITUTION = "Department of Computer Science, Twente University of Technology, The Netherlands", YEAR = 1988, MONTH = "October"} @INPROCEEDINGS{vanHulzen:89, AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof and B. L. Gates and M. C. Van Heerwaarden", TITLE = "A Code Optimization Package for {REDUCE}", BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York", YEAR = 1989, PAGES = "163-170", COMMENT = {Lecture Notes.}} @TECHREPORT{vanHulzen:89a, AUTHOR = "J. A. van Hulzen", TITLE = "Computer Algebra and Numerical Mathematics: The Odd Couple?", INSTITUTION = "Department of Computer Science, Twente University of Technology, The Netherlands", NUMBER = "Informatica 89-40", YEAR = 1989, MONTH = "June"} @TECHREPORT{VanProeyan:76, AUTHOR = "A. Van Proeyen", TITLE = "Quantum Gravity Corrections on the Anomalous Magnetic and Quadrupole Moments of a Spin-1 Particle", INSTITUTION = "Instituut voor Theor. Fys., Leuven", YEAR = 1976, MONTH = "October"} @TECHREPORT{VanProeyan:79, AUTHOR = "A. Van Proeyan", TITLE = "Gravitational Divergences of the Electromagnetic Interactions of Massive Vectorparticles", INSTITUTION = "Universiteit Leuven", YEAR = 1979, TYPE = "Preprint", NUMBER = "KUL-TF-79/032", MONTH = "October", ABSTRACT = {In a search for the explanation of the finite quantum gravity corrections to anomalous moments we examined a spontaneous broken 0(3) model with Yang-Mills particles and Higgs scalars coupled to gravitons.}} @INPROCEEDINGS{Vega:91, AUTHOR = "Laureano Gonz{\'a}lez Vega", TITLE = "Working with Real Algebraic Plane Curves in {REDUCE:} the {GCUR} package", YEAR = 1991, MONTH = "July", BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and Algebraic Computation", EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "397-402"} @TECHREPORT{Vinitsky:87, AUTHOR = "S. I. Vinitsky and V. A. Rostovtsev", TITLE = "A Use of {REDUCE} System in Problems of Hydrogen Atom in an Electric Field", INSTITUTION = "J.I.N.R., Dubna", TYPE = "Preprint", YEAR = 1987, NUMBER = "P11-87-303"} @ARTICLE{Voros:77, AUTHOR = "A. Voros", TITLE = "Asymptotic K-Expansions of Stationary Quantum States", JOURNAL = "Ann. Inst. H. Poincare", YEAR = 1977, VOLUME = "26A", PAGE = "343"} @TECHREPORT{Wanas, AUTHOR = "M. I. Wanas", TITLE = "The Third Face of Computer -- Computer Solution of Symbolic Problems", INSTITUTION = "Military Technical College, Cairo, Egypt", NUMBER = "CAP-3 837"} @INPROCEEDINGS{Wanas:85, AUTHOR = "M. I. Wanas", TITLE = "Manipulation of Parameters Indicating the Physical Significance of any Absolute Parallelism Space Using {REDUCE} 2", YEAR = 1985, BOOKTITLE = "Tenth International Congress for Statistics, Computer Science, Social and Demographic Research"} @INPROCEEDINGS{Wang:84, AUTHOR = "Paul S. Wang and T. Y. P. Chang and J. A. van Hulzen", TITLE = "Code Generation and Optimization for Finite Element Analysis", BOOKTITLE = "Proc. {EUROSAM} 1984, Lecture Notes in Computer Science", YEAR = 1984, VOLUME = 174, PAGES = "237-247", PUBLISHER = "Springer-Verlag"} @ARTICLE{Wassam:87, AUTHOR = "W. A. {Wassam, Jr.} and Go. Torres-Vega", TITLE = "Dual {Lanczos} Transformation Theory: Closed Set of Algebraic Equations Connecting {Lanczos} Parameters with Moments in Moment Expansions of Time-Dependent Quantities", JOURNAL = "Chemical Phys. Lett.", YEAR = 1987, VOLUME = 134, NUMBER = 4, PAGES = "355-360", COMMENT = {"The utility of this set of equations is illustrated by using them with the aid of symbolic manipulation on a computer to construct a previously unknown exact continued fraction for the spectral density of the incoherent scattering function{\ldots}" The system used is {REDUCE} on a Burroughs. Appear enthusiastic about the possibilities for computer algebra in related fields.}} @ARTICLE{Wassam:87a, AUTHOR = "W. A. {Wassam, Jr.} and Go. Torres-Vega and J. Neito-Frausto", TITLE = "Dual {Lanczos} Transformation Theory: Exact Continued Fraction Expression for Resonant $\gamma$-ray Absorption Spectrum of a Harmonically Bound Atom Executing Classical Motion Described by {Smoluchowski} Dynamics", JOURNAL = "Chemical Phys. Lett.", YEAR = 1987, VOLUME = 136, NUMBER = 1, PAGES = "26-30", COMMENT = {"{\ldots}with the aid of symbolic manipulation techniques, we construct a previously unknown exact continued fraction for the resonance $\gamma$-ray absorption spectrum{\dots}" The system used is {REDUCE} on a Burroughs.}} @TECHREPORT{Watanabe:85, AUTHOR = "Yoichi Watanabe", TITLE = "Symbolic Manipulation of Structure Functions in Availability Analysis", INSTITUTION = "Fusion Technology Institute, University of Wisconsin, Madison, Wisconsin", YEAR = 1985, NUMBER = "UWFDM-658", MONTH = "November"} @ARTICLE{Watanabe:76, AUTHOR = "Shunro Watanabe", TITLE = "Formula Manipulations Solving Linear Ordinary Differential Equations {II}", JOURNAL = "Publications of the Research Institute for Mathematical Sciences, Kyoto University", YEAR = 1976, VOLUME = 11, NUMBER = 2, PAGES = "297-337"} @ARTICLE{Watanabe:79, AUTHOR = "Shunro Watanabe", TITLE = "A Verification for Non-existence of Movable Branch Points of Six Painlev{\'e} Transcendents by Formula Manipulations", JOURNAL = "Tokyo Journal of Mathematics", YEAR = 1979, VOLUME = 2, NUMBER = 2, PAGES = "285-291"} @ARTICLE{Weber:79, AUTHOR = "Lawrence A. Weber and Gerhard Rayna", TITLE = "Problem \#11 Solved in {REDUCE:} A Case Study in Program Translation", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1979, VOLUME = 13, NUMBER = 4, PAGES = "21-24", MONTH = "November"} @ARTICLE{Wehner:86, AUTHOR = "M. F. Wehner and W. G. Wolfer", TITLE = "The Pressure of a Hard Sphere Fluid on a Curved Surface", JOURNAL = "J. Statistical Phys.", YEAR = 1986, VOLUME = 42, PAGES = "509-521", COMMENT = {Integral equation approach and perturbation expansions in {REDUCE}. "Therefore, in order to avoid errors, the integrations have been done in closed form with the algebraic manipulation routine {REDUCE}."}} @INCOLLECTION{Winkelmann:89, AUTHOR = "Volker Winkelmann and Friedrich W. Hehl", TITLE = "{REDUCE} for Beginners. Six Lectures on the Application of Computer Algebra", EDITOR = "D. Stauffer and F. W. Hehl and V. Winkelmann and J. G. Zabolitzky", BOOKTITLE = "Computer Simulation and Computer Algebra. Lectures for Beginners", CHAPTER = 3, EDITION = "2nd", PUBLISHER = "Springer-Verlag", YEAR= 1989} @TECHREPORT{Winkler:88, AUTHOR = "F. Winkler and B. Kutzler and F. Lichtenberger", TITLE = "Computeralgebrasysteme (in {German})", INSTITUTION = "RISC - LINZ, Austria", TYPE = "Report", YEAR = 1988, NUMBER = "88-10"} @ARTICLE {Witham:77, AUTHOR = "C. R. Witham and S. Dubowsky", TITLE = "An Improved Symbolic Manipulation Technique for the Simulation of Nonlinear Dynamic Systems With Mixed Time-Varying and Constant Terms", JOURNAL = "Journal of Dynamic Systems, Measurement, and Control", YEAR = 1977, MONTH = "September", PAGES = "157-165", ABSTRACT = {The time domain behavior of nonlinear dynamic systems often is obtained by numerical integration on the digital computer. These solutions are usually expensive and limit the scope of the dynamic study. The proposed improved technique results in a substantial increase in the computational efficiency by using automatic symbolic manipulation to generate explicit equations of motion algebraically prior to numerical integration.}} @ARTICLE{Wood:89, AUTHOR = "John C. Wood", TITLE = "Harmonic Two Spheres in the Unitary Group", YEAR = 1989, JOURNAL = "Proc. London Math. Soc.", VOLUME = 3, NUMBER = 58, PAGES = "608-624"} @TECHREPORT{Wright:84, AUTHOR = "F. J. Wright and G. Dangelmayr", TITLE = "Explicit Iterative Algorithms to Reduce a Univariate Catastrophe to Normal Form", INSTITUTION = "Universit{\"a}t T{\"u}bingen", YEAR = 1984} @TECHREPORT{Wulkow:90, AUTHOR = "Michael Wulkow and Peter Deuflhard", TITLE = "Towards an efficient computational treatment of heterogeneous polymer reactions", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1990, TYPE = "Preprint", NUMBER = "SC 90-1", MONTH = "January"} @INPROCEEDINGS{Yamamoto:87, AUTHOR = "T. Yamamoto and Y. Aoki", TITLE = "{REDUCE} 3.2 on {iAPX 86/286}-based Personal Computers", BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "134-135", PUBLISHER = "Springer-Verlag"} @ARTICLE{Yamartino:91, AUTHOR = "Robert J. Yamartino and Richard Pavelle", TITLE = "An Application of Computer Algebra to a Problem in Stratified Fluid Flow", JOURNAL = "J. Symb. Comp.", YEAR = 1991, VOLUME = 12, NUMBER = 6, PAGES = "669-672", MONTH = "December"} ABSTRACT = {The computationally tedious problem of considering trial Green's function solutions to the fourth-order partial differential equation for a stratified atmosphere flowing over a hill is approached using MACSYMA. Significance of the problem, solution methodologies and CPU time intercomparisons using various computer platforms and other algebra systems are discussed.}} @ARTICLE{Yannouleas:88, AUTHOR = "C. Yannouleas and J. M. Pacheco", TITLE = "An Algebraic Program for the States Associated with the ${U(5)} \supset {O(5)} \supset {O(3)}$ Chain of Groups", JOURNAL = "Comp. Phys. Comm.", YEAR = 1988, VOLUME = 52, NUMBER = 1, PAGES = "85-92", MONTH = "December"} @ARTICLE{Yannouleas:89, AUTHOR = "C. Yannouleas and J. M. Pacheco", TITLE = "Algebraic Manipulation of the States Associated with the ${U(5)} \supset {O(5)} \supset {O(3)}$ Chain of {groups:} Orthonormalization and Matrix Elements", JOURNAL = "Comp. Phys. Comm.", YEAR = 1989, VOLUME = 54, NUMBER = "2 and 3", PAGES = "315-328", MONTH = "June and July"} @ARTICLE{Zacrep:75, AUTHOR = "Douglas Zacrep and Bing-Lin Young", TITLE = "Trace and {Ward-Takahashi} Identity Anomalies in an {SU}(3) Current Model with Energy-Momentum Tensor", JOURNAL = "Phys. Rev. D", YEAR = 1975, VOLUME = 12, PAGES = "513-522"} @ARTICLE{Zahalak:87, AUTHOR = "G. I. Zahalak and P. R. Rao and S. P. Sutera", TITLE = "Large Deformations of a Cylindrical Liquid-Filled Membrane by a Viscous Shear Flow", JOURNAL = "J. Fluid Mech.", YEAR = 1987, VOLUME = 179, PAGES = "283-305", COMMENT = {Draws attention to the use of classical perturbation techniques combined with computer algebra as an alternative to numerical calculation.}} @ARTICLE{Zeng:84, AUTHOR = "Wan-zhen Zeng and Bail-lin Hao", TITLE = "Scaling Property of Period-n-Tupling Sequences in One-Dimensional Mappings", JOURNAL = "Commun. in Theor. Phys., Beijing, China", YEAR = 1984, VOLUME = 3, NUMBER = 3, PAGES = "283-295"} @TECHREPORT{Zhidkova:78, AUTHOR = "I. E. Zhidkova and I. P. Nedyalkov and V. A. Rostovtsev", TITLE = "On Applicability Limits of the Experimental Method for Investigating Strong Gravitational Fields", INSTITUTION = "J.I.N.R., Dubna", YEAR = 1978, NUMBER = "P2 - 11589", COMMENT = {Mechanical effects of tidal forces on the physical apparatus exploring strong gravitational fields are investigated.}} |
Added r34.1/doc/bibl.tex version [1d0b1a86d2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % The following UNIX script will create a hard copy version of the % REDUCE bibliography from this file and the bibliography files % bibl-*.bib. It creates the files tmp.* in the process. % % # Make REDUCE bibliography % rm tmp.* % cat bibl.tex > tmp.tex % cat bibl*.bib > tmp.bib % bib2tex tmp | sed 1,5d >> tmp.tex % latex tmp % bibtex tmp > tmp.blog % latex tmp % latex tmp % \documentstyle [11pt]{article} \def\thebibliography#1{\section*{}\list {[\arabic{enumi}]}{\settowidth\labelwidth{[#1]}\leftmargin\labelwidth \advance\leftmargin\labelsep \usecounter{enumi}} \def\newblock{\hskip .11em plus .33em minus .07em} \sloppy\clubpenalty4000\widowpenalty4000 \sfcode`\.=1000\relax} \textwidth 6.6in\textheight 9in\columnwidth\textwidth \hoffset-2cm \begin{document} \setcounter{page}{0} \title{REDUCE Bibliography} \author{Anthony C. Hearn\\ RAND \\ Santa Monica CA 90407-2138 \vspace {.5cm} \\ June 1992} \date{} \maketitle \vspace{1cm} This document contains a list of all known references to REDUCE. It no doubt contains errors and omissions. Please report these by regular mail (preferably in BibTeX format) to the REDUCE Secretary, RAND, P.O. Box 2138, Santa Monica CA 90407-2318, or by electronic mail to reduce@rand.org. An electronic copy of the bibliography in BibTeX format is also available from the latter address. \begin{center} \vspace{9.0cm} RAND Publication CP162 (Rev. 6/92) \vspace*{.5cm} \\ Copyright \copyright 1992 RAND. All rights reserved. \end{center} \newpage \voffset-2.5cm \nocite{Abbott:85} \nocite{Abbott:86} \nocite{Abbott:87} \nocite{Abbott:87a} \nocite{Abbott:88} \nocite{Abbott:88a} \nocite{Abbott:89} \nocite{Abbott:89a} \nocite{Abdali:88} \nocite{Abiezzi:83} \nocite{Abramov:91} \nocite{Abramov:91a} \nocite{Adamchik90} \nocite{Adams:83} \nocite{Adkins:83} \nocite{Adkins:83a} \nocite{Adkins:85} \nocite{Aguilera-Navarro:87} \nocite{Akselrod:90} \nocite{Aldins:69} \nocite{Alekseev:86} \nocite{Alekseev:87} \nocite{Alekseev:87a} \nocite{Alfeld:82} \nocite{Amirkhanov:87} \nocite{Amirkhanov:91} \nocite{Antweiler:89} \nocite{Appelquist:70} \nocite{Arbuzov:86} \nocite{Aso:81} \nocite{Atherton:73} \nocite{Aurenche:84} \nocite{Aurenche:84a} \nocite{Autin:89} \nocite{Baekler:84} \nocite{Baekler:84a} \nocite{Baekler:86} \nocite{Baekler:87} \nocite{Baekler:87a} \nocite{Baekler:87b} \nocite{Baekler:88} \nocite{Baekler:88a} \nocite{Baekler:88b} \nocite{Bahrdt:90} \nocite{Baier:81} \nocite{Baier:85} \nocite{Baier:90} \nocite{Bajla:78} \nocite{Balian:78} \nocite{Baker:81} \nocite{Bark:78} \nocite{Barthes-Biesel:73} \nocite{Barton:72} \nocite{Bateman:86} \nocite{Belkov:91} \nocite{Bennett} \nocite{Berends:81} \nocite{Berkovich:89} \nocite{Berkovich:90} \nocite{Berman:63} \nocite{Berndt:91} \nocite{Bessis:85} \nocite{Billoire:78} \nocite{Biro:86} \nocite{Biro:87} \nocite{Birrell:77} \nocite{Biswas:75} \nocite{Bittencourt:90} \nocite{Bocko:92} \nocite{Boege:86} \nocite{Bogdanova:88} \nocite{Bordoni:81} \nocite{Bowyer:87} \nocite{Boyd:78} \nocite{Brackx:87} \nocite{Brackx:87a} \nocite{Brackx:89} \nocite{Bradford:86} \nocite{Bradford:88} \nocite{Bradford90} \nocite{Broadhurst:85} \nocite{Broadhurst:91} \nocite{Broadhurst:91a} \nocite{Brodsky:62} \nocite{Brodsky:67} \nocite{Brodsky:69} \nocite{Brodsky:70} \nocite{Brodsky:71} \nocite{Brodsky:72} \nocite{Brodsky:72a} \nocite{Brodsky:72b} \nocite{Brodsky:73} \nocite{Broughan:82} \nocite{Broughan:91} \nocite{Brown:79} \nocite{Bryan-Jones:87} \nocite{Burnel} \nocite{Calmet:72} \nocite{Calmet:72a} \nocite{Calmet:74} \nocite{Calmet:83} \nocite{Campbell:67} \nocite{Campbell:68} \nocite{Campbell:70} \nocite{Campbell:70a} \nocite{Campbell:74} \nocite{Campbell:87} \nocite{Caprasse:84} \nocite{Caprasse:85} \nocite{Caprasse:86} \nocite{Caprasse:86a} \nocite{Caprasse:88} \nocite{Caprasse:89a} \nocite{Caprasse:90} \nocite{Caprasse:91} \nocite{Carlson:80} \nocite{Carroll:73} \nocite{Carroll:75} \nocite{Cejchan} \nocite{Chaffy:88} \nocite{Chinnick:86} \nocite{Cline:90} \nocite{Cohen:76} \nocite{Cohen:76a} \nocite{Cohen:77} \nocite{Cohen:79} \nocite{Cohen:84} \nocite{Cohen:89} \nocite{Connor:84} \nocite{Connor:84a} \nocite{Conwell:84} \nocite{Cowan:79} \nocite{Cung:75} \nocite{Darbaidze:86} \nocite{Darbaidze:86a} \nocite{Darbaidze:88} \nocite{Darbaidze:89} \nocite{Dautcourt:79} \nocite{Dautcourt:80} \nocite{Dautcourt:81} \nocite{Dautcourt:83} \nocite{Davenport:81} \nocite{Davenport:82} \nocite{Davenport:82a} \nocite{Davenport:85} \nocite{Davenport:88} \nocite{Davenport:88a} \nocite{Della-Dora:81} \nocite{Della-Dora:84} \nocite{Della-Dora:85} \nocite{Demaret:89} \nocite{DeMenna:87} \nocite{Demichev:85} \nocite{Demichev:86} \nocite{deRop:88} \nocite{DeVos:89} \nocite{Dewar:89} \nocite{Dhar:85} \nocite{Dicrescenzo:85} \nocite{Diver} \nocite{Diver:86} \nocite{Diver:88} \nocite{Diver:88a} \nocite{Diver:91} \nocite{Dorfi:85} \nocite{Dorizzi:86} \nocite{dosSantos:85} \nocite{dosSantos:87} \nocite{dosSantos:87a} \nocite{dosSantos:88a} \nocite{dosSantos:90} \nocite{Drska:90} \nocite{Dubowsky:75} \nocite{Dudley:89} \nocite{Dufner:69} \nocite{Dulyan:87} \nocite{Duncan:86} \nocite{Duval:87} \nocite{Earles:70} \nocite{Eastwood:87} \nocite{Eastwood:87a} \nocite{Eastwood:91} \nocite{Edelen:81} \nocite{Edelen:82} \nocite{Edneral:89} \nocite{Eisenberger:90} \nocite{Eissfeller:86} \nocite{Eitelbach:73} \nocite{Eleuterio:82} \nocite{Eliseev:85} \nocite{Elishakoff:87} \nocite{Elishakoff:87a} \nocite{Esteban:90} \nocite{Falck:89} \nocite{Fazio:84} \nocite{Fedorova:87} \nocite{Fedorova:87a} \nocite{Feldmar:86} \nocite{Feuillebois:84} \nocite{Fitch:73} \nocite{Fitch:81} \nocite{Fitch:83} \nocite{Fitch:85} \nocite{Fitch:85a} \nocite{Fitch:87} \nocite{Fitch:87a} \nocite{Fitch:89} \nocite{Fitch:89a} \nocite{Fitch90} \nocite{Fitch:90a} \nocite{Flatau:86} \nocite{Flath:86} \nocite{Fleischer:71} \nocite{Fleischer:73} \nocite{Fleischer:75} \nocite{Fogelholm:82} \nocite{Foster:89} \nocite{Fox:71} \nocite{Fox:74} \nocite{Franceschetti:85} \nocite{Freire:88} \nocite{Freire:89} \nocite{Frick:82} \nocite{Fujimoto:84} \nocite{Fuzio:85} \nocite{Gaemers} \nocite{Gaemers:78} \nocite{Ganzha:89} \nocite{Ganzha90} \nocite{Ganzha90a} \nocite{Ganzha:91} \nocite{Garavaglia} \nocite{Garavaglia:80} \nocite{Garavaglia:84} \nocite{Garcia:86} \nocite{Garrad:86} \nocite{Gastmans:79} \nocite{Gatermann:90} \nocite{Gatermann90a} \nocite{Gatermann:91} \nocite{Gatermann:91a} \nocite{Gatermann:91b} \nocite{Gates:85} \nocite{Gates:85a} \nocite{Gates:85b} \nocite{Gates:85c} \nocite{Gates:86} \nocite{Gebauer:85} \nocite{Gebauer:88} \nocite{George:68} \nocite{Gerdt:80} \nocite{Gerdt:80a} \nocite{Gerdt:80b} \nocite{Gerdt:85} \nocite{Gerdt:85a} \nocite{Gerdt:85b} \nocite{Gerdt:85c} \nocite{Gerdt:86} \nocite{Gerdt:87} \nocite{Gerdt:87a} \nocite{Gerdt:89} \nocite{Gerdt:89a} \nocite{Gerdt:89b} \nocite{Gerdt90} \nocite{Gerdt90a} \nocite{Gerdt:90b} \nocite{Gerdt:90c} \nocite{Gerdt:91} \nocite{Gerdt:91a} \nocite{Gerdt:91b} \nocite{Gervois:74} \nocite{Gladd:82} \nocite{Gladkih:83} \nocite{Gladkih:84} \nocite{Goldman:89} \nocite{Golley} \nocite{Good:75} \nocite{Goto:77} \nocite{Goto:78} \nocite{Gould:84} \nocite{Gragert:81} \nocite{Grammaticos} \nocite{Grammaticos:78} \nocite{Grammaticos:85} \nocite{Greenland:84} \nocite{Grimm} \nocite{Griss:74} \nocite{Griss:74a} \nocite{Griss:75} \nocite{Griss:76} \nocite{Griss:76a} \nocite{Griss:77} \nocite{Griss:77a} \nocite{Griss:78} \nocite{Griss:78a} \nocite{Griss:79} \nocite{Griss:79a} \nocite{Grozin:83} \nocite{Grozin:88} \nocite{Grozin:88a} \nocite{Grozin:88b} \nocite{Grozin:90} \nocite{Grozin:90a} \nocite{Grozin:90b} \nocite{Grozin:91} \nocite{Grozin:91a} \nocite{Gunion:72} \nocite{Gunion:73} \nocite{Gunion:85} \nocite{Hadinger:87} \nocite{Handy:87} \nocite{Harper:87} \nocite{Harper:89} \nocite{Harper:89a} \nocite{Harrington:77} \nocite{Harrington:77a} \nocite{Harrington:79} \nocite{Harrington:79a} \nocite{Hartley:91} \nocite{Hasenfratz:80} \nocite{Hearn:68} \nocite{Hearn:69} \nocite{Hearn:69a} \nocite{Hearn:71} \nocite{Hearn:71a} \nocite{Hearn:71b} \nocite{Hearn:71c} \nocite{Hearn:72} \nocite{Hearn:72a} \nocite{Hearn:72b} \nocite{Hearn:73} \nocite{Hearn:73a} \nocite{Hearn:74} \nocite{Hearn:74a} \nocite{Hearn:76} \nocite{Hearn:76a} \nocite{Hearn:76b} \nocite{Hearn:77} \nocite{Hearn:78} \nocite{Hearn:79} \nocite{Hearn:79a} \nocite{Hearn:80} \nocite{Hearn:81} \nocite{Hearn:81a} \nocite{Hearn:82} \nocite{Hearn:82a} \nocite{Hearn:85} \nocite{Hearn:86} \nocite{Hearn:91} \nocite{Hermann:83} \nocite{Hess:84} \nocite{Hettich:77} \nocite{Hietarinta:83} \nocite{Hietarinta:83a} \nocite{Hietarinta:84} \nocite{Hietarinta:84a} \nocite{Hietarinta:84b} \nocite{Hietarinta:85} \nocite{Hietarinta:87} \nocite{Hietarinta:87a} \nocite{Hietarinta:87b} \nocite{Hietarinta:87c} \nocite{Hietarinta:88} \nocite{Hietarinta:89} \nocite{Hietarinta:91} \nocite{Hietarinta:92} \nocite{Hietarinta:92a} \nocite{Hirota:89} \nocite{Horowitz:75} \nocite{Horwitz:83} \nocite{Hughes:90} \nocite{Hulshof:84} \nocite{Hulshof:85} \nocite{Hulshof:81} \nocite{Hulshof:83} \nocite{Husberg:81} \nocite{Idesawa:77} \nocite{Ilyin:87} \nocite{Ilyin:89} \nocite{Ilyin:91} \nocite{Ilyin:91a} \nocite{Inada:80} \nocite{Ioakimidis:90} \nocite{Ioakimidis:90a} \nocite{Ito:85} \nocite{Ito:85a} \nocite{Ito:88} \nocite{Ito:90} \nocite{Ito:90a} \nocite{Jansen:86} \nocite{Janssen:87} \nocite{Jeffrey:84} \nocite{Kadlecsik:88} \nocite{Kadlecsik:92} \nocite{Kagan:85} \nocite{Kagan:88} \nocite{Kahn:69} \nocite{Kamal:81} \nocite{Kamel:69} \nocite{Kamel:69a} \nocite{Kamel:78} \nocite{Kanada:81} \nocite{Kanada:75} \nocite{Kaneko:89} \nocite{Kaps:85} \nocite{Karr:85} \nocite{Katsura:85} \nocite{Kauffman:73} \nocite{Kazasov:87} \nocite{Keady:85} \nocite{Keener:83} \nocite{Keener:85} \nocite{Keener:89} \nocite{Keener:90} \nocite{Kendall:88} \nocite{Kendall:89} \nocite{Kendall:89a} \nocite{Kendall:90} \nocite{Kendall:91} \nocite{Kendall:91a} \nocite{Kerner:75} \nocite{Kersten:83} \nocite{Kersten:84} \nocite{Kersten:86} \nocite{Kersten:86a} \nocite{Kersten:86b} \nocite{Killalea:80} \nocite{Kinoshita:72} \nocite{Kinoshita:73} \nocite{Kitatani:86} \nocite{Kobayashi:84} \nocite{Kobayashi:88} \nocite{Kodaira:85} \nocite{Koh:82} \nocite{Koelbig:81} \nocite{Koelbig:81b} \nocite{Koelbig:82} \nocite{Koelbig:82a} \nocite{Koelbig:83} \nocite{Koelbig:83a} \nocite{Koelbig:84} \nocite{Koelbig:84a} \nocite{Koelbig:84b} \nocite{Koelbig:85} \nocite{Koelbig:85a} \nocite{Koelbig:86} \nocite{Kolar:90} \nocite{Kornyak:87} \nocite{Kotorynski:86} \nocite{Krack:82} \nocite{Kraus:73} \nocite{Kredel:88} \nocite{Kruse:83} \nocite{Kryukov} \nocite{Kryukov:84} \nocite{Kryukov:85} \nocite{Kryukov:85a} \nocite{Kryukov:87} \nocite{Kryukov:87a} \nocite{Kryukov:88} \nocite{Kryukov:88a} \nocite{Kryukov:88b} \nocite{Kryukov:91} \nocite{Kuppers:71} \nocite{Lambin:84} \nocite{Lang:79} \nocite{Laursen:79} \nocite{Laursen:80} \nocite{Laursen:81} \nocite{Lecourtier:85} \nocite{Lee:85} \nocite{Leler:85} \nocite{Lepage:83} \nocite{Levi:70} \nocite{Levi:71} \nocite{Liebermann:75} \nocite{Liska:84} \nocite{Liska:87} \nocite{Liska90} \nocite{Liska:91} \nocite{Lloyd:90} \nocite{Loe:85} \nocite{London:74} \nocite{Loos:72} \nocite{Lottati} \nocite{Louw:86} \nocite{Luegger:73} \nocite{Luegger:91} \nocite{Lukacs} \nocite{Lukaszuk:87} \nocite{Lux:75} \nocite{MacCallum:86} \nocite{MacCallum:86a} \nocite{MacCallum:87} \nocite{MacCallum:88} \nocite{MacCallum:89} \nocite{MacCallum:91} \nocite{Mack:73} \nocite{Mack:73a} \nocite{Maclaren:89} \nocite{Maguire:81} \nocite{Malm:82} \nocite{Marti:78} \nocite{Marti:79} \nocite{Marti:80} \nocite{Marti:83} \nocite{Marti:85} \nocite{Marti:85a} \nocite{Marti:88} \nocite{Marzinkewitsch:91} \nocite{Matveev:87} \nocite{Maurer:86} \nocite{Mazepa:85} \nocite{Mazzarella:85} \nocite{McCrea:81} \nocite{McCrea:82} \nocite{McCrea:83} \nocite{McCrea:84} \nocite{McCrea:84a} \nocite{McCrea:87} \nocite{McCrea:87a} \nocite{McCrea:88} \nocite{McIsaac:85} \nocite{Melenk:88} \nocite{Melenk:89} \nocite{Melenk:89a} \nocite{Melenk:89b} \nocite{Mirie:84} \nocite{Molenkamp:91} \nocite{Moller:89} \nocite{Moritsugu:85} \nocite{Moritsugu:88} \nocite{Moritsugu:89} \nocite{Moritsugu:89a} \nocite{Muroa:91} \nocite{Mueller:81} \nocite{Murzin:85} \nocite{Nagata:82} \nocite{Nagata:85} \nocite{Nakamura:89} \nocite{Nakashima:84} \nocite{Nakashima:84a} \nocite{Namba:86} \nocite{Nemeth:82} \nocite{Nemeth:87} \nocite{Neun:89} \nocite{Neutsch:85} \nocite{Neutsch:86} \nocite{Ng:89} \nocite{Niki:84} \nocite{Nikityuk:87} \nocite{Noor:79} \nocite{Norman:77} \nocite{Norman:78} \nocite{Norman:79} \nocite{Norman:83} \nocite{Norman90} \nocite{Norton:80} \nocite{Nucci:90} \nocite{Ochiai:90} \nocite{Ogilvie:82} \nocite{Ogilvie:89} \nocite{Ono:1979} \nocite{Ozieblo} \nocite{Padget90} \nocite{Pankau:73} \nocite{Pankau:73a} \nocite{Parsons:68} \nocite{Parsons:71} \nocite{Pasini:91} \nocite{Pattnaik:83} \nocite{Pearce:81} \nocite{Pearce:83} \nocite{Perjes:84} \nocite{Perjes:84a} \nocite{Perjes:84b} \nocite{Perjes:84c} \nocite{Perjes:86} \nocite{Perjes:86a} \nocite{Perjes:88} \nocite{Perlt:90} \nocite{Perrottet:78} \nocite{Pesic:73} \nocite{Pictiaw:69} \nocite{Piessens:84} \nocite{Piessens:86} \nocite{Pignataro:85} \nocite{Podgorzak:84} \nocite{Price:84} \nocite{Quarton} \nocite{Quarton:84} \nocite{Rao:85} \nocite{Rayna:87} \nocite{Renner:91} \nocite{Reusch:86} \nocite{Rink:71} \nocite{Rizzi:85} \nocite{Rodionov:84} \nocite{Rodionov:87} \nocite{Rodionov:87a} \nocite{Rodionov:88} \nocite{Roelofs:91} \nocite{Rogers:89} \nocite{Roque:88} \nocite{Roque:91} \nocite{Ronveaux:88} \nocite{Ronveaux:89} \nocite{Rudenko:91} \nocite{Saez:83} \nocite{Sage:88} \nocite{Sarlet:91} \nocite{Sasaki:79} \nocite{Savage:90} \nocite{Sayers:87} \nocite{Sayers:87a} \nocite{Schlegel:91} \nocite{Schmuck:77} \nocite{Schoepf:91} \nocite{Schruefer:81} \nocite{Schruefer:82} \nocite{Schruefer:87} \nocite{Schruefer:88} \nocite{Schwarz:80} \nocite{Schwarz:82} \nocite{Schwarz:82a} \nocite{Schwarz:83} \nocite{Schwarz:83a} \nocite{Schwarz:84} \nocite{Schwarz:84a} \nocite{Schwarz:85} \nocite{Schwarz:85a} \nocite{Schwarz:86} \nocite{Schwarz:87} \nocite{Schwarz:88} \nocite{Seiler:91} \nocite{Shablygin:87} \nocite{Shmueli:83} \nocite{Shmueli:83a} \nocite{Shtokhamer:75} \nocite{Shtokhamer:77} \nocite{Smit:79} \nocite{Smit:81} \nocite{Smit:82} \nocite{Smit:87} \nocite{Soderstrand:72} \nocite{Soderstrand:72a} \nocite{Soderstrand:74} \nocite{Soma:77} \nocite{Soma:85} \nocite{Spiridonova:87} \nocite{Squire} \nocite{Steinberg:82} \nocite{Steuerwald} \nocite{Stoutemyer:74} \nocite{Stoutemyer:75} \nocite{Stoutemyer:77} \nocite{Stroscio:74} \nocite{Stuart:88} \nocite{Stuart:90} \nocite{Suppes:89} \nocite{Surguladze:89} \nocite{Surguladze:91} \nocite{Tallents:84} \nocite{Tao90} \nocite{Tasso:76} \nocite{Thas:89} \nocite{Thas:89a} \nocite{Todd:88} \nocite{Toth:86} \nocite{Tournier:79} \nocite{Tournier:87} \nocite{Trenkov:91} \nocite{Trotter:89} \nocite{Tsai:65} \nocite{Tsai:74} \nocite{Ucoluk:82} \nocite{Umeno:89} \nocite{Urintsev:91} \nocite{vandenHeuvel:86} \nocite{vandenHeuvel:86a} \nocite{vandenHeuvel:87} \nocite{vandenHeuvel:87a} \nocite{vanHeerwaarden} \nocite{vanHulzen:80} \nocite{vanHulzen:81} \nocite{vanHulzen:82} \nocite{vanHulzen:82a} \nocite{vanHulzen:83} \nocite{vanHulzen:83a} \nocite{vanHulzen:87} \nocite{vanHulzen:88} \nocite{vanHulzen:89} \nocite{vanHulzen:89a} \nocite{VanProeyan:76} \nocite{VanProeyan:79} \nocite{Vega:91} \nocite{Vinitsky:87} \nocite{Voros:77} \nocite{Wanas} \nocite{Wanas:85} \nocite{Wang:84} \nocite{Wassam:87} \nocite{Wassam:87a} \nocite{Watanabe:85} \nocite{Watanabe:76} \nocite{Watanabe:79} \nocite{Weber:79} \nocite{Wehner:86} \nocite{Winkelmann:89} \nocite{Winkler:88} \nocite{Witham:77} \nocite{Wood:89} \nocite{Wright:84} \nocite{Wulkow:90} \nocite{Yamamoto:87} \nocite{Yamartino:91} \nocite{Yannouleas:88} \nocite{Yannouleas:89} \nocite{Zacrep:75} \nocite{Zahalak:87} \nocite{Zeng:84} \nocite{Zhidkova:78} \bibliography{bibl} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/compact.bib version [59d301d978].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | @INPROCEEDINGS{Hornfeldt:82, AUTHOR = "L. Hornfeldt", TITLE = "A Sum-Substitutor used as Trigonometric Simplifier", BOOKTITLE = "Proc. {EUROCAM} '82", PAGES = "188-195", SERIES = "Lecture Notes on Comp. Science", NUMBER = 144, PUBLISHER = "Springer-Verlag", ADDRESS = "Berlin", YEAR = 1982} |
Added r34.1/doc/compact.tex version [78b05677ff].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{COMPACT: Reduction of a Polynomial in the Presence of Side Relations} \date{} \author{Anthony C. Hearn\\ RAND\\ Santa Monica CA 90407-2138\\ Email: hearn@rand.org} \begin{document} \maketitle \index{COMPACT package} \index{side relations} \index{relations ! side} {COMPACT} is a package of functions for the reduction of a polynomial in the presence of side relations. The package defines one operator {COMPACT} \index{COMPACT operator} whose syntax is: \begin{quote} \k{COMPACT}(\s{expression}, \s{list}):\s{expression} \end{quote} \s{expression} can be any well-formed algebraic expression, and \s{list} an expression whose value is a list of either expressions or equations. For example \begin{verbatim} compact(x**2+y**3*x-5y,{x+y-z,x-y-z1}); compact(sin(x)**10*cos(x)**3+sin(x)**8*cos(x)**5, {cos(x)**2+sin(x)**2=1}); let y = {cos(x)**2+sin(x)**2-1}; compact(sin(x)**10*cos(x)**3+sin(x)**8*cos(x)**5,y); \end{verbatim} {COMPACT} applies the relations to the expression so that an equivalent expression results with as few terms as possible. The method used is briefly as follows: \begin{enumerate} \item Side relations are applied separately to numerator and denominator, so that the problem is reduced to the reduction of a polynomial with respect to a set of polynomial side relations. \item Reduction is performed sequentially, so that the problem is reduced further to the reduction of a polynomial with respect to a single polynomial relation. \item The polynomial being reduced is reordered so that the variables (kernels) occurring in the side relation have least precedence. \item Each coefficient of the remaining kernels (which now only contain the kernels in the side relation) is reduced with respect to that side relation. \item A polynomial quotient/remainder calculation is performed on the coefficient. The remainder is used instead of the original if it has fewer terms. \item The remaining expression is reduced with respect to the side relation using a ``nearest neighbor'' approach. \end{enumerate} As with the traveling salesman problem, a nearest neighbor approach to reduction does not necessarily achieve an optimal result. In most cases it will be within a factor of two from the optimal result, but in extreme cases it may be much further away. Another source of sub-optimal results is that the given expression is reduced sequentially with respect to the side relations. So for example in the case \begin{verbatim} compact((a+b+c)*(a-b-c)*(-a+b-c)*(-a-b+c), {x1=a+b+c,x2=a-b-c,x3=-a+b-c,x4=-a-b+c}) \end{verbatim} the expression is actually $x_{1}x_{2}x_{3}x_{4}$, but any given relation cannot reduce the size of the expanded form $a^{4}-2a^{2}b^{2}-2a^{2}c^{2}+b^{4}-2b^{2}c^{2}+c^{4}$ of the original expression, and so the final result is far from optimal. The only other program we have heard about that considers the compaction problem is that of Hornfeldt~\cite{Hornfeldt:82}. However, Hornfeldt reorders expressions so that the kernels in a side relation have highest order. Consequently, their coefficients are polynomials rather than integers or other constants as in our approach. Furthermore, it is not clear just how general Hornfeldt's approach is from his description, since he only talks about sine and cosine substitutions. There are a number of projects that this work immediately suggests. For example: \begin{enumerate} \item How does one do the reduction with the side relations in parallel? The above example shows this is necessary for an optimal solution. \item Should one reduce the side relations to a Groebner or other basis before doing any reduction? \item Should one check for the consistency of the basis? \item How does one do factorization and gcds on a polynomial whose variables are related by a set of side relations? \end{enumerate} The author would be interested in hearing from anyone wishing to work with him on any of these problems. \bibliography{compact} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/excalc.tex version [723cb6ff45].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{EXCALC: A System for Doing Calculations in the Calculus of Modern Differential Geometry} \author{Eberhard Schr\"{u}fer \\ GMD, Institut F1 \\ Postfach 1240 \\ 5205 St. Augustin \\ GERMANY \\[0.05in] Email: schrufer@gmdzi.gmd.de} \begin{document} \maketitle \index{EXCALC package} \section*{Acknowledgments} This program was developed over several years. I would like to express my deep gratitude to Dr. Anthony Hearn for his continuous interest in this work, and especially for his hospitality and support during a visit in 1984/85 at the RAND Corporation, where substantial progress on this package could be achieved. The Heinrich Hertz-Stiftung supported this visit. Many thanks are also due to Drs. F.W. Hehl, University of Cologne, and J.D. McCrea, University College Dublin, for their suggestions and work on testing this program. \section{Introduction} \index{differential geometry} {\bf EXCALC} is designed for easy use by all who are familiar with the calculus of Modern Differential Geometry. Its syntax is kept as close as possible to standard textbook notations. Therefore, no great experience in writing computer algebra programs is required. It is almost possible to input to the computer the same as what would have been written down for a hand-calculation. For example, the statement \begin{verbatim} f*x^y + u_|(y^z^x) \end{verbatim} \index{exterior calculus} would be recognized by the program as a formula involving exterior products and an inner product. The program is currently able to handle scalar-valued exterior forms, vectors and operations between them, as well as non-scalar valued forms (indexed forms). With this, it should be an ideal tool for studying differential equations, doing calculations in general relativity and field theories, or doing such simple things as calculating the Laplacian of a tensor field for an arbitrary given frame. With the increasing popularity of this calculus, this program should have an application in almost any field of physics and mathematics. Since the program is completely embedded in {\REDUCE}, all features and facilities of {\REDUCE} are available in a calculation. Even for those who are not quite comfortable in this calculus, there is a good chance of learning it by just playing with the program. This is still a very experimental version, and changes of the syntax are to be expected. The performance of the program can still be increased considerably. Complaints and comments are appreciated and should be sent to the author. If the use of this program leads to a publication, this document should be cited, and a copy of the article should be sent to the above address. \section{Declarations} Geometrical objects like exterior forms or vectors are introduced to the system by declaration commands. The declarations can appear anywhere in a program, but must, of course, be made prior to the use of the object. Everything that has no declaration is treated as a constant; therefore zero-forms must also be declared. An exterior form is introduced by\label{PFORM} \index{PFORM statement} \index{exterior form ! declaration} \hspace*{2em} \k{PFORM} \s{declaration$_1$}, \s{declaration$_2$}, \ldots; where \begin{tabbing} \s{declaration} ::= \s{name}=\s{number}|\s{identifier} $\mid$ \s{expression} \\ \s{name} ::= \s{identifier} $\mid$ \s{identifier}(\s{arguments}) \end{tabbing} For example \begin{verbatim} pform u=k,v=4,f=0,w=dim-1; \end{verbatim} declares {\tt U} to be an exterior form of degree {\tt K}, {\tt V} to be a form of degree 4, {\tt F} to be a form of degree 0 (a function), and {\tt W} to be a form of degree {\tt DIM}-1. If the exterior form should have indices, the declaration would be \index{exterior form ! with indices} \begin{verbatim} pform curv(a,b)=2,chris(a,b)=1; \end{verbatim} The name of the indices is arbitrary. The declaration of vectors is similar. The command {\tt TVECTOR}\label{TVECTOR} takes a list of names. \index{TVECTOR command} \index{exterior form ! vector} \example\index{EXCALC package ! example} To declare {\tt X} as a vector and {\tt COMM} as a vector with two indices, one would say \begin{verbatim} tvector x,comm(a,b); \end{verbatim} If a declaration of an already existing name is made, the old declaration is removed, and the new one is taken. \section{Exterior Multiplication} \index{"\^{} ! exterior multiplication} \index{exterior product} Exterior multiplication between exterior forms is carried out with the nary infix operator \^{ } (wedge)\label{wedge}. Factors are ordered according to the usual ordering in {\REDUCE} using the commutation rule for exterior products. \example\index{EXCALC package ! example} \begin{verbatim} pform u=1,v=1,w=k; u^v; U^V v^u; - U^V u^u; 0 w^u^v; K ( - 1) *U^V^W (3*u-a*w)^(w+5*v)^u; A*(5*U^V^W - U^W^W) \end{verbatim} It is possible to declare the dimension of the underlying space by\label{SPACEDIM} \index{SPACEDIM command} \index{dimension} \hspace*{2em} \k{SPACEDIM} \s{number} $\mid$ \s{identifier}; If an exterior product has a degree higher than the dimension of the space, it is replaced by 0: \begin{verbatim} spacedim 4; pform u=2,v=3; u^v; 0 \end{verbatim} \section{Partial Differentiation} Partial differentiation is denoted by the operator {\tt @}\label{at}. Its capability is the same as the {\REDUCE} {\tt DF} operator. \index{"@ operator} \index{partial differentiation} \index{differentiation ! partial} \example\index{EXCALC package ! example} \begin{verbatim} @(sin x,x); COS(X) @(f,x); 0 \end{verbatim} An identifier can be declared to be a function of certain variables. \index{FDOMAIN command} This is done with the command {\tt FDOMAIN}\label{FDOMAIN}. The following would tell the partial differentiation operator that {\tt F} is a function of the variables {\tt X} and {\tt Y} and that {\tt H} is a function of {\tt X}. \begin{verbatim} fdomain f=f(x,y),h=h(x); \end{verbatim} Applying {\tt @} to {\tt F} and {\tt H} would result in \begin{verbatim} @(f,x); @ F X @(x*f,x); F + X*@ F X @(h,y); 0 \end{verbatim} \index{tangent vector} The partial derivative symbol can also be an operator with a single argument. It then represents a natural base element of a tangent vector\label{at1}. \example\index{EXCALC package ! example} \begin{verbatim} a*@ x + b*@ y; A*@ + B*@ X Y \end{verbatim} \section{Exterior Differentiation} \index{exterior differentiation} Exterior differentiation of exterior forms is carried out by the operator {\tt d}\label{d}. Products are normally differentiated out, {\em i.e.} \begin{verbatim} pform x=0,y=k,z=m; d(x * y); X*d Y + d X^Y d(r*y); R*d Y d(x*y^z); K ( - 1) *X*Y^d Z + X*d Y^Z + d X^Y^Z \end{verbatim} This expansion can be suppressed by the command {\tt NOXPND D}\label{NOXPNDD}. \index{NOXPND ! D} \begin{verbatim} noxpnd d; d(y^z); d(Y^Z) \end{verbatim} To obtain a canonical form for an exterior product when the expansion is switched off, the operator {\tt D} is shifted to the right if it appears in the leftmost place. \begin{verbatim} d y ^ z; K - ( - 1) *Y^d Z + d(Y^Z) \end{verbatim} Expansion is performed again when the command {\tt XPND D}\label{XPNDD} is executed. \index{XPND ! D} Functions which are implicitly defined by the {\tt FDOMAIN} command are expanded into partial derivatives: \begin{verbatim} pform x=0,y=0,z=0,f=0; fdomain f=f(x,y); d f; @ F*d X + @ F*d Y X Y \end{verbatim} If an argument of an implicitly defined function has further dependencies the chain rule will be applied {\em e.g.} \index{chain rule} \begin{verbatim} fdomain y=y(z); d f; @ F*d X + @ F*@ Y*d Z X Y Z \end{verbatim} Expansion into partial derivatives can be inhibited by {\tt NOXPND @}\label{NOXPNDA} and enabled again by {\tt XPND @}\label{XPNDA}. \index{NOXPND ! "@} \index{XPND ! "@} The operator is of course aware of the rules that a repeated application always leads to zero and that there is no exterior form of higher degree than the dimension of the space. \begin{verbatim} d d x; 0 pform u=k; spacedim k; d u; 0 \end{verbatim} \section{Inner Product} \index{inner product ! exterior form} The inner product between a vector and an exterior form is represented by the diphthong \_$|$ \label{innerp} (underscore or-bar), which is the notation of many textbooks. If the exterior form is an exterior product, the inner product is carried through any factor. \index{\_$\mid$ operator} \example\index{EXCALC package ! example} \begin{verbatim} pform x=0,y=k,z=m; tvector u,v; u_|(x*y^z); K X*(( - 1) *Y^U_|Z + U_|Y^Z) \end{verbatim} In repeated applications of the inner product to the same exterior form the vector arguments are ordered {\em e.g.} \begin{verbatim} (u+x*v)_|(u_|(3*z)); - 3*U_|V_|Z \end{verbatim} The duality of natural base elements is also known by the system, {\em i.e.} \begin{verbatim} pform x=0,y=0; (a*@ x+b*@(y))_|(3*d x-d y); 3*A - B \end{verbatim} \section{Lie Derivative} \index{Lie Derivative} The Lie derivative can be taken between a vector and an exterior form or between two vectors. It is represented by the infix operator $|$\_ \label{lie}. In the case of Lie differentiating, an exterior form by a vector, the Lie derivative is expressed through inner products and exterior differentiations, {\em i.e.} \index{$\mid$\_ operator} \begin{verbatim} pform z=k; tvector u; u |_ z; U_|d Z + d(U_|Z) \end{verbatim} If the arguments of the Lie derivative are vectors, the vectors are ordered using the anticommutivity property, and functions (zero forms) are differentiated out. \example\index{EXCALC package ! example} \begin{verbatim} tvector u,v; v |_ u; - U|_V pform x=0,y=0; (x*u)|_(y*v); - U*Y*V_|d X + V*X*U_|d Y + X*Y*U|_V \end{verbatim} \section{Hodge-* Duality Operator} \index{Hodge-* duality poperator} \index{"\# ! Hodge-* operator} The Hodge-*\label{hodge} duality operator maps an exterior form of degree {\tt K} to an exterior form of degree {\tt N-K}, where {\tt N} is the dimension of the space. The double application of the operator must lead back to the original exterior form up to a factor. The following example shows how the factor is chosen here \begin{verbatim} spacedim n; pform x=k; # # x; 2 (K + K*N) ( - 1) *X*SGN \end{verbatim} \index{SGN ! indeterminate sign} \index{coframe} The indeterminate SGN in the above example denotes the sign of the determinant of the metric. It can be assigned a value or will be automatically set if more of the metric structure is specified (via COFRAME), {\em i.e.} it is then set to $g/|g|$, where $g$ is the determinant of the metric. If the Hodge-* operator appears in an exterior product of maximal degree as the leftmost factor, the Hodge-* is shifted to the right according to \begin{verbatim} pform x=k,y=k; # x ^ y; 2 (K + K*N) ( - 1) *X^# Y \end{verbatim} More simplifications are performed if a coframe is defined. \section{Variational Derivative} \index{derivative ! variational} \index{variational derivative} \ttindex{VARDF} The function {\tt VARDF}\label{VARDF} returns as its value the variation of a given Lagrangian n-form with respect to a specified exterior form (a field of the Lagrangian). In the shared variable \ttindex{BNDEQ"!*} {\tt BNDEQ!*}, the expression is stored that has to yield zero if integrated over the boundary. Syntax: \hspace*{2em} \k{VARDF}(\s{Lagrangian n-form},\s{exterior form}) \example\index{EXCALC package ! example} \begin{verbatim} spacedim 4; pform l=4,a=1,j=3; l:=-1/2*d a ^ # d a - a^# j$ %Lagrangian of the e.m. field vardf(l,a); - (# J + d # d A) %Maxwell's equations bndeq!*; - 'A^# d A %Equation at the boundary \end{verbatim} Restrictions: In the current implementation, the Lagrangian must be built up by the fields and the operations {\tt d}, {\tt \#}, and {\tt @}. Variation with respect to indexed quantities is currently not allowed. For the calculation of the conserved currents induced by symmetry operators (vector fields), the function {\tt NOETHER}\label{NOETHER} \index{NOETHER function} is provided. It has the syntax: \hspace*{2em} \k{NOETHER}(\s{Lagrangian n-form},\s{field},\s{symmetry generator}) \example\index{EXCALC package ! example} \begin{verbatim} pform l=4,a=1,f=2; spacedim 4; l:= -1/2*d a^#d a; %Free Maxwell field; tvector x(k); %An unspecified generator; noether(l,a,x(-k)); ( - 2*d(X _|A)^# d A - (X _|d A)^# d A + d A^(X _|# d A))/2 K K K \end{verbatim} The above expression would be the canonical energy momentum 3-forms of the Maxwell field, if X is interpreted as a translation; \section{Handling of Indices} \index{exterior form ! with indices} Exterior forms and vectors may have indices. On input, the indices are given as arguments of the object. A positive argument denotes a superscript and a negative argument a subscript. On output, the indexed quantity is displayed two dimensionally if {\tt NAT} is on. \index{NAT flag} Indices may be identifiers or numbers. However, zero is currently not allowed to be an index. \example\index{EXCALC package ! example} \begin{verbatim} pform om(k,l)=m,e(k)=1; e(k)^e(-l); K E ^E L om(4,-2); 4 OM 2 \end{verbatim} In the current release, full simplification is performed only if an index range is specified. It is hoped that this restriction can be removed soon. If the index range (the values that the indices can obtain) is specified, the given expression is evaluated for all possible index values, and the summation convention is understood. \example\label{INDEXRANGE}\index{EXCALC package ! example} \begin{verbatim} indexrange t,r,ph,z; pform e(k)=1,s(k,l)=2; w := e(k)*e(-k); T R PH Z W := E *E + E *E + E *E + E *E T R PH Z s(k,l):=e(k)^e(l); T T S := 0 R T T R S := - E ^E PH T T PH S := - E ^E . . . \end{verbatim} If the expression to be evaluated is not an assignment, the values of the expression are displayed as an assignment to an indexed variable with name {\tt NS}. This is done only on output, {\em i.e.} no actual binding to the variable NS occurs. \index{NS dummy variable} \begin{verbatim} e(k)^e(l); T T NS := 0 R T T R NS := - E ^E . . . \end{verbatim} It should be noted, however, that the index positions on the variable NS can sometimes not be uniquely determined by the system (because of possible reorderings in the expression). Generally it is advisable to use assignments to display complicated expressions. In certain cases, one would like to inhibit the summation over specified index names, or at all. For this the command \index{NOSUM command} \hspace*{2em} \k{NOSUM} \s{indexname$_1$}, \ldots;\label{NOSUM} and the switch {\tt NOSUM} are \index{NOSUM switch} available. The command {\tt NOSUM} has the effect that summation is not performed over those indices which had been listed. The command {\tt RENOSUM}\label{RENOSUM} enables summation again. The switch {\tt NOSUM}, if on, inhibits any summation. \index{RENOSUM command} It is possible to declare an indexed quantity completely antisymmetric or completely symmetric by the command \index{ANTISYMMETRIC command} \hspace*{2em} \k{ANTISYMMETRIC} \s{name$_1$}, \ldots;\label{ANTISYMMETRIC} or \index{SYMMETRIC command} \hspace*{2em} \k{SYMMETRIC} \s{name$_1$}, \ldots;\label{SYMMETRIC} If applicable, these commands should be issued, since great savings in memory and execution time result. Only strict components are printed. \section{Metric Structures} \index{metric structure} \index{coframe} A metric structure is defined in {\bf EXCALC} by specifying a set of basis one-forms (the coframe) together with the metric. Syntax:\label{COFRAME} \begin{tabbing} \hspace*{2em} \k{COFRAME} \= \s{identifier}\s{(index$_1$)}=\s{expression$_1$}, \\ \> \s{identifier}\s{(index$_2$)}=\s{expression$_2$}, \\ \> . \\ \> . \\ \> . \\ \> \s{identifier}\s{(index$_n$)}=\s{expression$_n$} \\ \> \hspace{1em} \k{WITH} \k{METRIC} \s{name}=\s{expression}; \\ \end{tabbing} \index{euclidean metric} \index{COFRAME ! WITH METRIC} This statement automatically sets the dimension of the space and the index range. The clause {\tt WITH METRIC} can be omitted if the metric \index{COFRAME ! WITH SIGNATURE} is Euclidean and the shorthand {\tt WITH SIGNATURE \s{diagonal elements}} \label{SIGNATURE} can be used in the case of a pseudo-Euclidean metric. The splitting of a metric structure in its metric tensor coefficients and basis one-forms is completely arbitrary including the extrems of an orthonormal frame and a coordinate frame. \example\index{EXCALC package ! example} \begin{verbatim} coframe e r=d r, e(ph)=r*d ph with metric g=e(r)*e(r)+e(ph)*e(ph); %Polar coframe coframe e(r)=d r,e(ph)=r*d(ph); %Same as before coframe o(t)=d t, o x=d x with signature -1,1; %A Lorentz coframe coframe b(xi)=d xi, b(eta)=d eta %A lightcone coframe with metric w=-1/2*(b(xi)*b(eta)+b(eta)*b(xi)); coframe e r=d r, e ph=d ph %Polar coordinate with metric g=e r*e r+r**2*e ph*e ph; %basis \end{verbatim} Individual elements of the metric can be accessed just by calling them with the desired indices. The value of the determinant of the \index{determinant ! in DETM"!*} \ttindex{DETM"!*} covariant metric is stored in the variable {\tt DETM!*}. The metric is not needed for lowering or raising of indices as the system performs this automatically, {\em i.e.} no matter in what index position values were assigned to an indexed quantity, the values can be retrieved for any index position just by writing the indexed quantity with the desired indices. \example\index{EXCALC package ! example} \begin{verbatim} coframe e t=d t,e x=d x,e y=d y with signature -1,1,1; pform f(k,l)=0; antisymmetric f; f(-t,-x):=ex$ f(-x,-y):=b$ f(-t,-y):=0$ on nero; f(k,-l):=f(k,-l); X F := - EX T T F := - EX X Y F := - B X X F := B Y \end{verbatim} Any expression containing differentials of the coordinate functions will be transformed into an expression of the basis one-forms.The system also knows how to take the exterior derivative of the basis one-forms. \index{spherical coordinates} \example (Spherical coordinates)\index{EXCALC package ! example} \begin{verbatim} coframe e(r)=d(r), e(th)=r*d(th), e(ph)=r*sin(th)*d(ph); d r^d th; R TH (E ^E )/R d(e(th)); R TH (E ^E )/R pform f=0; fdomain f=f(r,th,ph); factor e; on rat; d f; %The "gradient" of F in spherical coordinates; R TH PH E *@ F + (E *@ F)/R + (E *@ F)/(R*SIN(TH)) R TH PH \end{verbatim} The frame dual to the frame defined by the {\tt COFRAME} command can be introduced by \k{FRAME} command. \index{FRAME command} \hspace*{2em} \k{FRAME} \s{identifier};\label{FRAME} This command causes the dual property to be recognized, and the tangent vectors of the coordinate functions are replaced by the frame basis vectors. \example\index{EXCALC package ! example} \begin{verbatim} coframe b r=d r,b ph=r*d ph,e z=d z; %Cylindrical coframe; frame x; on nero; x(-k)_|b(l); R NS := 1 R PH NS := 1 PH Z NS := 1 Z x(-k) |_ x(-l); %The commutator of the dual frame; NS := X /R PH R PH NS := ( - X )/R %i.e. it is not a coordinate base; R PH PH \end{verbatim} \index{DISPLAYFRAME command} \index{tracing ! EXCALC} As a convenience, the frames can be displayed at any point in a program by the command {\tt DISPLAYFRAME;}\label{DISPLAYFRAME}. \index{Hodge-* duality operator} The Hodge-* duality operator returns the explicitly constructed dual element if applied to coframe base elements. The metric is properly taken into account. \index{Levi-Cevita tensor} \ttindex{EPS} The total antisymmetric Levi-Cevita tensor {\tt EPS}\label{EPS} is also available. The value of {\tt EPS} with an even permutation of the indices in a covariant position is taken to be +1. \section{Riemannian Connections} \index{Riemannian Connections} The command {\tt RIEMANNCONX} is provided for calculating the \index{RIEMANNCONX command} \label{RIEMANNCONX} connection 1 forms. The values are stored on the name given to {\tt RIEMANNCONX}. This command is far more efficient than calculating the connection from the differential of the basis one-forms and using inner products. \example (Calculate the connection 1-form and curvature 2-form on S(2)) \index{EXCALC package ! example} \begin{verbatim} coframe e th=r*d th,e ph=r*sin(th)*d ph; riemannconx om; om(k,-l); %Display the connection forms; TH NS := 0 TH PH PH NS := (E *COS(TH))/(SIN(TH)*R) TH TH PH NS := ( - E *COS(TH))/(SIN(TH)*R) PH PH NS := 0 PH pform curv(k,l)=2; curv(k,-l):=d om(k,-l) + om(k,-m)^om(m-l); %The curvature forms TH CURV := 0 TH PH TH PH 2 CURV := ( - E ^E )/R TH %Of course it was a sphere with %radius R. TH TH PH 2 CURV := (E ^E )/R PH PH CURV := 0 PH \end{verbatim} \section{Ordering and Structuring} \index{ordering ! exterior form} \index{FORDER command} The ordering of an exterior form or vector can be changed by the command {\tt FORDER}.\label{FORDER} In an expression, the first identifier or kernel in the arguments of {\tt FORDER} is ordered ahead of the second, and so on, and ordered ahead of all not appearing as arguments. This ordering is done on the internal level and not only on output. The execution of this statement can therefore have tremendous effects on computation time and memory requirements. {\tt REMFORDER}\label{REMFORDER} brings back standard ordering for those elements that are listed as arguments. \index{REMFORDER command} \index{ISOLATE command} Another ordering command is {\tt ISOLATE}.\label{ISOLATE} It takes one argument. The system attempts to shift out this identifier or kernel to the leftmost position, utilizing commutation and derivative rules. {\tt REMISOLATE} restores normal ordering. \index{REMISOLATE command}\label{REMISOLATE} \example\index{EXCALC package ! example} \begin{verbatim} pform u=k,v=l,w=m; u^d(v)^w; U^d V^W forder v; u^d(v)^w; (K*L + K) ( - 1) *d V^U^W isolate v; u^d(v); (K*L + K) L ( - 1) *(d(V^U) - ( - 1) *V^d U) \end{verbatim} An expression can be put in a more structured form by renaming a subexpression. This is done with the command {\tt KEEP} which has the syntax \index{KEEP command}\label{KEEP} \hspace*{2em} \k{KEEP} \s{name$_1$}=\s{expression$_1$},\s{name$_2$}=\s{expression$_2$}, \ldots The effect is that rules are set up for simplifying \s{name} without introducing its definition in an expression. In an expression the system also tries by reordering to generate as many instances of \s{name} as possible. \example\index{EXCALC package ! example} \begin{verbatim} pform x=0,y=0,z=0,f=0,j=3; keep j=d x^d y^d z; j; J d j; 0 j^d x; 0 fdomain f=f(x); d f^d y^d z; @ F*J X \end{verbatim} \index{exterior product} The capabilities of {\tt KEEP} are currently very limited. Only exterior products should occur as righthand sides in {\tt KEEP}. \section{Summary of Operators and Commands} Table~\ref{EXCALC:sum} summarizes EXCALC commands and the page number they are defined on. \begin{table} \begin{tabular}{l l r} \index{"\^{} ! exterior multiplication} \index{wedge} \^{ } & Exterior Multiplication & \pageref{wedge} \\ \index{"@ ! partial differentiation} @ & Partial Differentiation & \pageref{at} \\ \index{"@ ! tangent vector} @ & Tangent Vector & \pageref{at1} \\ \index{"\# ! Hodge-* operator} \# & Hodge-* Operator & \pageref{hodge} \\ \index{\_$\mid$ operator} \_$|$ & Inner Product & \pageref{innerp} \\ \index{$\mid$\_ operator} $|$\_ & Lie Derivative & \pageref{lie} \\ \index{ANTISYMMETRIC command} ANTISYMMETRIC & Declares completely antisymmetric & \pageref{ANTISYMMETRIC} \\ & indexed quantities & \\ \index{COFRAME command} COFRAME & Declaration of a coframe & \pageref{COFRAME} \\ \index{d ! exterior differentiation} d & Exterior differentiation & \pageref{d} \\ \index{DISPLAYFRAME command} DISPLAYFRAME & Displays the frame & \pageref{DISPLAYFRAME}\\ \index{EPS ! Levi-Civita tensor} EPS & Levi-Civita tensor & \pageref{EPS} \\ \index{FDOMAIN command} FDOMAIN & Declaration of implicit dependencies &\pageref{FDOMAIN} \\ \index{FORDER command} FORDER & Ordering command & \pageref{FORDER} \\ \index{FRAME command} FRAME & Declares the frame dual to the coframe & \pageref{FRAME} \\ \index{INDEXRANGE command} INDEXRANGE & Declaration of indices & \pageref{INDEXRANGE} \\ \index{ISOLATE command} ISOLATE & Ordering command & \pageref{ISOLATE} \\ \index{KEEP command} KEEP & Structuring command & \pageref{KEEP} \\ \index{METRIC command} METRIC & Clause of COFRAME to specify a metric & \pageref{COFRAME} \\ \index{NOETHER function} NOETHER & Calculates the Noether current & \pageref{NOETHER} \\ \index{NOSUM command} NOSUM & Inhibits summation convention & \pageref{NOSUM} \\ \index{NOXPND command} NOXPND d & Inhibits the use of product rule for d & \pageref{NOXPNDD} \\ \index{NOXPND "@ command} NOXPND @ & Inhibits expansion into partial derivatives & \pageref{NOXPNDA} \\ \index{PFORM command} PFORM & Declaration of exterior forms & \pageref{PFORM} \\ \index{REMFORDER command} REMFORDER & Clears ordering & \pageref{REMFORDER} \\ \index{REMISOLATE command} REMISOLATE & Clears ISOLATE command & \pageref{REMISOLATE} \\ \index{RENOSUM command} RENOSUM & Enables summation convention & \pageref{RENOSUM} \\ \index{RIEMANNCONX command} RIEMANNCONX & Calculation of a Riemannian Connection & \pageref{RIEMANNCONX} \\ \index{SIGNATURE command} SIGNATURE & Clause of COFRAME to specify a pseudo- & \pageref{SIGNATURE} \\ & Euclidean metric & \\ \index{SPACEDIM command} SPACEDIM & Command to set the dimension of a space & \pageref{SPACEDIM} \\ \index{SYMMETRIC command} SYMMETRIC & Declares completely symmetric indexed & \pageref{SYMMETRIC} \\ & quantities & \\ \index{TVECTOR command} TVECTOR & Declaration of vectors & \pageref{TVECTOR} \\ \ttindex{VARDF} VARDF & Variational derivative & \pageref{VARDF} \\ \index{XPND command} XPND d & Enables the use of product rule for d & \pageref{XPNDD} \\ & (default) & \\ \index{XPND ! "@} XPND @ & Enables expansion into partial derivatives & \pageref{XPNDA} \\ & (default) \end{tabular} \caption{EXCALC Command Summary}\label{EXCALC:sum} \end{table} \newpage \section{Examples} The following examples should illustrate the use of {\bf EXCALC}. It is not intended to show the most efficient or most elegant way of stating the problems; rather the variety of syntactic constructs are exemplified. The examples are on a test file distributed with {\bf EXCALC}. \index{EXCALC package ! example} {\small \begin{verbatim} % Problem: Calculate the PDE's for the isovector of the heat % equation. % -------- % (c.f. B.K. Harrison, f.B. Estabrook, "Geometric Approach...", % J. Math. Phys. 12, 653, 1971); %The heat equation @ psi = @ psi is equivalent to the set of % xx t %exterior equations (with u=@ psi, y=@ psi): % T x pform psi=0,u=0,x=0,y=0,t=0,a=1,da=2,b=2; a:=d psi - u*d t - y*d x; da:=- d u^d t - d y^d x; b:=u*d x^d t - d y^d t; %Now calculate the PDE's for the isovector; tvector v; pform vpsi=0,vt=0,vu=0,vx=0,vy=0; fdomain vpsi=vpsi(psi,t,u,x,y),vt=vt(psi,t,u,x,y), vu=vu(psi,t,u,x,y), vx=vx(psi,t,u,x,y), vy=vy(psi,t,u,x,y); v:=vpsi*@ psi + vt*@ t + vu*@ u + vx*@ x + vy*@ y; factor d; on rat; i1:=v |_ a - l*a; pform o=1; o:=ot*d t + ox*d x + ou*d u + oy*d y; fdomain f=f(psi,t,u,x,y); i11:=v_|d a - l*a + d f; let vx=-@(f,y),vt=-@(f,u),vu=@(f,t)+u*@(f,psi),vy=@(f,x)+y*@(f,psi), vpsi=f-u*@(f,u)-y*@(f,y); factor ^; i2:=v |_ b - xi*b - o^a + zet*da; let ou=0,oy=@(f,u,psi),ox=-u*@(f,u,psi), ot=@(f,x,psi)+u*@(f,y,psi)+y*@(f,psi,psi); i2; let zet=-@(f,u,x)-@(f,u,y)*u-@(f,u,psi)*y; i2; let xi=-@(f,t,u)-u*@(f,u,psi)+@(f,x,y)+u*@(f,y,y)+ y*@(f,y,psi)+@(f,psi); i2; let @(f,u,u)=0; i2; % These PDE's have to be solved; clear a,da,b,v,i1,i11,o,i2,xi,t; remfdomain f; clear @(f,u,u); %Problem: %-------- %Calculate the integrability conditions for the system of PDE's: %(c.f. B.F. Schutz, "Geometrical Methods of Mathematical Physics" %Cambridge University Press, 1984, p. 156) % @ z /@ x + a1*z + b1*z = c1 % 1 1 2 % @ z /@ y + a2*z + b2*z = c2 % 1 1 2 % @ z /@ x + f1*z + g1*z = h1 % 2 1 2 % @ z /@ y + f2*z + g2*z = h2 % 2 1 2 ; pform w(k)=1,integ(k)=4,z(k)=0,x=0,y=0,a=1,b=1,c=1,f=1,g=1,h=1, a1=0,a2=0,b1=0,b2=0,c1=0,c2=0,f1=0,f2=0,g1=0,g2=0,h1=0,h2=0; fdomain a1=a1(x,y),a2=a2(x,y),b1=b1(x,y),b2=b2(x,y), c1=c1(x,y),c2=c2(x,y),f1=f1(x,y),f2=f2(x,y), g1=g1(x,y),g2=g2(x,y),h1=h1(x,y),h2=h2(x,y); a:=a1*d x+a2*d y$ b:=b1*d x+b2*d y$ c:=c1*d x+c2*d y$ f:=f1*d x+f2*d y$ g:=g1*d x+g2*d y$ h:=h1*d x+h2*d y$ %The equivalent exterior system:; factor d; w(1) := d z(-1) + z(-1)*a + z(-2)*b - c; w(2) := d z(-2) + z(-1)*f + z(-2)*g - h; indexrange 1,2; factor z; %The integrability conditions:; integ(k) := d w(k) ^ w(1) ^ w(2); clear a,b,c,f,g,h,w(k),integ(k); %Problem: %-------- %Calculate the PDE's for the generators of the d-theta symmetries of %the Lagrangian system of the planar Kepler problem. %c.f. W.Sarlet, F.Cantrijn, Siam Review 23, 467, 1981; %Verify that time translation is a d-theta symmetry and %calculate the corresponding integral; pform t=0,q(k)=0,v(k)=0,lam(k)=0,tau=0,xi(k)=0,et(k)=0,theta=1,f=0, l=0,glq(k)=0,glv(k)=0,glt=0; tvector gam,y; indexrange 1,2; fdomain tau=tau(t,q(k),v(k)),xi=xi(t,q(k),v(k)),f=f(t,q(k),v(k)); l:=1/2*(v(1)**2+v(2)**2)+m/r$ %The Lagrangian; pform r=0; fdomain r=r(q(k)); let @(r,q 1)=q(1)/r,@(r,q 2)=q(2)/r,q(1)**2+q(2)**2=r**2; lam(k):=-m*q(k)/r; %The force; gam:=@ t + v(k)*@(q(k)) + lam(k)*@(v(k))$ et(k) := gam _| d xi(k) - v(k)*gam _| d tau$ y :=tau*@ t + xi(k)*@(q(k)) + et(k)*@(v(k))$ %Symmetry generator; theta := l*d t + @(l,v(k))*(d q(k) - v(k)*d t)$ factor @; s := y |_ theta - d f$ glq(k):=@(q k)_|s; glv(k):=@(v k)_|s; glt:=@(t)_|s; %Translation in time must generate a symmetry; xi(k) := 0; tau := 1; glq k; glv k; glt; %The corresponding integral is of course the energy; integ := - y _| theta; clear l,lam k,gam,et k,y,theta,s,glq k,glv k,glt,t,q k,v k,tau,xi k; remfdomain r,f; %Problem: %-------- %Calculate the "gradient" and "Laplacian" of a function and the %"curl" and "divergence" of a one-form in elliptic coordinates; coframe e u=sqrt(cosh(v)**2-sin(u)**2)*d u, e v=sqrt(cosh(v)**2-sin(u)**2)*d v, e ph=cos u*sinh v*d ph; pform f=0; fdomain f=f(u,v,ph); factor e,^; on rat,gcd; order cosh v, sin u; %The gradient:; d f; factor @; %The Laplacian:; # d # d f; %Another way of calculating the Laplacian: -#vardf(1/2*d f^#d f,f); remfac @; %Now calculate the "curl" and the "divergence" of a one-form: pform w=1,a(k)=0; fdomain a=a(u,v,ph); w:=a(-k)*e k; %The curl: x := # d w; factor @; %The divergence; y := # d # w; remfac @; clear x,y,w,u,v,ph,e k,a k; remfdomain a,f; %Problem: %-------- %Calculate in a spherical coordinate system the Navier Stokes %equations; coframe e r=d r,e th=r*d th,e ph=r*sin th*d ph; frame x; fdomain v=v(t,r,th,ph),p=p(r,th,ph); pform v(k)=0,p=0,w=1; %We first calculate the convective derivative; w := v(-k)*e(k)$ factor e; on rat; cdv := @(w,t) + (v(k)*x(-k)) |_ w - 1/2*d(v(k)*v(-k)); %next we calculate the viscous terms; visc := nu*(d#d# w - #d#d w) + nus*d#d# w; %finally we add the pressure term and print the components of the %whole equation; pform nasteq=1,nast(k)=0; nasteq := cdv - visc + 1/rho*d p$ factor @; nast(-k) := x(-k) _| nasteq; remfac @,e; clear v k,x k,nast k,cdv,visc,p,w,nasteq; remfdomain p,v; %Problem: %-------- %Calculate from the Lagrangian of a vibrating rod the equation of % motion and show that the invariance under time translation leads % to a conserved current; pform y=0,x=0,t=0,q=0,j=0,lagr=2; fdomain y=y(x,t),q=q(x),j=j(x); factor ^; lagr:=1/2*(rho*q*@(y,t)**2-e*j*@(y,x,x)**2)*d x^d t; vardf(lagr,y); %The Lagrangian does not explicitly depend on time; therefore the %vector field @ t generates a symmetry. The conserved current is pform c=1; factor d; c := noether(lagr,y,@ t); %The exterior derivative of this must be zero or a multiple of the %equation of motion (weak conservation law) to be a conserved %current; remfac d; d c; %i.e. it is a multiple of the equation of motion; clear lagr,c; %Problem: %-------- %Show that the metric structure given by Eguchi and Hanson induces a %self-dual curvature. %c.f. T. Eguchi, P.B. Gilkey, A.J. Hanson, "Gravitation, Gauge %Theories and Differential Geometry", Physics Reports 66, 213, 1980; for all x let cos(x)**2=1-sin(x)**2; pform f=0,g=0; fdomain f=f(r), g=g(r); coframe o(r) =f*d r, o(theta) =(r/2)*(sin(psi)*d theta-sin(theta)*cos(psi)*d phi), o(phi) =(r/2)*(-cos(psi)*d theta-sin(theta)*sin(psi)*d phi), o(psi) =(r/2)*g*(d psi+cos(theta)*d phi); frame e; pform gamma1(a,b)=1,curv2(a,b)=2; antisymmetric gamma1,curv2; factor o; gamma1(-a,-b):=-(1/2)*( e(-a)_|(e(-c)_|(d o(-b))) -e(-b)_|(e(-a)_|(d o(-c))) +e(-c)_|(e(-b)_|(d o(-a))) )*o(c)$ curv2(-a,b):=d gamma1(-a,b) + gamma1(-c,b)^gamma1(-a,c)$ factor ^; curv2(a,b):= curv2(a,b)$ let f=1/g; let g=sqrt(1-(a/r)**4); pform chck(k,l)=2; antisymmetric chck; %The following has to be zero for a self-dual curvature; chck(k,l):=1/2*eps(k,l,m,n)*curv2(-m,-n)+curv2(k,l); clear gamma1(a,b),curv2(a,b),f,g,chck(a,b),o(k),e(k); remfdomain f,g; %Problem: %-------- %Calculate for a given coframe and given torsion the Riemannian %part and the torsion induced part of the connection. Calculate %the curvature. %For a more elaborate example: E.Schruefer, F.W. Hehl, J.D. McCrea, %"Exterior Calculus on the Computer: The REDUCE-Package EXCALC %Applied to General Relativity and to the Poincare Gauge Theory", %GRG, vol. 19, 1987, pp. 197-218 pform ff=0, gg=0; fdomain ff=ff(r), gg=gg(r); coframe o(4)=d u+2*b0*cos(theta)*d phi, o(1)=ff*(d u+2*b0*cos(theta)*d phi)+ d r, o(2)=gg*d theta, o(3)=gg*sin(theta)*d phi with metric g=-o(4)*o(1)-o(4)*o(1)+o(2)*o(2)+o(3)*o(3); frame e; pform tor(a)=2,gwt(a)=2,gam(a,b)=1, u1=0,u3=0,u5=0; antisymmetric gam; fdomain u1=u1(r),u3=u3(r),u5=u5(r); tor(4):=0$ tor(1):=-u5*o(4)^o(1)-2*u3*o(2)^o(3)$ tor(2):=u1*o(4)^o(2)+u3*o(4)^o(3)$ tor(3):=u1*o(4)^o(3)-u3*o(4)^o(2)$ gwt(-a):=d o(-a)-tor(-a)$ %The following is the combined connection; %The Riemannian part could have equally well been calculated by the %RIEMANNCONX statement; gam(-a,-b):=(1/2)*( e(-b)_|(e(-c)_|gwt(-a)) +e(-c)_|(e(-a)_|gwt(-b)) -e(-a)_|(e(-b)_|gwt(-c)) )*o(c); pform curv(a,b)=2; antisymmetric curv; factor ^; curv(-a,b):=d gam(-a,b) + gam(-c,b)^gam(-a,c); showtime; end; \end{verbatim} } \end{document} |
Added r34.1/doc/gentran.bib version [b1776c7307].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @BOOK{FORTRAN, KEY = "American National Standards Institute", TITLE = "American National Standard Programming Language {FORTRAN}", PUBLISHER = "American National Standards Institute", SERIES = "{ANS X3.9}", ADDRESS = "New York", YEAR = 1978} @INPROCEEDINGS{Gates:84, AUTHOR = "Barbara L. Gates and Paul S. Wang", TITLE = "A {LISP}-Based {RATFOR} Code Generator", BOOKTITLE = "Proceedings of the 1984 {MACSYMA} User's Conference", ADDRESS = "Schenectady, New York", MONTH = "July", YEAR = 1984} @INPROCEEDINGS{Gates:85, AUTHOR = "Barbara L. Gates and J. A. van Hulzen", TITLE = "Automatic Generation of Optimized Programs", BOOKTITLE = "Proc. {EUROCAL} '85", YEAR = 1985, MONTH = "April"} @ARTICLE{Gates:85a, AUTHOR = "Barbara L. Gates", TITLE = "Gentran: An Automatic Code Generation Facility for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "24-42", MONTH = "August"} @TECHREPORT{Gates:85b, AUTHOR = "Barbara L. Gates", TITLE = "Gentran User's Manual - {REDUCE} Version", INSTITUTION = "Twente University of Technology, Department of Computer Science, The Netherlands", TYPE = "Memorandum", YEAR = 1985, NUMBER = "INF-85-11", MONTH = "June"} @INPROCEEDINGS{Gates:86, AUTHOR = "Barbara L. Gates", TITLE = "A Numerical Code Generation Facility for {REDUCE}", BOOKTITLE = "Proc. {SYMSAC} '86", YEAR = 1986, PAGES = "94-99", MONTH = "July"} @MANUAL{Kernighan:79, AUTHOR = "B. W. Kernighan", TITLE = "{RATFOR} -- A Preprocessor for a Rational Fortran", SERIES = "{UNIX} Programmer's Manual", VOLUME = "2B", EDITION = "Seventh", PUBLISHER = "Bell Telephone Laboratories, Inc.", ADDRESS = "Murray Hill, New Jersey", YEAR = 1979} @BOOK{Kernighan:78, AUTHOR = "B. W. Kernighan and Dennis M. Ritchie", TITLE = "The {C} Programming Language", PUBLISHER = "Prentice-Hall", ADDRESS = "Englewood Cliffs, New Jersey", YEAR = 1978} @ARTICLE{Wang:86, AUTHOR = "Payl S. Wang", TITLE = "{FINGER}: A Symbolic System for Automatic Generation of Numerical Programs in Finite Element Analysis", JOURNAL = "Journal of Symbolic Computation", VOLUME = 2, YEAR = 1986} @MASTERSTHESIS{vandenHeuvel:86ms, AUTHOR = "Pim van den Heuvel", TITLE = "Aspects of Program Generation Related to Automatic Differentiation", SCHOOL = "Twente University of Technology", ADDRESS = "Department of Computer Science, Enschede, The Netherlands", MONTH = "December", YEAR = 1986} @INPROCEEDINGS{vanHulzen:89, AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof and B. L. Gates and M. C. Van Heerwaarden", TITLE = "A Code Optimization Package for {REDUCE}", BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York", YEAR = 1989, PAGES = "163-170", COMMENT = {Lecture Notes.}} @INPROCEEDINGS{Wang:84, AUTHOR = "Paul S. Wang and T. Y. P. Chang and J. A. van Hulzen", TITLE = "Code Generation and Optimization for Finite Element Analysis", BOOKTITLE = "{EUROSAM} '84 Conference Proceedings", PUBLISHER = "Springer-Verlag", SERIES = "{LNCS} Series", YEAR = 1984} |
Added r34.1/doc/gentran.tex version [1addc37c21].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 | \documentstyle[11pt,reduce]{article} \title{GENTRAN User's Manual \\ REDUCE Version} \date{} \author{Barbara L. Gates \\ RAND \\ Santa Monica CA 90407-2138 \\[0.05in] {\em Updated for {\REDUCE} 3.4 by} \\[0.05in] Michael C. Dewar \\ The University of Bath \\ Email: mcd@maths.bath.ac.uk} \begin{document} \maketitle \index{GENTRAN ! package} \index{GENTRAN package !} \begin{center} February 1991 \end{center} GENTRAN is an automatic code GENerator and TRANslator which runs under REDUCE and VAXIMA\index{VAXIMA}. It constructs complete numerical programs based on sets of algorithmic specifications and symbolic expressions. Formatted FORTRAN, RATFOR or C code can be generated through a series of interactive commands or under the control of a template processing routine. Large expressions can be automatically segmented into subexpressions of manageable size, and a special file-handling mechanism maintains stacks of open I/O channels to allow output to be sent to any number of files simultaneously and to facilitate recursive invocation of the whole code generation process. GENTRAN provides the flexibility necessary to handle most code generation applications. This manual describes usage of the GENTRAN package for REDUCE. \subsection*{Acknowledgements} The GENTRAN package was created at Kent State University to generate numerical code for computations in finite element analysis. I would like to thank Prof. Paul Wang for his guidance and many suggestions used in designing the original package for VAXIMA. The second version of GENTRAN was implemented at Twente University of Technology to run under REDUCE. It was designed to be interfaced with a code optimization facility created by Dr. J. A. van Hulzen. I would like to thank Dr. van Hulzen for all of his help in the implementation of GENTRAN in RLISP during a stay at his university in The Netherlands. Finally, I would like to thank Dr. Anthony Hearn of the RAND Corporation for his help in better integrating GENTRAN into the REDUCE environment. \section{INTRODUCTION} Solving a problem in science or engineering is often a two-step process. First the problem is modeled mathematically and derived symbolically to provide a set of formulas which describe how to solve the problem numerically. Next numerical programs are written based on this set of formulas to efficiently compute specific values for given sets of input. Computer algebra systems such as REDUCE provide powerful tools for use in the formula-derivation phase but only provide primitive program-coding tools. The GENTRAN package~\cite{Gates:85,Gates:85a,Gates:85b,Gates:86} has been constructed to automate the tedious, time consuming and error-prone task of writing numerical programs based on a set of symbolic expressions. \subsection{The GENTRAN Code Generator and Translator} The GENTRAN code GENeration and TRANslation package, originally implemented in Franz LISP to run under VAXIMA~\cite{Gates:84}, is now also implemented in RLISP to run under REDUCE. Although GENTRAN was originally created specifically to generate numerical code for use with an existing FORTRAN-based finite element analysis package~\cite{Wang:86,Wang:84}, it was designed to provide the flexibility required to handle most code generation applications. GENTRAN contains code generation commands, file-handling commands, mode switches, and global variables, all of which are accessible from both the algebraic and symbolic modes of REDUCE to give the user maximal control over the code generation process. Formatted \index{FORTRAN} \index{RATFOR} \index{C} FORTRAN~\cite{FORTRAN}, RATFOR~\cite{Kernighan:79}, C~\cite{Kernighan:78}, or PASCAL code can be generated from algorithmic specifications, i.e., descriptions of the behaviour of the target numerical program expressed in the REDUCE programming language, and from symbolically derived expressions and formulas. In addition to arithmetic expressions and assignment statements, GENTRAN can also generate type declarations and control-flow structures. Code generation can be guided by user-supplied template file(s) to insert generated code into pre-existing program skeletons, or it can be accomplished interactively through a series of translation commands without the use of template files. Special mode switches enable the user to turn on or off specific features such as automatic segmentation of large expressions, and global variables allow the user to modify the code formatting process. Generated code can be sent to one or more files and, optionally, to the user's terminal. Stacks of open I/O channels facilitate temporary output redirection and recursive invocation of the code generation process. \subsection{Code Optimization} \index{optimization, code} A code optimizer~\cite{vanHulzen:89}, which runs under REDUCE, has been constructed to reduce the arithmetic complexity of a set of symbolic expressions (see the SCOPE package on page~\pageref{SCOPE:intro}). It optimizes them by extracting common subexpressions and assigning them to temporary variables which are inserted in their places. The optimization technique is based on mapping the expressions onto a matrix of coefficients and exponents which are searched for patterns corresponding to the common subexpressions. Due to this process the size of the expressions is often considerably reduced. GENTRAN and the Code Optimizer have been interfaced to make it possible to generate optimized numerical programs directly \index{GENTRANOPT switch} from REDUCE. Setting the switch {\tt GENTRANOPT} {\bf ON} specifies that all sequences of assignment statements are to be optimized before being converted to numerical code. \subsection{Organization of the Manual} The remainder of this manual is divided into five sections. Sections \ref{GENTRAN:inter} and \ref{GENTRAN:template} describe code generation. Section \ref{GENTRAN:inter} explains interactive code generation, the expression segmentation facility, and how temporary variables can be generated; then section \ref{GENTRAN:template} explains how code generation can be guided by a user-supplied template file. Section \ref{GENTRAN:output} describes methods of output redirection, and section \ref{GENTRAN:mod} describes user-accessible global variables and mode switches which alter the code generation process. Finally section \ref{GENTRAN:examples} presents three complete examples. \subsubsection{Typographic Conventions} The following conventions are used in the syntactic definitions of commands in this manual: \begin{itemize} \item[{-}] Command parts which must be typed exactly as shown are given in {\bf BOLD PRINT}. \item[{-}] User-supplied arguments are {\it emphasized}. \item[{-}] [ ... ] indicate optional command parts. \end{itemize} The syntax of each GENTRAN command is shown terminated with a {\bf ;}. However, either {\bf ;} or {\bf \$} can be used to terminate any command with the usual REDUCE meaning: {\bf ;} indicates that the returned value is to be printed, while {\bf \$} indicates that printing of the returned value is to be suppressed. Throughout this manual it is stated that file name arguments must be atoms. The exact type of atom (e.g., identifier or string) is system and/or site dependent. The instructions for the implementation being used should therefore be consulted. \section{Interactive Code Generation}\label{GENTRAN:inter} GENTRAN generates numerical programs based on algorithmic specifications in the REDUCE programming language and derived symbolic expressions \index{FORTRAN} \index{RATFOR} \index{PASCAL} \index{C} produced by REDUCE evaluations. FORTRAN, RATFOR, PASCAL or C code can be produced. Type declarations can be generated, and comments and other literal strings can be inserted into the generated code. In addition, large arithmetic expressions can be automatically segmented into a sequence of subexpressions of manageable size. This section explains how to select the target language, generate code, control expression segmentation, and how to generate temporary variable names. \subsection{Target Language Selection} \label{gentranlang} Before generating code, the target numerical language must be selected. GENTRAN is currently able to generate FORTRAN, RATFOR, PASCAL and C \ttindex{GENTRANLANG"!*} code. The global variable {\bf GENTRANLANG!*} determines which type of code is produced. {\bf GENTRANLANG!*} can be set in algebraic or symbolic mode. It can be set to any value, but only four atoms have special meaning: {\bf FORTRAN}, {\bf RATFOR}, {\bf PASCAL} and {\bf C}. Any other value is assumed to mean {\bf FORTRAN}. {\bf GENTRANLANG!*} is always initialized to {\bf FORTRAN}. \subsection{Translation} \label{translation} \index{GENTRAN ! command} The {\bf GENTRAN} (GENerate/TRANslate) command is used to generate numerical code and also to translate code from algorithmic specifications in the REDUCE programming language to code in the target numerical language. Section~\ref{generation} explains code {\em generation}. This section explains code {\em translation}. A substantial subset of all expressions and statements in the REDUCE programming language can be translated directly into numerical code. The {\bf GENTRAN} command takes a REDUCE expression, statement, or procedure definition, and translates it into code in the target language. \begin{describe}{Syntax:} {\bf GENTRAN} {\it stmt} [ {\bf OUT} {\it f1,f2,\dots\ ,fn} ]{\it ;} \end{describe} \begin{describe}{Arguments:} {\it stmt} is any REDUCE expression, statement (simple, compound, or group), or procedure definition that can be translated by GENTRAN into the target language\footnote{See~\ref{appa} for a complete listing of REDUCE expressions and statements that can be translated.} {\it stmt} may contain any number of calls to the special functions {\bf EVAL}, {\bf DECLARE}, and {\bf LITERAL} (see sections~\ref{translation}~--~\ref{comments}). {\it f1,f2,\dots\ ,fn } is an optional argument list containing one or more {\it f}'s, where each {\it f} is one of: \par \begin{tabular}{lll} {\it an atom} &= &an output file\\ {\bf T} &= &the terminal\\ {\bf NIL} &= &the current output file(s)\\ \ttindex{ALL"!*} {\bf ALL!*} &= &all files currently open for output \\ & & by GENTRAN (see section~\ref{GENTRAN:output})\\ \end{tabular} \end{describe} \index{side effects} \begin{describe}{Side Effects:} {\bf GENTRAN} translates {\it stmt} into formatted code in the target language. If the optional part of the command is not given, generated code is simply written to the current output file. However, if it is given, then the current output file is temporarily overridden. Generated code is written to each file represented by {\it f1,f2,\dots\ ,fn} for this command only. Files which were open prior to the call to {\bf GENTRAN} will remain open after the call, and files which did not exist prior to the call will be created, opened, written to, and closed. The output stack will be exactly the same both before and after the call. \end{describe} \begin{describe}{Returned Value:} {\bf GENTRAN} returns the name(s) of the file(s) to which code was written. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) \end{verbatim} \begin{verbatim} ***** WRONG TYPE OF ARG \end{verbatim} exp \begin{verbatim} ***** CANNOT BE TRANSLATED \end{verbatim} \end{describe} \begin{describe}{\example\footnote{When the {\bf PERIOD} flag (default setting: ON) is turned on, all \ttindex{PERIOD} integers are automatically printed as real numbers except exponents, subscripts in subscripted variables, and index values in DO-type loops.}} \index{GENTRAN package ! example} \begin{verbatim} 1: GENTRANLANG!* := 'FORTRAN$ 2: GENTRAN 2: FOR I:=1:N DO 2: V(I) := 0$ DO 25001 I=1,N V(I)=0.0 25001 CONTINUE 3: GENTRANLANG!* := 'RATFOR$ 4: GENTRAN 4: FOR I:=1:N DO 4: FOR J:=I+1:N DO 4: << 4: X(J,I) := X(I,J); 4: Y(J,I) := Y(I,J) 4: >>$ DO I=1,N DO J=I+1,N { X(J,I)=X(I,J) Y(J,I)=Y(I,J) } 5: GENTRANLANG!* := 'C$ 6: GENTRAN 6: P := FOR I:=1:N PRODUCT I$ { P=1; for (I=1;I<=N;++I) P*=I; } 7: GENTRANLANG!* := 'PASCAL$ 8: GENTRAN 8: S := FOR I := 1:10 SUM V(I)$ BEGIN S:=0; FOR I:=1 TO 10 DO S:=S+V(I) END; \end{verbatim} \end{describe} \index{numeric code} Translation is a convenient method of producing numerical code when the exact behaviour of the resultant code is known. It gives the REDUCE user who is familiar with the syntax of statements in the REDUCE programming language the ability to write code in a numerical programming language without knowing the exact syntactical requirements of the language. However the {\em real} power of the {\bf GENTRAN} command lies in its ability to generate code: it can produce numerical code from symbolic expressions derived in REDUCE in addition to translating statements directly. This aspect is described in section~\ref{generation}. \subsection{Precision} \label{precision} \index{precision} \index{DOUBLE switch} By default {\bf GENTRAN} generates constants and type declarations in single precision form. If the user requires double precision output then the switch {\bf DOUBLE} must be set {\bf ON}. This does the following: \begin{itemize} \item Declarations of appropriate type are converted to their double precision counterparts. In FORTRAN and RATFOR this means that objects of type {\it REAL\/} are converted to objects of type {\it DOUBLE PRECISION\/} and objects of type {\it COMPLEX\/} are converted to {\it COMPLEX*16\/} \footnote{This is not part of the ANSI FORTRAN standard. Some compilers accept {\it DOUBLE COMPLEX\/} as well as, or instead of, {\it COMPLEX*16\/}, and some accept neither.}. \index{DOUBLE PRECISION} \index{COMPLEX} \index{COMPLEX*16} In C the counterpart of {\it float\/} is {\it double\/}, and of {\it int\/} is {\it long\/}. There is no complex data type and trying to translate complex objects causes an error. \item Similarly subprograms are given their correct type where appropriate. \item In FORTRAN and RATFOR {\it REAL\/} and {\it COMPLEX\/} numbers are printed with the correct double precision format. \item Intrinsic functions are converted to their double precision counterparts (e.g. in FORTRAN $SIN \rightarrow DSIN$ etc.). \end{itemize} \subsubsection{Intrinsic FORTRAN and RATFOR functions.} An attempt is made to convert the arguments of intrinsic functions to the correct type. For example: \begin{verbatim} 5: GENTRAN f:=sin(1)$ F=SIN(1.0) 6: GENTRAN f:=sin(x)$ F=SIN(REAL(X)) 7: GENTRAN DECLARE <<x:real>>$ 8: GENTRAN f:=sin(x)$ F=SIN(X) \end{verbatim} Which function is used to coerce the argument may, of course, depend on the setting of the switch {\bf DOUBLE}. \subsubsection{Number of printed floating point digits.} \index{PRECISION command} \index{PRINT"!-PRECISION command} To ensure the correct number of floating point digits are generated it may be necessary to use either the {\bf PRECISION} or {\bf PRINT!-PRECISION} commands. The former alters the number of digits REDUCE calculates, the latter only the number of digits REDUCE prints. Each takes an integer argument. It is not possible to set the printed precision higher than the actual precision. Calling {\bf PRINT!-PRECISION} with a negative argument causes the printed precision to revert to the actual precision. \begin{verbatim} 1: on rounded$ 2: precision 16$ 3: 1/3; 0.333 33333 33333 333 4: print!-precision 6$ 5: 1/3; 0.333333 6: print!-precision(-1)$ 7: 1/3; 0.333 33333 33333 333 \end{verbatim} \subsection{Code Generation: Evaluation Prior to Translation} \label{generation} Section~\ref{translation} showed how REDUCE statements and expressions can be translated directly into the target language. This section shows how to indicate that parts of those statements and expressions are to be handed to REDUCE to be evaluated before being translated. In other words, this section explains how to generate numerical code from algorithmic specifications (in the REDUCE programming language) and symbolic expressions. Each of the following four subsections describes a special function or operator that can be used to request partial or full evaluation of expressions prior to translation. Note that these functions and operators have the described effects {\it only} when applied to arguments to the {\bf GENTRAN} function and that evaluation is done in algebraic or symbolic mode, depending on the value of the REDUCE variable {\bf !*MODE}.\ttindex{"!*MODE} \subsubsection{The EVAL Function} \label{eval} \begin{describe}{Syntax:} {\bf EVAL} {\it exp} \end{describe} \ttindex{EVAL} \begin{describe}{Argument:} {\it exp} is any REDUCE expression or statement which, after evaluation by REDUCE, results in an expression that can be translated by GENTRAN into the target language. \end{describe} \begin{describe}{Side Effect:} When {\bf EVAL} is called on an expression which is to be translated, it tells {\bf GENTRAN} to give the expression to REDUCE for evaluation first, and then to translate the result of that evaluation. \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} The following formula, F, has been derived symbolically: \begin{verbatim} 2 2*X - 5*X + 6 \end{verbatim} We wish to generate an assignment statement for the quotient of F and its derivative. \begin{verbatim} 1: GENTRAN 1: Q := EVAL(F)/EVAL(DF(F,X))$ Q=(2.0*X**2-(5.0*X)+6.0)/(4.0*X-5.0) \end{verbatim} \end{describe} \subsubsection{The :=: Operator} \index{:=:} \label{rsetq} \index{GENTRAN ! preevaluation} \index{rsetq operator} In many applications, assignments must be generated in which the left-hand side is some known variable name, but the right-hand side is an expression that must be evaluated. For this reason, a special operator is provided to indicate that the expression on the right-hand side is to be evaluated prior to translation. This special operator is {\bf :=:} (i.e., the usual REDUCE assignment operator with an extra ``:'' on the right). \begin{describe}{\example} \index{GENTRAN package ! example} \begin{verbatim} 1: GENTRAN 1: DERIV :=: DF(X^4-X^3+2*x^2+1,X)$ DERIV=4.0*X**3-(3.0*X**2)+4.0*X \end{verbatim} \end{describe} Each built-in operator in REDUCE has an alternative alphanumeric identifier associated with it. Similarly, the GENTRAN {\bf :=:} operator has a special identifier associated with it: {\bf RSETQ} may be used \ttindex{RSETQ} interchangeably with {\bf :=:} on input. \subsubsection{The ::= Operator} \label{lsetq} \index{matrices ! in GENTRAN} When assignments to matrix or array elements must be generated, many times the indices of the element must be evaluated first. The special operator \index{::=} \index{lsetq operator} {\bf ::=} can be used within a call to {\bf GENTRAN} to indicate that the indices of the matrix or array element on the left-hand side of the assignment are to be evaluated prior to translation. (This is the usual REDUCE assignment operator with an extra ``:'' on the left.) \begin{describe}{\example}\index{GENTRAN package ! example} We wish to generate assignments which assign zeros to all elements on the main diagonal of M, an n x n matrix. \begin{verbatim} 10: FOR j := 1 : 8 DO 10: GENTRAN 10: M(j,j) ::= 0$ M(1,1)=0.0 M(2,2)=0.0 : : M(8,8)=0.0 \end{verbatim} \end{describe} {\bf LSETQ} may be used interchangeably with {\bf ::=} on input.\ttindex{LSETQ} \subsubsection{The ::=: Operator} \label{lrsetq} \index{::=:} \index{lrsetq operator} In applications in which evaluated expressions are to be assigned to array elements with evaluated subscripts, the {\bf ::=:} operator can be used. It is a combination of the {\bf ::=} and {\bf :=:} operators described in sections~\ref{rsetq} and ~\ref{lsetq}. \index{matrices ! in GENTRAN} \newpage \begin{describe}{\example}\index{GENTRAN package ! example} The following matrix, M, has been derived symbolically: \begin{verbatim} ( A 0 -1 1) ( ) ( 0 B 0 0) ( ) ( -1 0 C -1) ( ) ( 1 0 -1 D) \end{verbatim} We wish to generate assignment statements for those elements on the main diagonal of the matrix. \begin{verbatim} 10: FOR j := 1 : 4 DO 10: GENTRAN 10: M(j,j) ::=: M(j,j)$ M(1,1)=A M(2,2)=B M(3,3)=C M(4,4)=D \end{verbatim} \end{describe} The alternative alphanumeric identifier associated with {\bf ::=:} is {\bf LRSETQ}.\ttindex{LRSETQ} \subsection{Explicit Type Declarations} \label{explicit:type} Type declarations are automatically generated each time a subprogram heading is generated. Type declarations are constructed from information stored in the GENTRAN symbol table. The user can place entries into the symbol table explicitly through calls to the special GENTRAN function {\bf DECLARE}. \index{DECLARE function} \begin{describe}{Syntax:} {\bf \ \ DECLARE} {\it v1,v2,\dots\ ,vn} {\bf :} {\it type;} or \begin{tabular}{ll} {\bf DECLARE}\\ {\bf $<$$<$}\\ &{\it v11,v12,\dots\ ,v1n} {\bf :} {\it type1;}\\ &{\it v21,v22,\dots\ ,v2n} {\bf :} {\it type2;}\\ & :\\ & :\\ &{\it vn1,vnn,\dots\ ,vnn} {\bf :} {\it typen;}\\ {\bf $>$$>$}{\it ;} \end{tabular} \end{describe} \begin{describe}{Arguments:} Each {\it v1,v2,\dots\ ,vn} is a list of one or more variables (optionally subscripted to indicate array dimensions), or variable ranges (two letters separated by a ``-''). {\it v}'s are not evaluated unless given as arguments to {\bf EVAL}. Each {\it type} is a variable type in the target language. Each must be an atom, optionally preceded by the atom {\bf IMPLICIT}. \index{IMPLICIT option} {\it type}'s are not evaluated unless given as arguments to {\bf EVAL}. \end{describe} \begin{describe}{Side Effect:} Entries are placed in the symbol table for each variable or variable range declared in the call to this function. The function call itself is removed from the statement group being translated. Then after translation, type declarations are generated from these symbol table entries before the resulting executable statements are printed. \end{describe} \begin{describe}{Diagnostic Message:} \begin{verbatim} ***** INVALID SYNTAX \end{verbatim} \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: GENTRAN 1: << 1: DECLARE 1: << 1: A-H, O-Z : IMPLICIT REAL; 1: M(4,4) : INTEGER 1: >>; 1: FOR I:=1:4 DO 1: FOR J:=1:4 DO 1: IF I=J 1: THEN M(I,J):=1 1: ELSE M(I,J):=0; 1: DECLARE I, J : INTEGER; 1: >>$ IMPLICIT REAL (A-H,O-Z) INTEGER M(4,4),I,J DO 25001 I=1,4 DO 25002 J=1,4 IF (I.EQ.J) THEN M(I,J)=1.0 ELSE M(I,J)=0.0 ENDIF 25002 CONTINUE 25001 CONTINUE \end{verbatim} \end{describe} The {\bf DECLARE} statement can also be used to declare subprogram types (i.e. {\bf SUBROUTINE} or {\bf FUNCTION}) for \index{SUBROUTINE} \index{FUNCTION} FORTRAN and RATFOR code, and function types for all four languages. \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: GENTRANLANG!* := 'RATFOR$ 2: GENTRAN 2: PROCEDURE FAC N; 2: BEGIN 2: DECLARE 2: << 2: FAC : FUNCTION; 2: FAC, N : INTEGER 2: >>; 2: F := FOR I:=1:N PRODUCT I; 2: DECLARE F, I : INTEGER; 2: RETURN F 2: END$ INTEGER FUNCTION FAC(N) INTEGER N,F,I { F=1 DO I=1,N F=F*I } RETURN(F) END 3: GENTRANLANG!* := 'C$ 4: GENTRAN 4: PROCEDURE FAC N; 4: BEGIN 4: DECLARE FAC, N, I, F : INTEGER; 4: F := FOR I:=1:N PRODUCT I; 4: RETURN F 4: END$ int FAC(N) int N; { int I,F; { F=1; for (I=1;I<=N;++I) F*=I; } return(F); } \end{verbatim} \end{describe} When generating code for subscripted variables (i.e., matrix and array elements), it is important to keep several things in mind. First of all, when a REDUCE array is declared with a declaration such as \index{ARRAY} \begin{center} {\bf ARRAY A(}{\it n}{\bf )\$} \end{center} where {\it n} is a positive integer, {\bf A} is actually being declared to be of size {\bf n}+1. Each of the elements {\bf A(0), A(1), \dots\ , A(n)} can be used. However, a FORTRAN or RATFOR declaration such as \begin{center} {\bf DIMENSION A(}{\it n}{\bf )} \end{center} declares {\bf A} only to be of size {\bf n}. Only the elements {\bf A(1), A(2), \dots\ , A(n)} can be used. Furthermore, a C declaration such as \begin{center} {\bf float A[}{\it n}{\bf ];} \end{center} declares {\bf A} to be of size {\bf n} with elements referred to as {\bf A[0], A[1], \dots\ , A[}{\it n-1}{\bf ]}. To resolve these array size and subscripting conflicts, the user should remember the following: \index{subscripts ! in GENTRAN} \begin{itemize} \item {\it All REDUCE array subscripts are translated literally.} Therefore it is the user's responsibility to be sure that array elements with subscript 0 are not translated into FORTRAN or RATFOR. \item Since C and PASCAL arrays allow elements with a subscript of 0, when an array is declared to be of size {\it n} by the user, {\it the actual generated type declaration will be of size n+1} so that the user can translate elements with subscripts from 0, and up to and including {\it n}. \end{itemize} \subsection{Implicit Type Declarations} \label{implicit:type} \index{GETDECS switch} Some type declarations can be made automatically if the switch {\bf GETDECS} is {\bf ON}. In this case: \begin{enumerate} \item The indices of loops are automatically declared to be integers. \index{loop indices ! in GENTRAN} \item There is a global variable {\bf DEFTYPE!*}, which is the default type given to objects. Subprograms, their parameters, and local scalar objects are automatically assigned this type. \ttindex{DEFTYPE"!*} \index{REAL*8} \index{DOUBLE PRECISION} Note that types such as REAL*8 or DOUBLE PRECISION should not be used as, if {\bf DOUBLE} is on, then a default type of REAL will in fact be DOUBLE PRECISION anyway. \item If GENTRAN is used to translate a REDUCE procedure, then it assigns objects declared {\bf SCALAR} the type given by {\bf DEFTYPE!*}. Note that \index{INTEGER declaration} \index{REAL declaration} it is legal to use the commands {\bf INTEGER} and {\bf REAL} in the place of {\bf SCALAR}, which allows the user to specify an actual type. The procedure may also be given a return type, in which case that is used as the default. For example: \begin{verbatim} 2: on getdecs,gendecs$ 3: GENTRAN 3: real procedure f(x); 3: begin integer n;real y; 3: n := 4; 3: y := n/(1+x)^2; 3: return y; 3: end; REAL FUNCTION F(X) INTEGER N REAL X,Y N=4 Y=N/(1.0+X)**2 F=Y RETURN END \end{verbatim} \end{enumerate} \subsection{More about Type Declarations} \label{more:type} A check is made on output to ensure that all types generated are legal ones. This is necessary since {\bf DEFTYPE!*} can be set to anything. Note that {\bf DEFTYPE!*} ought normally to be given a simple type as its \ttindex{DEFTYPE"!*} value, such as REAL, INTEGER, or COMPLEX, since this will always be translated into the corresponding type in the target language on output. An entry is removed from the symbol table once a declaration has been generated for it. The {\bf KEEPDECS} switch (by default {\bf OFF}) disables this, allowing a user to check the types of objects \index{KEEPDECS switch} which GENTRAN has generated (useful if they are being generated automatically) \subsection{Comments and Literal Strings} \label{comments} \index{comments ! in GENTRAN} Comments and other strings of characters can be inserted directly into the stream of generated code through a call to the special function {\bf LITERAL}. \begin{describe}{Syntax:} {\bf LITERAL} {\it arg1,arg2,\dots\ ,argn;} \end{describe} \begin{describe}{Arguments:} {\it arg1,arg2,\dots\ ,argn} is an argument list containing one or more {\it arg}'s, where each {\it arg} either is, or evaluates to, an atom. The \ttindex{TAB"!*} \ttindex{CR"!*} atoms {\bf TAB!*} and {\bf CR!*} have special meanings. {\it arg}'s are not evaluated unless given as arguments to {\bf EVAL}. \end{describe} \begin{describe}{Side Effect:} This statement is replaced by the character sequence resulting from concatenation of the given atoms. Double quotes are stripped from all string type {\it arg}'s, and the reserved atoms {\bf TAB!*} and {\bf CR!*} are replaced by a tab to the current level of indentation, and an end-of-line character, respectively. \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} Suppose N has value 10. \begin{verbatim} 1: GENTRANLANG!* := 'FORTRAN$ 2: GENTRAN 2: << 2: LITERAL 2: "C",TAB!*,"--THIS IS A FORTRAN COMMENT--",CR!*, 2: "C",CR!*; 2: LITERAL 2: TAB!*,"DATA N/",EVAL(N),"/",CR!* 2: >>$ C --THIS IS A FORTRAN COMMENT-- C DATA N/10/ 3: GENTRANLANG!* := 'RATFOR$ 4: GENTRAN 4: FOR I:=1:N DO 4: << 4: LITERAL 4: TAB!*,"# THIS IS A RATFOR COMMENT",CR!*; 4: LITERAL 4: TAB!*,"WRITE(6,10) (M(I,J),J=1,N)",CR!*, 4: 10,TAB!*,"FORMAT(1X,10(I5,3X))",CR!* 4: >>$ DO I=1,N { # THIS IS A RATFOR COMMENT WRITE(6,10) (M(I,J),J=1,N) 10 FORMAT(1X,10(I5,3X)) } 5: GENTRANLANG!* := 'C$ 6: GENTRAN 6: << 6: X:=0; 6: LITERAL "/* THIS IS A",CR!*, 6: " C COMMENT */",CR!* 6: >>$ { X=0.0; /* THIS IS A C COMMENT */ } 7: GENTRANLANG!* := 'PASCAL$ 8: GENTRAN 8: << 8: X := SIN(Y); 8: LITERAL "{ THIS IS A PASCAL COMMENT }", CR!* 8: >>$ BEGIN X:=SIN(Y) { THIS IS A PASCAL COMMENT } END; \end{verbatim} \end{describe} \subsection{Expression Segmentation} \label{segmentation} \index{segmenting expressions} Symbolic derivations can easily produce formulas that can be anywhere from a few lines to several pages in length. Such formulas can be translated into numerical assignment statements, but unless they are broken into smaller pieces they may be too long for a compiler to handle. (The maximum number of continuation lines for one statement allowed by most FORTRAN compilers is only 19.) Therefore GENTRAN \index{continuation lines} contains a segmentation facility which automatically {\it segments}, or breaks down unreasonably large expressions. The segmentation facility generates a sequence of assignment statements, each of which assigns a subexpression to an automatically generated temporary variable. This sequence is generated in such a way that temporary variables are re-used as soon as possible, thereby keeping the number of automatically generated variables to a minimum. The facility can be turned on or off by setting the mode \index{GENTRANSEG switch} switch {\bf GENTRANSEG} accordingly (i.e., by calling the REDUCE function {\bf ON} or {\bf OFF} on it). The user can control the maximum allowable expression size by setting the \ttindex{MAXEXPPRINTLEN"!*} variable {\bf MAXEXPPRINTLEN!*} to the maximum number of characters allowed in an expression printed in the target language (excluding spaces automatically printed by the formatter). The {\bf GENTRANSEG} switch is on initially, and {\bf MAXEXPPRINTLEN!*} is initialized to 800. \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: ON EXP$ 2: JUNK1 := (A+B+C+D)^2$ 3: MAXEXPPRINTLEN!* := 24$ 4: GENTRAN VAL :=: JUNK1$ T0=A**2+2.0*A*B T0=T0+2.0*A*C+2.0*A*D T0=T0+B**2+2.0*B*C T0=T0+2.0*B*D+C**2 VAL=T0+2.0*C*D+D**2 5: JUNK2 := JUNK1/(E+F+G)$ 6: MAXEXPPRINTLEN!* := 23$ 7: GENTRANLANG!* := 'C$ 8: GENTRAN VAL :=: JUNK2$ { T0=power(A,2)+2.0*A*B; T0+=2.0*A*C; T0=T0+2.0*A*D+power(B,2); T0+=2.0*B*C; T0=T0+2.0*B*D+power(C,2); T0=T0+2.0*C*D+power(D,2); VAL=T0/(exp(1.0)+F+G); } \end{verbatim} \end{describe} \subsubsection{Implicit Type Declarations}\label{GENTRAN:itd} When the segmentation routine generates temporary variables, it places type declarations in the symbol table for those variables if possible. It uses the following rules to determine their type: \index{implicit type declarations} \index{temporary variables ! type} \begin{itemize} \item[{(1)}] If the type of the variable to which the large expression is being assigned is already known (i.e., has been declared by the user), then the temporary variables will be declared to be of that same type. \item[{(2)}] \ttindex{TEMPVARTYPE"!*} If the global variable {\bf TEMPVARTYPE!*} has a non-NIL value, then the temporary variables are declared to be of that type. \item[{(3)}] Otherwise, the variables are not declared. \end{itemize} \newpage \begin{describe}{\example} \index{GENTRAN package ! example} \begin{verbatim} 1: MAXEXPPRINTLEN!* := 20$ 2: TEMPVARTYPE!* := 'REAL$ 3: GENTRAN 3: << 3: DECLARE ISUM : INTEGER; 3: ISUM := II+JJ+2*KK+LL+10*MM+NN; 3: PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2) 3: >>$ INTEGER ISUM,T0 REAL T1 T0=II+JJ+2.0*KK+LL ISUM=T0+10.0*MM+NN T1=V(X,Y)*SIN(X)*COS(Y**2) PROD=T1*(X+Y+Z**2) \end{verbatim} \end{describe} \subsection{Generation of Temporary Variable Names} \label{tempvars} \index{temporary variables ! names} As we have just seen, GENTRAN's segmentation module generates temporary variables and places type declarations in the symbol table for them whenever possible. Various other modules also generate variables and corresponding declarations. All of these modules call one special GENTRAN function each time they need a temporary variable name. This function is {\bf TEMPVAR}. There are situations in which it may be convenient for the user to be able to generate temporary variable names directly.\footnote{One such example is suppression of the simplification process to generate numerical code which is more efficient. See the example in section~\ref{tempvar:example} on page~\pageref{tempvar:example}.} Therefore {\bf TEMPVAR} \ttindex{TEMPVAR} is a user-accessible function which may be called from both the algebraic and symbolic modes of REDUCE. \begin{describe}{Syntax:} {\bf TEMPVAR} {\it type} \end{describe} \begin{describe}{Argument:} {\it type} is an atom which either indicates the variable type in the target language (INTEGER, REAL, etc.), or is {\bf NIL} if the variable type is unknown. \end{describe} \begin{describe}{Side Effects:} {\bf TEMPVAR} creates temporary variable names by repeatedly concatenating the values of the global variables {\bf TEMPVARNAME!*} (which has a \ttindex{TEMPVARNUM"!*} default value of {\bf T}) and {\bf TEMPVARNUM!*} (which is initially set to 0) and incrementing {\bf TEMPVARNUM!*} until a variable name is created which satisfies one of the following conditions: \begin{itemize} \item[{(1)}] It was not generated previously, and it has not been declared by the user. \item[{(2)}] It was previously generated to hold the same type of value that it must hold this time (e.g. INTEGER, REAL, etc.), and the value assigned to it previously is no longer needed. \end{itemize} If {\it type} is a non-NIL argument, or if {\it type} is {\bf NIL} and the global variable {\bf TEMPVARTYPE!*} (initially NIL) has been \ttindex{TEMPVARTYPE"!*} set to a non-NIL value, then a type entry for the generated variable name is placed in the symbol table. \end{describe} \begin{describe}{Returned Value:} {\bf TEMPVAR} returns an atom which can be used as a variable. \end{describe} Note: It is the user's responsibility to set {\bf TEMPVARNAME!*} and {\bf TEMPVARNUM!*} to values such that generated variable names will not clash with variables used elsewhere in the program unless those variables have been declared. \subsubsection{Marking Temporary Variables} In section~\ref{tempvars} we saw that a temporary variable name (of a certain type) can be regenerated when the value previously assigned to it is no longer needed. This section describes a function which {\it marks} a variable to indicate that it currently holds a significant value, and the next section describes functions which {\it unmark} variables to indicate that the values they hold are no \index{temporary variables ! marking} \index{marking temporary variables} longer significant.\ttindex{MARKVAR} \begin{describe}{Syntax:} {\bf MARKVAR} {\it var} \end{describe} \begin{describe}{Argument:} {\it var} is an atom. \end{describe} \begin{describe}{Side Effects:} {\bf MARKVAR} sets a flag on {\it var}'s property list to indicate that {\it var} currently holds a significant value. \end{describe} \begin{describe}{Returned Value:} {\bf MARKVAR} returns {\it var}. \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} The following matrix, M has been derived symbolically: \begin{verbatim} (X*(Y+Z) 0 X*Z) ( ) ( -X X+Y 0) ( ) ( X*Z 0 Z**2) \end{verbatim} We wish to replace each non-zero element by a generated variable name to prevent these expressions from being resubstituted into further calculations. (We will also record these substitutions in the numerical program we are constructing by generating assignment statements.)\footnote{ Note: {\bf MARKVAR} is a symbolic mode procedure. Therefore, the name of each variable whose value is to be passed to it from algebraic mode must appear in a {\bf SHARE} \index{SHARE command} declaration. This tells REDUCE to share the variable's value between algebraic and symbolic modes.} \begin{verbatim} 9: SHARE var$ 10: FOR j := 1 : 3 DO 10: FOR k := 1 : 3 DO 10: IF M(j,k) NEQ 0 THEN 10: << 10: var := TEMPVAR(NIL); 10: MARKVAR var; 10: GENTRAN 10: EVAL(var) :=: M(j,k); 10: M(j,k) := var 10: >>$ T0=X*(Y+Z) T1=X*Z T2=-X T3=X+Y T4=X*Z T5=Z**2 \end{verbatim} Now matrix M contains the following entries: \begin{verbatim} (T0 0 T1) ( ) (T2 T3 0) ( ) (T4 0 T5) \end{verbatim} \end{describe} \subsubsection{Unmarking Temporary Variables} \index{unmarking temporary variables} \index{temporary variables ! unmarking} After the value assigned to a temporary variable has been used in the numerical program and is no longer needed, the variable name can be \ \ttindex{UNMARKVAR} {\it unmarked} with the {\bf UNMARKVAR} function. \begin{describe}{Syntax:} {\bf UNMARKVAR} {\it var;} \end{describe} \begin{describe}{Argument:} {\it var} is an atom (variable name) or an expression containing one or more variable names. \end{describe} \begin{describe}{Side Effect:} {\bf UNMARKVAR} resets flags on the property lists of all variable names in {\it var} to indicate that they do not hold significant values any longer. \end{describe} \subsection{Enabling and Disabling Generation of Type Declarations} \label{control:type} GENTRAN maintains a symbol table of variable type and dimension information. It adds information to the symbol table by processing user-supplied calls to the {\bf DECLARE} function (see Section~\ref{explicit:type}) and as a side effect of generating temporary variable names (see Sections~\ref{segmentation} and \ref{tempvars}). All information is stored in the symbol table until GENTRAN is ready to print formatted numerical code. Since programming languages such as FORTRAN require that type declarations appear before executable statements, GENTRAN automatically extracts all relevant type information and prints it in the form of type declarations before printing executable statements. This feature is useful when the entire body of a (sub)program is generated at one time: in this case, type declarations are printed before any executable code. However, if the user chooses to generate code in pieces, the resulting code may have type declarations interleaved \index{GENDECS switch} with executable code. For this reason, the user may turn the {\bf GENDECS} mode switch on or off, depending on whether or not s/he chooses to use this feature. In the following we re-examine the example of Section~\ref{GENTRAN:itd}. \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: MAXEXPPRINTLEN!* := 20$ 2: TEMPVARTYPE!* := 'REAL!*8$ 3: GENTRAN 3: << 3: DECLARE ISUM : INTEGER; 3: ISUM := II+JJ+2*KK+LL+10*MM+NN 3: >>$ INTEGER ISUM,T0 T0=II+JJ+2*KK+LL ISUM=T0+10*MM+NN 4: GENTRAN PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2)$ REAL*8 T2 T2=V(X,Y)*SIN(REAL(X))*COS(REAL(Y**2)) PROD=T2*(X+Y+Z**2) 5: OFF GENDECS$ 6: GENTRAN 6: << 6: DECLARE ISUM : INTEGER; 6: ISUM := II+JJ+2*KK+LL+10*MM+NN 6: >>$ T0=II+JJ+2*KK+LL ISUM=T0+10*MM+NN 7: GENTRAN PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2)$ T2=V(X,Y)*SIN(REAL(X))*COS(REAL(Y**2)) PROD=T2*(X+Y+Z**2) \end{verbatim} \end{describe} In Section~\ref{template:type} we will explain how to further control the generation of type declarations. \subsection{Complex Numbers} \label{complex} \index{complex numbers} \index{COMPLEX} With the switch {\bf COMPLEX} set {\bf ON}, GENTRAN will generate the correct representation for a complex number in the given precision provided that: \begin{enumerate} \item The current language supports a complex data type (if it doesn't then an error results); \item The complex quantity is evaluated by REDUCE to give an object of the correct domain; i.e. \begin{verbatim} GENTRAN x:=: 1+i; GENTRAN x:= eval 1+i; z := 1+i; GENTRAN x:=: z; \end{verbatim} will all generate the correct result, as will their Symbolic mode equivalents, while: \begin{verbatim} GENTRAN x := 1+i; \end{verbatim} will not. \end{enumerate} \subsection{Intrinsic Functions} \label{intrinsic} \index{intrinsic functions} A warning is issued if a standard REDUCE function is encountered which does not have an intrinsic counterpart in the target language (e.g. {\it cot\/}, {\it sec\/} etc.). Output is not halted in case this is a user--supplied function, either via a REDUCE definition or within a GENTRAN template. The types of intrinsic FORTRAN functions are coerced to reals (in the correct precision) as the following examples demonstrate: \begin{verbatim} 19: GENTRAN x:=sin(0)$ X=SIN(0.0) 20: GENTRAN x:=cos(A)$ X=COS(REAL(A)) 21: ON DOUBLE$ 22: GENTRAN x := log(1)$ X=DLOG(1.0D0) 23: GENTRAN x := exp(B)$ X=DEXP(DBLE(B)) 24: GENTRAN DECLARE <<b:real>>$ 25: GENTRAN x := exp(B)$ X=DEXP(B) \end{verbatim} \subsection{Miscellaneous} \subsubsection{MAKECALLS} A statement like: \begin{verbatim} GENTRAN x^2+1$ \end{verbatim} will yield the result: \begin{verbatim} X**2+1 \end{verbatim} but, under normal circumstances, a statement like: \begin{verbatim} GENTRAN sin(x)$ \end{verbatim} will yield the result: \begin{verbatim} CALL SIN(X) \end{verbatim} \index{MAKECALLS switch} The switch {\bf MAKECALLS} (OFF by default) will make GENTRAN yield \begin{verbatim} SIN(X) \end{verbatim} This is useful if you don't know in advance what the form of the expression which you are translating is going to be. \subsubsection{E} \index{e} \index{EXP} When GENTRAN encounters $e$ it translates it into EXP(1), and when GENTRAN encounters $e^x$ it is translated to EXP(X). This is then translated into the correct statement in the given language and precision. Note that it is still possible to do something like: \begin{verbatim} GENTRAN e:=:e; \end{verbatim} and get the correct result. \section{Template Processing}\label{GENTRAN:template} \index{GENTRAN ! templates} \index{templates !} \index{code templates} In some code generation applications pieces of the target numerical program are known in advance. A {\it template} file containing a program outline is supplied by the user, and formulas are derived in REDUCE, converted to numerical code, and inserted in the corresponding places in the program outline to form a complete numerical program. A template processor is provided by GENTRAN for use in these applications. \subsection{The Template Processing Command} \label{templates} \index{GENTRANIN command} \begin{describe}{Syntax:} {\bf GENTRANIN} {\it f1,f2,\dots\ ,fm} [{\bf OUT} {\it f1,f2,\dots\ ,fn\/}]{\it ;} \end{describe} \begin{describe}{Arguments:} {\it f1,f2,\dots\ ,fm\/} is an argument list containing one or more {\it f\/}'s, where each {\it f\/} is one of: \begin{center} \begin{tabular}{lll} {\it an atom}& = &a template (input) file\\ {\bf T}& = &the terminal\\ \end{tabular} \end{center} {\it f1,f2,\dots\ ,fn\/} is an optional argument list containing one or more {\it f\/}'s, where each {\it f\/} is one of: \begin{center} \begin{tabular}{lll} {\it an atom}& = &an output file\\ {\bf T}& = &the terminal\\ {\bf NIL}& = &the current output file(s)\\ {\bf ALL!*}& = &all files currently open for output \\ & & by GENTRAN (see section~\ref{GENTRAN:output}) \\ \end{tabular} \end{center} \end{describe} \begin{describe}{Side Effects:} {\bf GENTRANIN} processes each template file {\it f1,f2,\dots\ ,fm} sequentially. A template file may contain any number of parts, each of which is either an active or an inactive part. All active parts start with the character sequence {\bf ;BEGIN;} and end with {\bf ;END;}. The end of the template file is indicated by an extra {\bf ;END;} character sequence. \index{;BEGIN; marker} \index{;END; marker} Inactive parts of template files are assumed to contain code in the target language (FORTRAN, RATFOR, PASCAL or C, depending on the value \ttindex{GENTRANLANG"!*} of the global variable {\bf GENTRANLANG!*}). All inactive parts are copied to the output. Comments delimited by the appropriate characters, \index{comments ! in GENTRAN} \begin{center} \begin{tabular}{lll} &{\bf C} \dots\ $<$cr$>$ & FORTRAN (beginning in column 1)\\ &{\bf \#} \dots\ $<$cr$>$ & RATFOR \\ &{\bf /*} \dots\ {\bf */} & C \\ &{\bf \{} \dots\ {\bf \}} or {\bf *(} \dots\ {\bf )*} & PASCAL\\ \end{tabular} \end{center} are also copied in their entirety to the output. Thus the character sequences {\bf ;BEGIN;} and {\bf ;END;} have no special meanings within comments. Active parts may contain any number of REDUCE expressions, statements, and commands. They are not copied directly to the output. Instead, they are given to REDUCE for evaluation in algebraic mode\footnote{ Active parts are evaluated in algebraic mode unless the mode is explicitly changed to symbolic from within the active part itself. This is true no matter which mode the system was in when the template processor was called.}. All output generated by each evaluation is sent to the output file(s). Returned values are only printed on the terminal.\index{GENTRAN ! preevaluation} Active parts will most likely contain calls to {\bf GENTRAN} to generate code. This means that the result of processing a template file will be the original template file with all active parts replaced by generated code. If {\bf OUT} {\it f1,f2,\dots\ ,fn} is not given, generated code is simply written to the current-output file. However, if {\bf OUT} {\it f1,f2,\dots\ ,fn} is given, then the current-output file is temporarily overridden. Generated code is written to each file represented by {\it f1,f2,\dots\ ,fn} for this command only. Files which were open prior to the call to {\bf GENTRANIN} will remain open after the call, and files which did not exist prior to the call will be created, opened, written to, and closed. The output-stack will be exactly the same both before and after the call. \end{describe} \begin{describe}{Returned Value:} {\bf GENTRANIN} returns the names of all files written to by this command. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** NONEXISTENT INPUT FILE ***** TEMPLATE FILE ALREADY OPEN FOR INPUT ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} Suppose we wish to generate a FORTRAN subprogram to compute the determinant of a 3 x 3 matrix. We can construct a template file with an outline of the FORTRAN subprogram and REDUCE and GENTRAN commands to fill it in: \index{matrices ! in GENTRAN} Contents of file {\tt det.tem}: \end{describe} \begin{framedverbatim} REAL FUNCTION DET(M) REAL M(3,3) ;BEGIN; OPERATOR M$ MATRIX MM(3,3)$ MM := MAT( (M(1,1),M(1,2),M(1,3)), (M(2,1),M(2,2),M(2,3)), (M(3,1),M(3,2),M(3,3)) )$ GENTRAN DET :=: DET(MM)$ ;END; RETURN END ;END; \end{framedverbatim} \begin{describe}{} Now we can generate a FORTRAN subprogram with the following REDUCE session: \begin{verbatim} 1: GENTRANLANG!* := 'FORTRAN$ 2: GENTRANIN 2: "det.tem" 2: OUT "det.f"$ \end{verbatim} Contents of file det.f: \end{describe} \begin{framedverbatim} REAL FUNCTION DET(M) REAL M(3,3) DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2) . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1 . ,2)-(M(3,1)*M(2,2)*M(1,3)) RETURN END \end{framedverbatim} \subsection{Copying Files into Template Files} \label{copy:template} \index{GENTRANIN command} \index{files ! in GENTRAN} Template files can be copied into other template files with recursive calls to {\bf GENTRANIN} ; i.e., by calling {\bf GENTRANIN} from the active part of a template file. For example, suppose we wish to copy the contents of a file containing a subprogram into a file containing a main program. We will call {\bf GENTRANIN} to do the copying, so the subprogram file must have {\bf ;END;} on its last line: Contents of file {\tt det.tem}: \begin{framedverbatim} REAL FUNCTION DET(M) REAL M(3,3) DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2) . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1 . ,2)-(M(3,1)*M(2,2)*M(1,3)) RETURN END ;END; \end{framedverbatim} Now the template file for the main program can be constructed with an active part which will include file det.tem: Contents of file {\tt main.tem}: \begin{framedverbatim} C C MAIN PROGRAM C REAL M(3,3),DET WRITE(6,*) 'ENTER 3 x 3 MATRIX' DO 100 I=1,3 READ(5,*) (M(I,J),J=1,3) 100 CONTINUE WRITE(6,*) ' DET = ', DET(M) STOP END C C DETERMINANT CALCULATION C ;BEGIN; GENTRANIN "det.tem"$ ;END; ;END; \end{framedverbatim} The following REDUCE session will create the file {\tt main.f}: \begin{verbatim} 1: GENTRANIN 1: "main.tem" 1: OUT "main.f"$ \end{verbatim} Contents of file {\tt main.f}: \begin{framedverbatim} C C MAIN PROGRAM C REAL M(3,3),DET WRITE(6,*) 'ENTER 3 x 3 MATRIX' DO 100 I=1,3 READ(5,*) (M(I,J),J=1,3) 100 CONTINUE WRITE(6,*) ' DET = ', DET(M) STOP END C C DETERMINANT CALCULATION C REAL FUNCTION DET(M) REAL M(3,3) DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2) . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)* . M(1,2)-(M(3,1)*M(2,2)*M(1,3)) RETURN END \end{framedverbatim} \subsection{The Template File Stack} \label{template:stack} \index{templates ! file stack} The REDUCE {\bf IN} command takes one or more file names as arguments. REDUCE reads each of the given files and executes all statements and commands, any of which may be another {\bf IN} command. A stack of input file names is maintained by REDUCE to allow recursive invocation of the {\bf IN} command. Similarly, a stack of template file names is maintained by GENTRAN to facilitate recursive invocation of the template processor. Section~\ref{copy:template} showed that the {\bf GENTRANIN} command can be \index{GENTRANIN command} called recursively to copy files into other files. This section shows that template files which are copied into other template files can also contain active parts, and thus the whole code generation process can be invoked recursively. We can generalize the example of section~\ref{copy:template} by generating code recursively. We can extend it to generate code which will compute entries of the inverse matrix, also. Suppose we have created the file init.red, which contains REDUCE commands to create an {\it n}x{\it n} matrix MM and initialize its entries to M(1,1), M(1,2),~\dots~, M({\it n}, {\it n}), for some user-entered value of {\it n}: Contents of file {\tt init.red}: \begin{framedverbatim} OPERATOR M$ MATRIX MM(n,n)$ FOR J := 1 : n DO FOR K := 1 : n DO MM(J,K) := M(J,K)$ END$ \end{framedverbatim} We have also created template files {\tt det.tem} and {\tt inv.tem} which contain outlines of FORTRAN subprograms to compute the determinant and inverse of an {\it n}x{\it n} matrix, respectively: Contents of file {\tt det.tem}: \begin{framedverbatim} REAL FUNCTION DET(M) ;BEGIN; GENTRAN << DECLARE M(EVAL(n),EVAL(n)) : REAL; DET :=: DET(MM) >>$ ;END; RETURN END ;END; \end{framedverbatim} Contents of file {\tt inv.tem}: \begin{framedverbatim} SUBROUTINE INV(M,MINV) ;BEGIN; GENTRAN << DECLARE M(EVAL(n),EVAL(n)), MINV(EVAL(n),EVAL(n)) : REAL; MINV :=: MM^(-1) >>$ ;END; RETURN END ;END; \end{framedverbatim} Now we can construct a template file with a generalized version of the main program given in section~\ref{copy:template} and can place {\bf GENTRANIN} commands in this file to generate code recursively from the template files det.tem and inv.tem: Contents of file {\tt main.tem}: \begin{framedverbatim} C C MAIN PROGRAM C ;BEGIN; GENTRAN << DECLARE << M(EVAL(n),EVAL(n)), DET, MINV(EVAL(n),EVAL(n)) : REAL; N : INTEGER >>; LITERAL TAB!*, "DATA N/", EVAL(n), "/", CR!* >>$ ;END; WRITE(6,*) 'ENTER ', N, 'x', N, ' MATRIX' DO 100 I=1,N READ(5,*) (M(I,J),J=1,N) 100 CONTINUE WRITE(6,*) ' DET = ', DET(M) WRITE(6,*) ' INVERSE MATRIX:' CALL INV(M,MINV) DO 200 I=1,N WRITE(6,*) (MINV(I,J),J=1,N) 200 CONTINUE STOP END C C DETERMINANT CALCULATION C ;BEGIN; GENTRANIN "det.tem"$ ;END; C C INVERSE CALCULATION C ;BEGIN; GENTRANIN "inv.tem"$ ;END; ;END; \end{framedverbatim} The following REDUCE session will create the file {\tt main.f}: \begin{verbatim} 1: n := 3$ 2: IN "init.red"$ 3: GENTRANLANG!* := 'FORTRAN$ 4: GENTRANIN 4: "main.tem" 4: OUT "main.f"$ \end{verbatim} Contents of file {\tt main.f}: \begin{framedverbatim} C C MAIN PROGRAM C REAL M(3,3),DET,MINV(3,3) INTEGER N DATA N/3/ WRITE(6,*) 'ENTER ', N, 'x', N, ' MATRIX' DO 100 I=1,N READ(5,*) (M(I,J),J=1,N) 100 CONTINUE WRITE(6,*) ' DET = ', DET(M) WRITE(6,*) ' INVERSE MATRIX:' CALL INV(M,MINV) DO 200 I=1,N WRITE(6,*) (MINV(I,J),J=1,N) 200 CONTINUE STOP END C C DETERMINANT CALCULATION C REAL FUNCTION DET(M) REAL M(3,3) DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2) . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3) . *M(1,2)-(M(3,1)*M(2,2)*M(1,3)) RETURN END C C INVERSE CALCULATION C SUBROUTINE INV(M,MINV) REAL M(3,3),MINV(3,3) MINV(1,1)=(M(3,3)*M(2,2)-(M(3,2)*M(2,3)))/(M(3,3)*M(2,2 . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)) . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2 . ,2)*M(1,3))) MINV(1,2)=(-(M(3,3)*M(1,2))+M(3,2)*M(1,3))/(M(3,3)*M(2, . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1) . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M( . 2,2)*M(1,3))) MINV(1,3)=(M(2,3)*M(1,2)-(M(2,2)*M(1,3)))/(M(3,3)*M(2,2 . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)) . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2 . ,2)*M(1,3))) MINV(2,1)=(-(M(3,3)*M(2,1))+M(3,1)*M(2,3))/(M(3,3)*M(2, . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1) . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M( . 2,2)*M(1,3))) MINV(2,2)=(M(3,3)*M(1,1)-(M(3,1)*M(1,3)))/(M(3,3)*M(2,2 . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)) . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2 . ,2)*M(1,3))) MINV(2,3)=(-(M(2,3)*M(1,1))+M(2,1)*M(1,3))/(M(3,3)*M(2, . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1) . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M( . 2,2)*M(1,3))) MINV(3,1)=(M(3,2)*M(2,1)-(M(3,1)*M(2,2)))/(M(3,3)*M(2,2 . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)) . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2 . ,2)*M(1,3))) MINV(3,2)=(-(M(3,2)*M(1,1))+M(3,1)*M(1,2))/(M(3,3)*M(2, . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1) . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M( . 2,2)*M(1,3))) MINV(3,3)=(M(2,2)*M(1,1)-(M(2,1)*M(1,2)))/(M(3,3)*M(2,2 . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)) . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2 . ,2)*M(1,3))) RETURN END \end{framedverbatim} This is an example of a modular approach to code generation; separate subprogram templates are given in separate files. Furthermore, the template files are general; they can be used for matrices of any predetermined size. Therefore, we can easily generate different subprograms to handle matrices of different sizes from the same template files simply by assigning different values to {\it n}, and reloading the file init.red. \subsection{Template Processing and Generation of Type Declarations} \label{template:type} \index{GENDECS switch} \index{type declarations} In Section~\ref{control:type} we described the {\bf GENDECS} flag. We explained that type declarations are not generated when this flag is turned off. Now that the concept of template processing has been explained, it is appropriate to continue our discussion of generation of type declarations. When the {\bf GENDECS} flag is off, type declaration information is not simply discarded --- it is still maintained in the symbol table. Only the automatic extraction of this information in the form of declarations is disabled. When the {\bf GENDECS} flag is turned off, all type information associated with a specific subprogram can be retrieved in the form of generated declarations by calling the {\bf GENDECS} function with the subprogram name as argument. The template processor recognizes function and subroutine headings. It always keeps track of the name of the subprogram it is processing. Therefore, the declarations associated with a particular subprogram {\it subprogname} can be generated with a call to {\bf GENDECS} as follows: \begin{center} {\bf GENDECS} {\it subprogname}\$ \end{center} By using the {\bf GENDECS} flag and function together with the template processing facility, it is possible to have type information inserted into the symbol table during a first pass over a template file, and then to have it extracted during a second pass. Consider the following example in which the original template file is transformed into an intermediate template during the first pass, and then into the final file of FORTRAN code during the second pass: Contents of file {\tt junk.tem}: \begin{framedverbatim} ;BEGIN; MAXEXPPRINTLEN!* := 50$ OFF GENDECS$ ;END; SUBROUTINE CALC(X,Y,Z,A,B,RES) ;BEGIN; GENTRAN LITERAL ";BEGIN;", CR!*, "GENDECS CALC$", CR!*, ";END;", CR!*$ ;END; X=3.75 Y=-10.2 Z=16.473 ;BEGIN; GENTRAN << DECLARE X,Y,Z,A,B,RES : REAL; RES :=: (X + Y + Z)^3*(A + B)^2 >>$ ;END; RETURN END ;BEGIN; GENTRAN LITERAL ";END;", CR!*$ ;END; ;END; \end{framedverbatim} Invocation of the template processor on this file produces an intermediate template file: \begin{verbatim} 1: GENTRANIN 1: "junk.tem" 1: OUT "#junk.tem"$ \end{verbatim} Contents of file {\tt \#junk.tem}: \begin{framedverbatim} SUBROUTINE CALC(X,Y,Z,A,B,RES) ;BEGIN; GENDECS CALC$ ;END; X=3.75 Y=-10.2 Z=16.473 T0=A**2*X**3+3.0*A**2*X**2*Y T0=T0+3.0*A**2*X**2*Z+3.0*A**2*X*Y**2 T0=T0+6.0*A**2*X*Y*Z+3.0*A**2*X*Z**2 T0=T0+A**2*Y**3+3.0*A**2*Y**2*Z T0=T0+3.0*A**2*Y*Z**2+A**2*Z**3 T0=T0+2.0*A*B*X**3+6.0*A*B*X**2*Y T0=T0+6.0*A*B*X**2*Z+6.0*A*B*X*Y**2 T0=T0+12.0*A*B*X*Y*Z+6.0*A*B*X*Z**2 T0=T0+2.0*A*B*Y**3+6.0*A*B*Y**2*Z T0=T0+6.0*A*B*Y*Z**2+2.0*A*B*Z**3 T0=T0+B**2*X**3+3.0*B**2*X**2*Y T0=T0+3.0*B**2*X**2*Z+3.0*B**2*X*Y**2 T0=T0+6.0*B**2*X*Y*Z+3.0*B**2*X*Z**2 T0=T0+B**2*Y**3+3.0*B**2*Y**2*Z RES=T0+3.0*B**2*Y*Z**2+B**2*Z**3 RETURN END ;END; \end{framedverbatim} Another pass of the template processor produced the final file of FORTRAN code: \begin{verbatim} 2: GENTRANIN 2: "#junk.tem" 2: OUT "junk.f"$ \end{verbatim} Contents of file {\tt junk.f}: \begin{framedverbatim} SUBROUTINE CALC(X,Y,Z,A,B,RES) REAL X,Y,Z,A,B,RES,T0 X=3.75 Y=-10.2 Z=16.473 T0=A**2*X**3+3.0*A**2*X**2*Y T0=T0+3.0*A**2*X**2*Z+3.0*A**2*X*Y**2 T0=T0+6.0*A**2*X*Y*Z+3.0*A**2*X*Z**2 T0=T0+A**2*Y**3+3.0*A**2*Y**2*Z T0=T0+3.0*A**2*Y*Z**2+A**2*Z**3 T0=T0+2.0*A*B*X**3+6.0*A*B*X**2*Y T0=T0+6.0*A*B*X**2*Z+6.0*A*B*X*Y**2 T0=T0+12.0*A*B*X*Y*Z+6.0*A*B*X*Z**2 T0=T0+2.0*A*B*Y**3+6.0*A*B*Y**2*Z T0=T0+6.0*A*B*Y*Z**2+2.0*A*B*Z**3 T0=T0+B**2*X**3+3.0*B**2*X**2*Y T0=T0+3.0*B**2*X**2*Z+3.0*B**2*X*Y**2 T0=T0+6.0*B**2*X*Y*Z+3.0*B**2*X*Z**2 T0=T0+B**2*Y**3+3.0*B**2*Y**2*Z RES=T0+3.0*B**2*Y*Z**2+B**2*Z**3 RETURN END \end{framedverbatim} \subsection{Referencing Subprogram and Parameter Names} \index{"!\$n parameters} \index{"!\$0 subprogram name} In some code generation applications in which template processing is used, it is useful to be able to reference the names of the parameters given in the subprogram header. For this reason, the special symbols {\bf !\$1}, {\bf !\$2},~\dots, {\bf !\${\it n}}, where {\it n} is the number of parameters, can be used in computations and code generation commands in active parts of template files. Each of these symbols will be replaced by the corresponding parameter name when code is generated. In addition, the special symbol {\bf !\$0} will be replaced by the subprogram name. This is useful when FORTRAN or RATFOR functions are being generated. Finally, the \index{"!\$"!\# in GENTRAN} special global variable {\bf !\$!\#} is bound to the number of parameters in the subprogram header. \section{Output Redirection}\label{GENTRAN:output} \index{GENTRAN ! file output} Many examples given thus far in this manual have sent all generated code to the terminal screen. In actual code generation applications, however, code must be sent to a file which will be compiled at a later time. This section explains methods of redirecting code to a file as it is generated. Any number of output files can be open simultaneously, and generated code can be sent to any combination of these open files. \subsection{File Selection Commands} \label{file:selection} \index{OUT command} \index{SHUT command} REDUCE provides the user with two file handling commands for output redirection: {\bf OUT} and {\bf SHUT}. The {\bf OUT} command takes a single file name as argument and directs all REDUCE output to that file from then on, until another {\bf OUT} changes the output file, or {\bf SHUT} closes it. Output can go to only one file at a time, although many can be open. If the file has previously been used for output during the current job and not {\bf SHUT}, then the new output is appended onto the end of the file. Any existing file is erased before its first use for output in a job. To output on the terminal without closing the output file, the reserved file name {\bf T} (for terminal) may be used. The REDUCE {\bf SHUT} command takes a list of names of files which have been previously opened via an {\bf OUT} command and closes them. Most systems require this action by the user before he ends the REDUCE job; otherwise the output may be lost. If a file is {\bf SHUT} and a further {\bf OUT} command is issued for the same file, the file is erased before the new output is written. If it is the current output file that is {\bf SHUT}, output will switch to the terminal. These commands are suitable for most applications in which REDUCE output must be saved. However, they have two deficiencies when considered for use in code generation applications. First, they are inconvenient. {\bf OUT} tells REDUCE to direct {\it all\/} output to a specified file. Thus in addition to output written as side effects of functions, returned values are also written to the file (unless the user is careful to terminate all statements and commands with a {\bf \$}, in which case only output produced by side effects is written). If code generation is to be accomplished interactively; i.e., if algebraic computations and code generation commands are interleaved, then {\bf OUT} {\it filename\/}{\bf \$} must be issued before every group of code generation requests, and {\bf OUT T\$} must be issued after every group. Secondly, the {\bf OUT} command does not allow output to be sent to two or more files without reissuing the {\bf OUT} with another file name. In an effort to remove these deficiencies and make the code generation commands flexible and easy to use, separate file handling commands are provided by GENTRAN which redirect generated code {\it only}. \index{GENTRANOUT command} \index{GENTRANSHUT command} The {\bf GENTRANOUT} and {\bf GENTRANSHUT} commands are identical to the REDUCE {\bf OUT} and {\bf SHUT} commands with the following exceptions: \begin{itemize} \item {\bf GENTRANOUT} and {\bf GENTRANSHUT} redirect {\it only\/} code which is printed as a side effect of GENTRAN commands. \item {\bf GENTRANOUT} allows more than one file name to be given to indicate that generated code is to be sent to two or more files. (It is particularly convenient to be able to have generated code sent to the terminal screen and one or more file simultaneously.) \item {\bf GENTRANOUT} does not automatically erase existing files; it prints a warning message on the terminal and asks the user whether the existing file should be erased or the whole command be aborted. \end{itemize} The next two subsections describe these commands in detail. \index{GENTRANOUT command} \subsubsection{GENTRANOUT} \begin{describe}{Syntax:} {\bf GENTRANOUT} {\it f1,f2,\dots\ ,fn;} \end{describe} \begin{describe}{Arguments:} {\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each {\it f\/} is one of: \begin{center} \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf T} & = & the terminal\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{center} \end{describe} \begin{describe}{Side Effects:} GENTRAN maintains a list of files currently open for output by GENTRAN {\it only}. {\bf GENTRANOUT} inserts each file name represented by {\it f1,f2,\dots\ ,fn\/} into that list and opens each one for output. It also resets the current output file(s) to be all files in {\it f1,f2,\dots\ ,fn}. \end{describe} \begin{describe}{Returned Value:} {\bf GENTRANOUT} returns the list of files represented by {\it f1,f2,\dots\ ,fn\/}; i.e., the current output file(s) after the command has been executed. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \begin{describe}{\example} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(5,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(.75,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(.7,1.5) {\vector(0,-1){.75}} \end{picture}} \begin{verbatim} 1: GENTRANOUT "f1"; "f1" \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(5,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(1.5,0) {\framebox(1.5,.75){"f1"}} \put(2.25,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(2.2,1.5) {\vector(0,-1){.75}} \end{picture}} \begin{verbatim} 2: GENTRANOUT "f2"; "f2" \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(5,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(1.5,0) {\framebox(1.5,.75){"f1"}} \put(3,0) {\framebox(1.5,.75){"f2"}} \put(3.75,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(3.7,1.5) {\vector(0,-1){.75}} \end{picture}} \begin{verbatim} 3: GENTRANOUT T,"f3"; {T,"f3"} \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(1.5,0) {\framebox(1.5,.75){"f1"}} \put(3,0) {\framebox(1.5,.75){"f2"}} \put(4.5,0) {\framebox(1.5,.75){"f3"}} \put(5.5,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(5.25,1.5) {\vector(0,-1){.75}} \put(5.45,1.5) {\line(-1,0){4.70}} \put(.75,1.5) {\vector(0,-1){.75}} \end{picture}} \begin{verbatim} 4: GENTRANOUT "f1"; "f1" \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(1.5,0) {\framebox(1.5,.75){"f1"}} \put(3,0) {\framebox(1.5,.75){"f2"}} \put(4.5,0) {\framebox(1.5,.75){"f3"}} \put(2.25,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(2.2,1.5) {\vector(0,-1){.75}} \end{picture}} \begin{verbatim} 5: GENTRANOUT NIL,"f4"; {"f1","f4"} \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(1.5,0) {\framebox(1.5,.75){"f1"}} \put(3,0) {\framebox(1.5,.75){"f2"}} \put(4.5,0) {\framebox(1.5,.75){"f3"}} \put(6,0) {\framebox(1.5,.75){"f4"}} \put(7.5,1.5) {\makebox(0,0)[bl]{\tt current-output}} \put(6.75,1.5) {\vector(0,-1){.75}} \put(2.25,1.5) {\vector(0,-1){.75}} \put(7.45,1.5) {\line(-1,0){5.2}} \end{picture}} \ttindex{ALL"!*} \begin{verbatim} 6: GENTRANOUT ALL!*; {"f1","f2","f3","f4"} \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1.5,.75){T}} \put(1.5,0) {\framebox(1.5,.75){"f1"}} \put(3,0) {\framebox(1.5,.75){"f2"}} \put(4.5,0) {\framebox(1.5,.75){"f3"}} \put(6,0) {\framebox(1.5,.75){"f4"}} \put(7.5,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(6.75,1.5) {\vector(0,-1){.75}} \put(5.25,1.5) {\vector(0,-1){.75}} \put(3.75,1.5) {\vector(0,-1){.75}} \put(2.25,1.5) {\vector(0,-1){.75}} \put(7.45,1.5) {\line(-1,0){5.2}} \end{picture}} \end{describe} \subsubsection{GENTRANSHUT} \index{GENTRANSHUT command} \begin{describe}{Syntax:} {\bf GENTRANSHUT} {\it f1,f2,\dots\ ,fn;\/} \end{describe} \begin{describe}{Arguments:} {\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each {\it f\/} is one of: \begin{center} \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{center} \end{describe} \begin{describe}{Side Effects:} {\bf GENTRANSHUT} creates a list of file names from {\it f1,f2,\dots\ ,fn}, deletes each from the output file list, and closes the corresponding files. If (all of) the current output file(s) are closed, then the current output file is reset to the terminal. \end{describe} \begin{describe}{Returned Value:} {\bf GENTRANSHUT} returns the current output file(s) after the command has been executed. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** FILE NOT OPEN FOR OUTPUT ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1,.75){T}} \put(1,0) {\framebox(1,.75){"f1"}} \put(2,0) {\framebox(1,.75){"f2"}} \put(3,0) {\framebox(1,.75){"f3"}} \put(4,0) {\framebox(1,.75){"f4"}} \put(5,0) {\framebox(1,.75){"f5"}} \put(6,0) {\framebox(1,.75){"f6"}} \put(7,0) {\framebox(1,.75){"f7"}} \put(2,1.5) {\makebox(0,0) [br]{\tt current-output}} \put(3.5,1.5) {\vector(0,-1){.75}} \put(4.5,1.5) {\vector(0,-1){.75}} \put(7.5,1.5) {\vector(0,-1){.75}} \put(2.05,1.5) {\line(1,0){5.45}} \end{picture}} \begin{verbatim} 1: GENTRANSHUT "f1","f2","f7"; {"f3","f4"} \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1,.75){T}} \put(1,0) {\framebox(1,.75){"f3"}} \put(2,0) {\framebox(1,.75){"f4"}} \put(3,0) {\framebox(1,.75){"f5"}} \put(4,0) {\framebox(1,.75){"f6"}} \put(4.5,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(1.5,1.5) {\vector(0,-1){.75}} \put(2.5,1.5) {\vector(0,-1){.75}} \put(4.45,1.5) {\line(-1,0){2.95}} \end{picture}} \begin{verbatim} 2: GENTRANSHUT NIL; T \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1,.75){T}} \put(1,0) {\framebox(1,.75){"f5"}} \put(2,0) {\framebox(1,.75){"f6"}} \put(.55,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(.5,1.5) {\vector(0,-1){.75}} \end{picture}} \begin{verbatim} 3: GENTRANSHUT ALL!*; T \end{verbatim} Output file list: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(1,.75){T}} \put(.55,1.5) {\makebox(0,0) [bl]{\tt current-output}} \put(.5,1.5) {\vector(0,-1){.75}} \end{picture}} \end{describe} \subsection{The Output File Stack} Section~\ref{file:selection} \index{files ! in GENTRAN} explained the {\bf GENTRANOUT} and {\bf GENTRANSHUT} commands which are very similar to the REDUCE {\bf OUT} and {\bf SHUT} commands but redirect {\it only code generated as side effects of GENTRAN commands\/} to files. This section describes another pair of file handling commands provided by GENTRAN. In some code generation applications it may be convenient to be able to send generated code to one (set of) file(s), then temporarily send code to another (set of) file(s), and later resume sending generated code to the first (set of) file(s). In other words, it is convenient to think of the output files as being arranged in a stack which can be pushed whenever new files are to be written to temporarily, and popped whenever previously written-to files are to be appended onto. {\bf GENTRANPUSH} \index{GENTRANPUSH command} \index{GENTRANPOP command} and {\bf GENTRANPOP} enable the user to manipulate a stack of open output files in these ways. {\bf GENTRANPUSH} simply pushes a (set of) file(s) onto the stack and opens each one that is not already open for output. {\bf GENTRANPOP} deletes the top-most occurrence of the given file(s) from the stack and closes each one that is no longer in the stack. The stack is initialized to one element: the terminal. This element is always on the bottom of the stack, and thus, is the default output file. The current output file is always the file(s) on top of the stack. \subsubsection{GENTRANPUSH} \index{GENTRANPUSH command} \begin{describe}{Syntax:} {\bf GENTRANPUSH} {\it f1,f2,\dots\ ,fn;} \end{describe} \begin{describe}{Arguments:} {\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each {\it f\/} is one of: \begin{center} \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf T} & = & the terminal\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{center} \end{describe} \begin{describe}{Side Effects:} {\bf GENTRANPUSH} creates a list of file name(s) represented by {\it f1,f2,\dots\ ,fn\/} and pushes that list onto the output stack. Each file in the list that is not already open for output is opened at this time. The current output file is reset to this new element on the top of the stack. \end{describe} \begin{describe}{Returned Value:} {\bf GENTRANPUSH} returns the list of files represented by {\it f1,f2,\dots\ ,fn\/}; i.e., the current output file(s) after the command has been executed. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,1)(0,0) \put(0,0) {\framebox(3,1){}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,.5) {\vector(-1,0){1}} \put(4.1,.5) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 1: GENTRANPUSH "f1"; "f1" \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,1.5)(0,0) \put(0,0) {\framebox(3,1.5){}} \put(0.25,1) {\makebox(0,0)[cl]{"f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,1) {\vector(-1,0){1}} \put(4.1,1) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 2: GENTRANPUSH "f2","f3"; {"f2","f3"} \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,2)(0,0) \put(0,0) {\framebox(3,2){}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,1.5) {\vector(-1,0){1}} \put(4.1,1.5) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 3: GENTRANPUSH NIL,T; {"f2","f3",T} \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,2.5)(0,0) \put(0,0) {\framebox(3,2.5){}} \put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,2) {\vector(-1,0){1}} \put(4.1,2) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 4: GENTRANPUSH "f1"; "f1" \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,3)(0,0) \put(0,0) {\framebox(3,3){}} \put(0.25,2.5) {\makebox(0,0)[cl]{"f1"}} \put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,2.5) {\vector(-1,0){1}} \put(4.1,2.5) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 5: GENTRANPUSH ALL!*; {"f1","f2","f3"} \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,3.5)(0,0) \put(0,0) {\framebox(3,3.5){}} \put(0.25,3) {\makebox(0,0)[cl]{"f1" "f2" "f3"}} \put(0.25,2.5) {\makebox(0,0)[cl]{"f1"}} \put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,3) {\vector(-1,0){1}} \put(4.1,3) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \end{describe} \subsubsection{GENTRANPOP} \index{GENTRANPOP command} \begin{describe}{Syntax:} {\bf GENTRANPOP} {\it f1,f2,\dots\ ,fn;} \end{describe} \begin{describe}{Arguments:} {\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each {\it f\/} is one of: \begin{center} \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf T} & = & the terminal\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{center} \end{describe} \begin{describe}{Side Effects:} {\bf GENTRANPOP} deletes the top-most occurrence of the single element containing the file name(s) represented by {\it f1,f2,\dots\ ,fn\/} from the output stack. Files whose names have been completely removed from the output stack are closed. The current output file is reset to the (new) element on the top of the output stack. \end{describe} \begin{describe}{Returned Value:} {\bf GENTRANPOP} returns the current output file(s) after this command has been executed. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** FILE NOT OPEN FOR OUTPUT ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,4)(0,0) \put(0,0) {\framebox(3,4){}} \put(0.25,3.5) {\makebox(0,0)[cl]{"f4"}} \put(0.25,3) {\makebox(0,0)[cl]{"f4" "f2" T}} \put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}} \put(0.25,2) {\makebox(0,0)[cl]{T}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,3.5) {\vector(-1,0){1}} \put(4.1,3.5) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 1: GENTRANPOP NIL; {"f4","f2",T} \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,3.5)(0,0) \put(0,0) {\framebox(3,3.5){}} \put(0.25,3) {\makebox(0,0)[cl]{"f4" "f2" T}} \put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}} \put(0.25,2) {\makebox(0,0)[cl]{T}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,3) {\vector(-1,0){1}} \put(4.1,3) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 2: GENTRANPOP NIL; "f4" \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,3)(0,0) \put(0,0) {\framebox(3,3){}} \put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}} \put(0.25,2) {\makebox(0,0)[cl]{T}} \put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}} \put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,2.5) {\vector(-1,0){1}} \put(4.1,2.5) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 3: GENTRANPOP "f2","f1"; "f4" \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,2.5)(0,0) \put(0,0) {\framebox(3,2.5){}} \put(0.25,2) {\makebox(0,0)[cl]{"f4"}} \put(0.25,1.5) {\makebox(0,0)[cl]{T}} \put(0.25,1) {\makebox(0,0)[cl]{"f3"}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,2) {\vector(-1,0){1}} \put(4.1,2) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \begin{verbatim} 4: GENTRANPOP ALL!*; T \end{verbatim} Output stack: {\setlength{\unitlength}{1cm} \begin{picture}(10,1)(0,0) \put(0,0) {\framebox(3,1){}} \put(0.25,.5) {\makebox(0,0)[cl]{T}} \put(4,.5) {\vector(-1,0){1}} \put(4.1,.5) {\makebox(0,0)[cl]{\tt current-output}} \end{picture}} \end{describe} \subsection{Temporary Output Redirection} Sections~\ref{translation} and ~\ref{templates} explain how to use the code generation and template processing commands. The syntax for these two commands is: \index{output redirection (temporary)} \index{GENTRAN command} \index{GENTRANIN command} \begin{tabular}{lll} &\multicolumn{2}{l}{{\bf GENTRAN} {\it stmt\/} [{\bf OUT} {\it f1,f2,\dots\ ,fn\/}]{\it ;}}\\ &&and\\ &\multicolumn{2}{l}{{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm\/} [{\bf OUT} {\it f1,f2,\dots\ ,fn\/}]{\it ;}}\\ \end{tabular} The optional parts of these two commands can be used for {\it temporary} output redirection; they can be used when the current output file is to be temporarily reset, for this command only. Thus the following two sequences of commands are equivalent: \begin{verbatim} 10: GENTRANPUSH "f1",T$ 11: GENTRAN ... $ 12: GENTRANPOP NIL$ \end{verbatim} and \begin{verbatim} 10: GENTRAN 10: ... 10: OUT "f1",T$ \end{verbatim} \section{Modification of the Code Generation Process}\label{GENTRAN:mod} GENTRAN is designed to be flexible enough to be used in a variety of code generation applications. For this reason, several mode switches and variables are provided to enable the user to tailor the code generation process to meet his or her particular needs. \subsection{Mode Switches} \index{GENTRAN package ! switches} The following GENTRAN mode switches can be turned on and off with the REDUCE {\bf ON} and {\bf OFF} commands. \begin{describe}{DOUBLE} \index{DOUBLE switch} \index{precision} \begin{itemize} \item When turned on, causes (where appropriate): \begin{itemize} \item floating point numbers to be printed in double precision format; \item intrinsic functions to be replaced by their double precision counterparts; \item generated type declarations to be of double precision form. \end{itemize} See also section~\ref{precision} on page~\pageref{precision}. \item default setting: off \end{itemize} \end{describe} \begin{describe}{GENDECS} \index{GENDECS switch} \begin{itemize} \item when turned on, allows type declarations to be generated automatically; otherwise, type information is stored in but not automatically retrieved from the symbol table. See also sections~\ref{explicit:type} on page~\pageref{explicit:type}, \ref{more:type} on page~\pageref{more:type}, and \ref{template:type} on page~\pageref{template:type}. \item default setting: on \end{itemize} \end{describe} \begin{describe}{GENTRANOPT} \index{GENTRANOPT switch} \begin{itemize} \item when turned on, replaces each block of straightline code by an optimized sequence of assignments. The Code Optimizer takes a sequence of assignments and replaces common subexpressions with temporary variables. It returns the resulting assignment statements with common-subexpression-to-temporary-variable assignment statements preceding them \item default setting: off \end{itemize} \end{describe} \begin{describe}{GENTRANSEG} \index{GENTRANSEG switch} \begin{itemize} \item when turned on, checks the print length of expressions and breaks those expressions that are longer than {\bf MAXEXPPRINTLEN!*} down \ttindex{MAXEXPPRINTLEN"!*} into subexpressions which are assigned to temporary variables. See also section~\ref{segmentation} on page~\pageref{segmentation}. \item default setting: on \end{itemize} \end{describe} \begin{describe}{GETDECS} \index{GETDECS switch} \begin{itemize} \item when on, causes: \begin{itemize} \item the indices of loops to be declared integer; \item objects without an explicit type declaration to be declared of the type given by the variable {\bf DEFTYPE!*}. \ttindex{DEFTYPE"!*} \end{itemize} See also section~\ref{implicit:type} on page~\pageref{implicit:type}. \item default setting: off \end{itemize} \end{describe} \begin{describe}{KEEPDECS} \index{KEEPDECS switch} \begin{itemize} \item when on, prevents declarations being removed from the symbol table when type declarations are generated. \item default: off \end{itemize} \end{describe} \begin{describe}{MAKECALLS} \index{MAKECALLS switch} \begin{itemize} \item when turned on, causes GENTRAN to translate functional expressions as subprogram calls. \item default setting: on \end{itemize} \end{describe} \begin{describe}{PERIOD} \index{PERIOD switch} \begin{itemize} \item when turned on, causes all integers to be printed out as floating point numbers except: \begin{itemize} \item exponents; \item variable subscripts; \item index values in DO-type loops; \item those which have been declared to be integers. \end{itemize} \item default setting: on \end{itemize} \end{describe} \subsection{Variables} \index{GENTRAN package ! variables} Several global variables are provided in GENTRAN to enable the user to \begin{itemize} \item select the target language \item control expression segmentation \item change automatically generated variable names and statement numbers \item modify the code formatter \end{itemize} The following four subsections describe these variables\footnote{ Note that when an atomic value (other than an integer) is assigned to a variable, that value must be quoted. For example, {\bf GENTRANLANG!* := 'FORTRAN\$} assigns the atom {\bf FORTRAN} to the variable {\bf GENTRANLANG!*}.}. \subsubsection{Target Language Selection} \begin{describe}{GENTRANLANG!*} \ttindex{GENTRANLANG"!*} \begin{itemize} \item target language (FORTRAN, RATFOR, PASCAL or C) See also section~\ref{gentranlang} on page~\pageref{gentranlang}. \item value type: atom \item default value: FORTRAN \end{itemize} \end{describe} \subsubsection{Expression Segmentation Control} \begin{describe}{MAXEXPPRINTLEN!*} \ttindex{MAXEXPPRINTLEN"!*} \begin{itemize} \item value used to determine whether or not an expression should be segmented; maximum number of characters permitted in an expression in the target language (excluding spaces printed for formatting). See also section~\ref{segmentation} on page~\pageref{segmentation}. \item value type: integer \item default value: 800 \end{itemize} \end{describe} \subsubsection{Variable Names \& Statement Numbers} \begin{describe}{TEMPVARNAME!*} \ttindex{TEMPVARNAME"!*} \begin{itemize} \item name used as prefix in generating temporary variable names. See also section~\ref{tempvars} on page~\pageref{tempvars}. \item value type: atom \item default value: T \end{itemize} \end{describe} \begin{describe}{TEMPVARNUM!*} \ttindex{TEMPVARNUM"!*} \begin{itemize} \item number appended to {\bf TEMPVARNAME!*} to create a temporary variable name. If the temporary variable name resulting from appending {\bf TEMPVARNUM!*} onto {\bf TEMPVARNAME!*} has already been generated and still holds a useful value, then {\bf TEMPVARNUM!*} is incremented and temporary variable names are compressed until one is found which was not previously generated or does not still hold a significant value. See also section~\ref{tempvars} on page~\pageref{tempvars}. \item value type: integer \item default value: 0 \end{itemize} \end{describe} \begin{describe}{TEMPVARTYPE!*} \ttindex{TEMPVARTYPE"!*} \begin{itemize} \item target language variable type (e.g., INTEGER, REAL!*8, FLOAT, etc) used as a default for automatically generated variables whose type cannot be determined otherwise. If {\bf TEMPVARTYPE!*} is NIL, then generated temporary variables whose type cannot be determined are not automatically declared. See also section~\ref{tempvars} on page~\pageref{tempvars}. \item value type: atom \item default value: NIL \end{itemize} \end{describe} \begin{describe}{GENSTMTNUM!*} \ttindex{GENSTMTNUM"!*} \begin{itemize} \item number used when a statement number must be generated \item value type: integer \item default value: 25000 \end{itemize} \end{describe} \begin{describe}{GENSTMTINCR!*} \ttindex{GENSTMTINCR"!*} \begin{itemize} \item number by which {\bf GENSTMTNUM!*} is increased each time a new statement number is generated. \item value type: integer \item default value: 1 \end{itemize} \end{describe} \begin{describe}{DEFTYPE!*} \ttindex{DEFTYPE"!*} \begin{itemize} \item default type for objects when the switch {\bf GETDECS} is on. See also section~\ref{implicit:type} on page~\pageref{implicit:type}. \item value type: atom \item default value: real \end{itemize} \end{describe} \subsubsection{Code Formatting} \begin{describe}{FORTCURRIND!*} \ttindex{FORTCURRIND"!*} \begin{itemize} \item number of blank spaces printed at the beginning of each line of generated FORTRAN code beyond column 6 \item value type: integer \item default value: 0 \end{itemize} \end{describe} \begin{describe}{RATCURRIND!*} \ttindex{RATCURRIND"!*} \begin{itemize} \item number of blank spaces printed at the beginning of each line of generated RATFOR code. \item value type: integer \item default value: 0 \end{itemize} \end{describe} \begin{describe}{CCURRIND!*} \ttindex{CCURRIND"!*} \begin{itemize} \item number of blank spaces printed at the beginning of each line of generated C code. \item value type: integer \item default value: 0 \end{itemize} \end{describe} \begin{describe}{PASCCURRIND!*} \ttindex{PASCCURRIND"!*} \begin{itemize} \item number of blank spaces printed at the beginning of each line of generated PASCAL code. \item value type: integer \item default value: 0 \end{itemize} \end{describe} \begin{describe}{TABLEN!*} \ttindex{TABLEN"!*} \begin{itemize} \item number of blank spaces printed for each new level of indentation. \item value type: integer \item default value: 4 \end{itemize} \end{describe} \begin{describe}{FORTLINELEN!*} \ttindex{FORTLINELEN"!*} \begin{itemize} \item maximum number of characters printed on each line of generated FORTRAN code. \item value type: integer \item default value: 72 \end{itemize} \end{describe} \begin{describe}{RATLINELEN!*} \ttindex{RATLINELEN"!*} \begin{itemize} \item maximum number of characters printed on each line of generated RATFOR code. \item value type: integer \item default value: 80 \end{itemize} \end{describe} \begin{describe}{CLINELEN!*} \ttindex{CLINELEN"!*} \begin{itemize} \item maximum number of characters printed on each line of generated C code. \item value type: integer \item default value: 80 \end{itemize} \end{describe} \begin{describe}{PASCLINELEN!*} \ttindex{PASCLINELEN"!*} \begin{itemize} \item maximum number of characters printed on each line of generated PASCAL code. \item value type: integer \item default value: 70 \end{itemize} \end{describe} \begin{describe}{MINFORTLINELEN!*} \ttindex{MINFORTLINELEN"!*} \begin{itemize} \item minimum number of characters printed on each line of generated FORTRAN code after indentation. \item value type: integer \item default value: 40 \end{itemize} \end{describe} \begin{describe}{MINRATLINELEN!*} \ttindex{MINRATLINELEN"!*} \begin{itemize} \item minimum number of characters printed on each line of generated RATFOR code after indentation. \item value type: integer \item default value: 40 \end{itemize} \end{describe} \begin{describe}{MINCLINELEN!*} \ttindex{MINCLINELEN"!*} \begin{itemize} \item minimum number of characters printed on each line of generated C code after indentation. \item value type: integer \item default value: 40 \end{itemize} \end{describe} \begin{describe}{MINPASCLINELEN!*} \ttindex{MINPASCLINELEN"!*} \begin{itemize} \item minimum number of characters printed on each line of generated PASCAL code after indentation. \item value type: integer \item default value: 40 \end{itemize} \end{describe} \section{Examples}\label{GENTRAN:examples} \index{GENTRAN package ! example} Short examples have been given throughout this manual to illustrate usage of the GENTRAN commands. This section gives complete code generation examples. \subsection{Interactive Code Generation} \index{GENTRAN package ! example} \index{interactive code generation} Suppose we wish to generate a FORTRAN subprogram which can be used for \index{Graeffe's Root-Squaring Method} computing the roots of a polynomial by Graeffe's Root-Squaring Method\footnote{ This is for instance convenient for ill-conditioned polynomials. More details are given in {\it Introduction to Numerical Analysis\/} by C. E. Froberg, Addison-Wesley Publishing Company, 1966.}. This method states that the roots $x_i$ of a polynomial $$P_n(x) = \sum_{i=0}^{n}{a_i x^{n-i}} $$ can be found by constructing the polynomial $$P^{*}_n\left({x^2}\right) = \left( a_0x^n + a_2x^{n-2} + \dots\right)^2 - \left( a_1x^{n-1} + a_3x^{n-3} + \dots\right)^2$$ with roots $x_i^2$ When read into REDUCE, the following file of REDUCE statements will place the coefficients of $P^{*}_n$ into the list B for some user-entered value of n greater than zero. Contents of file {\tt graeffe.red}:\footnote{ In accordance with section~\ref{explicit:type}, the subscripts of A are I+1 instead of I.} \begin{framedverbatim} OPERATOR A$ Q := FOR I := 0 STEP 2 UNTIL n SUM (A(I+1)*X^(n-I))$ R := FOR I := 1 STEP 2 UNTIL n-1 SUM (A(I+1)*X^(n-I))$ P := Q^2 - R^2$ LET X^2 = Y$ B := COEFF(P,Y)$ END$ \end{framedverbatim} Now a numerical subprogram can be generated with assignment statements for the coefficients of $P^{*}_n$ (now stored in list B in REDUCE). Since these coefficients are given in terms of the coefficients of $P_n$ (i.e., operator A in REDUCE), the subprogram will need two parameters: A and B, each of which must be arrays of size n+1. The following REDUCE session will create subroutine GRAEFF for a polynomial of degree n=10 and write it to file {\tt graeffe.f}: {\small \begin{verbatim} 1: n := 10$ 2: IN "graeffe.red"$ 3: GENTRANLANG!* := 'FORTRAN$ 4: ON DOUBLE$ 5: GENTRAN 5: ( 5: PROCEDURE GRAEFF(A,B); 5: BEGIN 5: DECLARE 5: << 5: GRAEFF : SUBROUTINE; 5: A(11),B(11) : REAL 5: >>; 5: LITERAL 5: "C",CR!*, 5: "C",TAB!*,"GRAEFFE ROOT-SQUARING METHOD TO FIND",CR!*, 5: "C",TAB!*,"ROOTS OF A POLYNOMIAL",CR!*, 5: "C",CR!*; 5: B(1) :=: PART (B,1); 5: B(2) :=: PART (B,2); 5: B(3) :=: PART (B,3); 5: B(4) :=: PART (B,4); 5: B(5) :=: PART (B,5); 5: B(6) :=: PART (B,6); 5: B(7) :=: PART (B,7); 5: B(8) :=: PART (B,8); 5: B(9) :=: PART (B,9); 5: B(10) :=: PART (B,10); 5: B(11) :=: PART (B,11) 5: END 5: ) 5: OUT "graeffe.f"$ \end{verbatim} } Contents of file {\tt graeffe.f}: \begin{framedverbatim} SUBROUTINE GRAEFF(A,B) DOUBLE PRECISION A(11),B(11) C C GRAEFFE ROOT-SQUARING METHOD TO FIND C ROOTS OF A POLYNOMIAL C B(1)=A(11)**2 B(2)=2.0D0*A(11)*A(9)-A(10)**2 B(3)=2.0D0*A(11)*A(7)-(2.0D0*A(10)*A(8))+A(9)**2 B(4)=2.0D0*A(11)*A(5)-(2.0D0*A(10)*A(6))+2.0D0*A(9)*A(7 . )-A(8)**2 B(5)=2.0D0*A(11)*A(3)-(2.0D0*A(10)*A(4))+2.0D0*A(9)*A(5 . )-(2.0D0*A(8)*A(6))+A(7)**2 B(6)=2.0D0*A(11)*A(1)-(2.0D0*A(10)*A(2))+2.0D0*A(9)*A(3 . )-(2.0D0*A(8)*A(4))+2.0D0*A(7)*A(5)-A(6)**2 B(7)=2.0D0*A(9)*A(1)-(2.0D0*A(8)*A(2))+2.0D0*A(7)*A(3)- . (2.0D0*A(6)*A(4))+A(5)**2 B(8)=2.0D0*A(7)*A(1)-(2.0D0*A(6)*A(2))+2.0D0*A(5)*A(3)- . A(4)**2 B(9)=2.0D0*A(5)*A(1)-(2.0D0*A(4)*A(2))+A(3)**2 B(10)=2.0D0*A(3)*A(1)-A(2)**2 B(11)=A(1)**2 RETURN END \end{framedverbatim} \subsection{Code Generation, Segmentation \& Temporary Variables} \index{GENTRAN package ! example} The following 3 x 3 inertia matrix M was derived in the course of some research \footnote{For details see: Bos, A. M. and M. J. L. Tiernego. ``Formula Manipulation in the Bond Graph Modelling and Simulation of Large Mechanical Systems'', {\it Journal of the Franklin Institute} , Pergamon Press Ltd., Vol. 319, No. 1/2, pp. 51-65, January/February 1985.}: \begin{eqnarray*} M(1,1) & = & 18*\cos (q_3)*\cos (q_2)*m_{30}*p^2 - \sin ^2(q_3) *j_{30}y + \sin ^2(q_3) \\ & & *j_{30}z - 9*\sin ^2(q_3) *m_{30}*p^2 + j_{10}y + j_{30}y + m_{10}*p^2 + \\ & & 18*m_{30}*p^2\\ M(1,2) & = & 9*\cos (q_3)*\cos (q_2)*m_{30}*p^2 - \sin ^2(q_3) *j_{30}y +\sin ^2(q_3) \\ & & *j_{30}z - 9*\sin ^2(q_3) *m_{30}*p^2 + j_{30}y + 9* m_{30}*p^2\\ M(2,1) & = & M(1,2)\\ M(1,3) & = & - 9*\sin (q_3)*\sin (q_2)*m_{30}*p^2\\ M(3,1) & = & M(1,3)\\ M(2,2) & = & - \sin ^2(q_3) *j_{30}y + \sin ^2(q_3) *j_{30}z - 9*\sin ^2(q_3)*m_{30}*p^2 \\ & & + j_{30}y + 9*m_{30}*p^2\\ M(2,3) & = & 0\\ M(3,2) & = & M(2,3)\\ M(3,3) & = & 9*m_{30}*p^2 + j_{30}x\\ \end{eqnarray*} We know M is symmetric. We wish to generate numerical code to compute values for M and its inverse matrix. \subsubsection{Code Generation} \label{code:example} Generating code for matrix M and its inverse matrix is straightforward. We can simply generate an assignment statement for each element of M, compute the inverse matrix MIV, and generate an assignment statement for each element of MIV. Since we know M is symmetric, we know that MIV will also be symmetric. To avoid duplicate computations, we will not generate assignments for elements below the main diagonals of these matrices. Instead, we will copy elements across the main diagonal by generating nested loops. The following REDUCE session will write to the file {\tt m1.f}: \begin{verbatim} 1: IN "m.red"$ % Initialize M 2: GENTRANOUT "m1.f"$ 3: GENTRANLANG!* := 'FORTRAN$ 4: ON DOUBLE$ 5: FOR J := 1 : 3 DO 5: FOR K := J : 3 DO 5: GENTRAN M(J,K) ::=: M(J,K)$ 6: MIV := M^(-1)$ 7: FOR J := 1 : 3 DO 7: FOR K := J : 3 DO 7: GENTRAN MIV(J,K) ::=: MIV(J,K)$ 8: GENTRAN 8: FOR J := 1 : 3 DO 8: FOR K := J+1 : 3 DO 8: << 8: M(K,J) := M(J,K); 8: MIV(K,J) := MIV(J,K) 8: >>$ 9: GENTRANSHUT "m1.f"$ \end{verbatim} The contents of {\tt m1.f} are reproduced in~\ref{appc} on page~\pageref{appc}. This code was generated with the segmentation facility turned off. However, most FORTRAN compilers cannot handle statements more than 20 lines long. The next section shows how to generate segmented assignments. \subsubsection{Segmentation} \label{seg:example} \index{segmented assignments} Large arithmetic expressions can be broken into pieces of manageable size with the expression segmentation facility. The following REDUCE session will write segmented assignment statements to the file {\tt m2.f}. Large arithmetic expressions will be broken into subexpressions of approximately 300 characters in length. \begin{verbatim} 1: IN "m.red"$ % Initialize M 2: GENTRANOUT "m2.f"$ 3: ON DOUBLE$ 4: ON GENTRANSEG$ 5: MAXEXPPRINTLEN!* := 300$ 6: FOR J := 1 : 3 DO 6: FOR K := J : 3 DO 6: GENTRAN M(J,K) ::=: M(J,K)$ 7: MIV := M^(-1)$ 8: FOR J := 1 : 3 DO 8: FOR K := J : 3 DO 8: GENTRAN MIV(J,K) ::=: MIV(J,K)$ 9: GENTRAN 9: FOR J := 1 : 3 DO 9: FOR K := J+1 : 3 DO 9: << 9: M(K,J) := M(J,K); 9: MIV(K,J) := MIV(J,K) 9: >>$ 10: GENTRANSHUT "m2.f"$ \end{verbatim} The contents of file {\tt m2.f} are reproduced in~\ref{appc} on page~\pageref{appc}. \subsubsection{Generation of Temporary Variables to Suppress Simplification} \label{tempvar:example} We can dramatically improve the efficiency of the code generated in sections~\ref{code:example} on page~\pageref{code:example} and \ref{seg:example} on page~\pageref{seg:example} by replacing expressions by temporary variables before computing the inverse matrix. This effectively suppresses simplification; these expressions will not be substituted into later computations. We will replace each non-zero element of the REDUCE matrix M by a generated variable name, and generate a numerical assignment statement to reflect that substitution in the numerical program being generated. The following REDUCE session will write to the file {\tt m3.f}: \begin{verbatim} 1: in "m.red"$ % Initialize M 2: GENTRANOUT "m3.f"$ 3: GENTRANLANG!* := 'FORTRAN$ 4: ON DOUBLE$ 5: FOR J := 1 : 3 DO 5: FOR K := J : 3 DO 5: GENTRAN M(J,K) ::=: M(J,K)$ 6: SHARE VAR$ 7: FOR J := 1 : 3 DO 7: FOR K := J : 3 DO 7: IF M(J,K) NEQ 0 THEN 7: << 7: VAR := TEMPVAR(NIL)$ 7: MARKVAR VAR$ 7: M(J,K) := VAR$ 7: M(K,J) := VAR$ 7: GENTRAN 7: EVAL(VAR) := M(EVAL(J),EVAL(K)) 7: >>$ 8: COMMENT ** Contents of matrix M: **$ 9: M; [T0 T1 T2] [ ] [T1 T3 0 ] [ ] [T2 0 T4] 10: MIV := M^(-1)$ 11: FOR J := 1 : 3 DO 11: FOR K := J : 3 DO 11: GENTRAN MIV(J,K) ::=: MIV(J,K)$ 12: GENTRAN 12: FOR J := 1 : 3 DO 12: FOR K := J+1 : 3 DO 12: << 12: M(K,J) := M(J,K); 12: MIV(K,J) := MIV(J,K) 12: >>$ 13: GENTRANSHUT "m3.f"$ \end{verbatim} Contents of file {\tt m3.f}: \begin{framedverbatim} M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10 . +J30Y+J10Y M(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*DCOS(DBLE( . Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+J30Y M(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30) M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+ . J30Y M(2,3)=0.0D0 M(3,3)=9.0D0*P**2*M30+J30X T0=M(1,1) T1=M(1,2) T2=M(1,3) T3=M(2,2) T4=M(3,3) MIV(1,1)=-(T4*T3)/(T4*T1**2-(T4*T3*T0)+T2**2*T3) MIV(1,2)=(T4*T1)/(T4*T1**2-(T4*T3*T0)+T2**2*T3) MIV(1,3)=(T2*T3)/(T4*T1**2-(T4*T3*T0)+T2**2*T3) MIV(2,2)=(-(T4*T0)+T2**2)/(T4*T1**2-(T4*T3*T0)+T2**2* . T3) MIV(2,3)=-(T1*T2)/(T4*T1**2-(T4*T3*T0)+T2**2*T3) MIV(3,3)=(T1**2-(T3*T0))/(T4*T1**2-(T4*T3*T0)+T2**2*T3) DO 25009 J=1,3 DO 25010 K=J+1,3 M(K,J)=M(J,K) MIV(K,J)=MIV(J,K) 25010 CONTINUE 25009 CONTINUE \end{framedverbatim} \subsection{Template Processing} \index{template processing} \index{GENTRAN package ! example} \index{Automatic Circuitry Code Generator} Circuit simulation plays a vital role in computer hardware development. A recent paper\footnote{Loe, K. F., N. Ohsawa, and E. Goto. ``Design of an Automatic Circuitry Code Generator (ACCG)'', {\it RSYMSAC Proceedings}, Wako-shi, Saitama, Japan. 1984.} describes the design of an Automatic Circuitry Code Generator (ACCG), which generates circuit simulation programs based on user-supplied circuit specifications. The actual code generator consists of a series of REDUCE {\bf WRITE} statements, each of which writes one line of FORTRAN code. This section presents an alternative implementation for the ACCG which uses GENTRAN's template processor to generate code. Template processing is a much more natural method of code generation than the REDUCE {\bf WRITE} statement method. First we will put all REDUCE calculations into two files: {\tt rk.red} and {\tt ham.red}. Contents of file {\tt rk.red}:\footnote{ Line 11 of procedure RUNGEKUTTA was changed from \begin{center} {\tt K41 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2);} \end{center} as given in (Loe84), to \begin{center} {\tt K42 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2);} \end{center} } \begin{framedverbatim} COMMENT -- RUNGE-KUTTA METHOD --$ PROCEDURE RUNGEKUTTA(P1, P2, P, Q, TT); BEGIN SCALAR K11,K12,K21,K22,K31,K32,K41,K42; K11 := HH*P1; K12 := HH*P2; K21 := HH*SUB(TT=TT+HH/2, P=P+K11/2, Q=Q+K12/2, P1); K22 := HH*SUB(TT=TT+HH/2, P=P+K11/2, Q=Q+K12/2, P2); K31 := HH*SUB(TT=TT+HH/2, P=P+K21/2, Q=Q+K22/2, P1); K32 := HH*SUB(TT=TT+HH/2, P=P+K21/2, Q=Q+K22/2, P2); K41 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P1); K42 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2); PN := P + (K11 + 2*K21 + 2*K31 + K41)/6; QN := Q + (K12 + 2*K22 + 2*K32 + K42)/6 END$ END$ \end{framedverbatim} Contents of file {\tt ham.red}: \begin{framedverbatim} COMMENT -- HAMILTONIAN CALCULATION --$ DIFQ := DF(H,P)$ DIFP := -DF(H,Q) - SUB(QDOT=P/M, DF(D,QDOT))$ RUNGEKUTTA(DIFP, DIFQ, P, Q, TT)$ END$ \end{framedverbatim} Next we will create a template file with an outline of the target FORTRAN program and GENTRAN commands. Contents of file {\tt runge.tem}: \begin{framedverbatim} PROGRAM RUNGE IMPLICIT DOUBLE PRECISION (K,M) C C INPUT C WRITE(6,*) 'INITIAL VALUE OF P' READ(5,*) P WRITE(6,*) ' P = ', P WRITE(6,*) 'INITIAL VALUE OF Q' READ(5,*) Q WRITE(6,*) ' Q = ', Q WRITE(6,*) 'VALUE OF M' READ(5,*) M WRITE(6,*) ' M = ', M WRITE(6,*) 'VALUE OF K0' READ(5,*) K0 WRITE(6,*) ' K0 = ', K0 WRITE(6,*) 'VALUE OF B' READ(5,*) B WRITE(6,*) ' B = ', B WRITE(6,*) 'STEP SIZE OF T' READ(5,*) HH WRITE(6,*) ' STEP SIZE OF T = ', HH WRITE(6,*) 'FINAL VALUE OF T' READ(5,*) TP WRITE(6,*) ' FINAL VALUE OF T = ', TP C C INITIALIZATION C TT=0.0D0 ;BEGIN; GENTRAN LITERAL TAB!*, "WRITE(9,*) ' H = ", EVAL(H), "'", CR!*, TAB!*, "WRITE(9,*) ' D = ", EVAL(D), "'", CR!*$ ;END; WRITE(9,901) C 901 FORMAT(' C= ',D20.10) WRITE(9,910) TT, Q, P 910 FORMAT(' '3D20.10) C C LOOP C ;BEGIN; GENTRAN REPEAT << PN :=: PN; Q :=: QN; P := PN; TT := TT + HH; LITERAL TAB!*, "WRITE(9,910) TT, QQ, P", CR!* >> UNTIL TT >= TF$ ;END; STOP END ;END; \end{framedverbatim} Now we can generate a circuit simulation program simply by starting a REDUCE session and following three steps: \begin{enumerate} \item Enter circuit specifications. \item Perform calculations. \item Call the GENTRAN template processor. \end{enumerate} For example, the following REDUCE session will write a simulation program to the file {\tt runge.f}: \begin{verbatim} 1: COMMENT -- INPUT --$ 2: K := 1/(2*M)*P^2$ % kinetic energy 3: U := K0/2*Q^2$ % potential energy 4: D := B/2*QDOT$ % dissipating function 5: H := K + U$ % hamiltonian 6: COMMENT -- CALCULATIONS --$ 7: IN "rk.red", "ham.red"$ 8: COMMENT -- FORTRAN CODE GENERATION --$ 9: GENTRANLANG!* := 'FORTRAN$ 10: ON DOUBLE$ 11: GENTRANIN "runge.tem" OUT "runge.f"$ \end{verbatim} Contents of file {\tt runge.f}: \begin{framedverbatim} PROGRAM RUNGE IMPLICIT DOUBLE PRECISION (K,M) C C INPUT C WRITE(6,*) 'INITIAL VALUE OF P' READ(5,*) P WRITE(6,*) ' P = ', P WRITE(6,*) 'INITIAL VALUE OF Q' READ(5,*) Q WRITE(6,*) ' Q = ', Q WRITE(6,*) 'VALUE OF M' READ(5,*) M WRITE(6,*) ' M = ', M WRITE(6,*) 'VALUE OF K0' READ(5,*) K0 WRITE(6,*) ' K0 = ', K0 WRITE(6,*) 'VALUE OF B' READ(5,*) B WRITE(6,*) ' B = ', B WRITE(6,*) 'STEP SIZE OF T' READ(5,*) HH WRITE(6,*) ' STEP SIZE OF T = ', HH WRITE(6,*) 'FINAL VALUE OF T' READ(5,*) TP WRITE(6,*) ' FINAL VALUE OF T = ', TP C C INITIALIZATION C TT=0.0D0 WRITE(9,*) ' H = (M*Q**2*K0+P**2)/(2.0D0*M)' WRITE(9,*) ' D = (B*QDOT)/2.0D0' WRITE(9,901) C 901 FORMAT(' C= ',D20.10) WRITE(9,910) TT, Q, P 910 FORMAT(' '3D20.10) C C LOOP C 25001 CONTINUE PN=(-(12.0D0*B*M**2*HH)+2.0D0*B*M*K0*HH**3+24.0D0* . M**2*P-(24.0D0*M**2*Q*K0*HH)-(12.0D0*M*P*K0*HH**2) . +4.0D0*M*Q*K0**2*HH**3+P*K0**2*HH**4)/(24.0D0*M**2 . ) Q=(-(12.0D0*B*M*HH**2)+B*K0*HH**4+48.0D0*M**2*Q+ . 48.0D0*M*P*HH-(24.0D0*M*Q*K0*HH**2)-(8.0D0*P*K0*HH . **3)+2.0D0*Q*K0**2*HH**4)/(48.0D0*M**2) P=PN TT=TT+HH WRITE(9,910) TT, QQ, P IF (.NOT.TT.GE.TF) GOTO 25001 STOP END \end{framedverbatim} \section{Symbolic Mode Functions} \index{symbolic mode ! in GENTRAN} Thus far in this manual, commands have been presented which are meant to be used primarily in the algebraic mode of REDUCE. These commands are designed to be used interactively. However, many code generation applications require code to be generated under program control\footnote{ \cite{vandenHeuvel:86ms} contains one such example.}. In these applications, it is generally more convenient to generate code from (computed) prefix forms. Therefore, GENTRAN provides code generation and file handling functions designed specifically to be used in the symbolic mode of REDUCE. This section presents the symbolic functions which are analogous to the code generation, template processing, and output file handling commands presented in sections \ref{GENTRAN:inter}, \ref{GENTRAN:template}, and \ref{GENTRAN:output}. \subsection{Code Generation and Translation} Sections~\ref{translation} through \ref{comments} describe interactive commands and functions which generate and translate code, declare variables to be of specific types, and insert literal strings of characters into the stream of generated code. This section describes analogous symbolic mode code generation functions. \subsubsection{Translation of Prefix Forms} In algebraic mode, the {\bf GENTRAN} command translates algorithmic specifications supplied in the form of REDUCE statements into numerical code. Similarly, the symbolic function {\bf SYM!-GENTRAN} \index{SYM"!-GENTRAN command} translates algorithmic specifications supplied in the form of REDUCE prefix forms into numerical code. \begin{describe}{Syntax:} {\bf SYM!-GENTRAN} {\it form\/}; \end{describe} \begin{describe}{Function Type:} expr \end{describe} \begin{describe}{Argument:} {\it form\/} is any LISP prefix form that evaluates to a REDUCE prefix form that can be translated by GENTRAN into the target language\footnote{ See~\ref{appa} on page~\pageref{appa} for a complete listing of REDUCE prefix forms that can be translated.}. {\it form\/} may contain any number of occurrences of the special forms \ttindex{EVAL} \ttindex{LSETQ} \ttindex{RSETQ} \ttindex{LRSETQ} \ttindex{DECLARE} \ttindex{LITERAL} {\bf EVAL}, {\bf LSETQ}, {\bf RSETQ}, {\bf LRSETQ}, {\bf DECLARE}, and {\bf LITERAL} (see sections~\ref{sym:cg} through \ref{special} on pages~\pageref{sym:cg}--\pageref{special}). \end{describe} \begin{describe}{Side Effects:} {\bf SYM!-GENTRAN} translates {\it form\/} into formatted code in the target language and writes it to the file(s) currently selected for output. \end{describe} \begin{describe}{Returned Value:} {\bf SYM!-GENTRAN} returns the name(s) of the file(s) to which code was written. If code was written to one file, the returned value is an atom; otherwise, it is a list. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** WRONG TYPE OF ARG \end{verbatim} {\it exp} \begin{verbatim} ***** CANNOT BE TRANSLATED \end{verbatim} \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: SYMBOLIC$ 2: GENTRANLANG!* := 'FORTRAN$ 3: SYM!-GENTRAN '(FOR I (1 1 n) DO (SETQ (V I) 0))$ DO 25001 I=1,N V(I)=0.0 25001 CONTINUE 4: GENTRANLANG!* := 'RATFOR$ 5: SYM!-GENTRAN '(FOR I (1 1 N) DO 5: (FOR J ((PLUS I 1) 1 N) DO 5: (PROGN 5: (SETQ (X J I) (X I J)) 5: (SETQ (Y J I) (Y I J)))))$ DO I=1,N DO J=I+1,N { X(J,I)=X(I,J) Y(J,I)=Y(I,J) } 6: GENTRANLANG!* := 'C$ 7: SYM!-GENTRAN '(SETQ P (FOR I (1 1 N) PRODUCT I))$ { P=1; for (I=1;I<=N;++I) P*=I; } 8: GENTRANLANG!* := 'PASCAL$ 9: SYM!-GENTRAN '(SETQ C 9: (COND ((LESSP A B) A) (T B)))$ IF A<B THEN C:=A; ELSE C:=B; \end{verbatim} \end{describe} \subsubsection{Code Generation} \index{code generation} \label{sym:cg} Sections~\ref{eval} through~\ref{lrsetq} on pages~\pageref{eval}--\pageref{lrsetq} described the special functions and operators {\bf EVAL}, {\bf ::=}, {\bf :=:}, and {\bf ::=:} that could be included in arguments to the {\bf GENTRAN} command to indicate that parts of those arguments were to be given to REDUCE FOR Evaluation prior to translation. This section describes the analogous functions that can be supplied in prefix form to the {\bf SYM!-GENTRAN} function. The following special forms may be interleaved arbitrarily in forms supplied as arguments to {\bf SYM!-GENTRAN} to specify partial \ttindex{EVAL} \ttindex{LSETQ} \ttindex{RSETQ} \ttindex{LRSETQ} evaluation: {\bf EVAL}, {\bf LSETQ}, {\bf RSETQ}, and {\bf LRSETQ}. Sections~\ref{sym:eval} through \ref{sym:lrsetq} describe these forms. Then section~\ref{lispeval} through \ref{share} present examples of the usage of these forms for evaluation of expressions in both symbolic and algebraic modes. \paragraph{The EVAL Form} \label{sym:eval} \begin{describe}{Syntax:} \ttindex{EVAL} {\bf (EVAL} {\it form\/}{\bf )} \end{describe} \begin{describe}{Argument:} {\it form\/} is any LISP prefix form that evaluates to a REDUCE prefix form that can be translated by GENTRAN into the target language. \end{describe} \paragraph{The LSETQ Form} \ttindex{LSETQ} \begin{describe}{Syntax:} {\bf (LSETQ} {\it svar exp\/}{\bf )} \end{describe} \begin{describe}{Arguments:} {\it svar\/} is a subscripted variable in LISP prefix form. Its subscripts must evaluate to REDUCE prefix forms that can be translated into the target language. {\it exp\/} is any REDUCE expression in prefix form that can be translated by GENTRAN. \end{describe} \paragraph{The RSETQ Form} \ttindex{RSETQ} \begin{describe}{Syntax:} {\bf (RSETQ} {\it var exp\/}{\bf )} \end{describe} \begin{describe}{Arguments:} {\it var\/} is a variable in REDUCE prefix form. {\it exp\/} is a LISP prefix form which evaluates to a translatable REDUCE prefix form. \end{describe} \paragraph{The LRSETQ Form} \ttindex{RSETQ} \label{sym:lrsetq} \begin{describe}{Syntax:} {\bf (LRSETQ} {\it svar exp\/}{\bf )} \end{describe} \begin{describe}{Arguments:} {\it svar\/} is a subscripted variable in LISP prefix form with subscripts that evaluate to REDUCE prefix forms that can be translated by GENTRAN. {\it exp\/} is a LISP prefix form that evaluates to a translatable REDUCE prefix form. \end{describe} \paragraph{Symbolic Mode Evaluation} \label{lispeval} The symbolic mode evaluation forms that have just been described are analogous to their algebraic mode counterparts, except that by default, they evaluate their argument(s) in symbolic mode. The following is an example of evaluation of subscripts in symbolic mode: \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: SYMBOLIC$ 2: FOR i:=1:2 DO 2: FOR j:=1:2 DO 2: SYM!-GENTRAN '(LSETQ (M i j) 0)$ M(1,1)=0.0 M(1,2)=0.0 M(2,1)=0.0 M(2,2)=0.0 \end{verbatim} \end{describe} \paragraph{Algebraic Mode Evaluation} As we have just seen, the symbolic mode evaluation forms evaluate their argument(s) in symbolic mode. This default evaluation mode can be overridden by explicitly requesting evaluation in algebraic mode with the REDUCE {\bf AEVAL} function.\ttindex{AEVAL} \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: ALGEBRAIC$ 2: F := 2*x^2 - 5*X + 6$ 3: SYMBOLIC$ 4: SYM!-GENTRAN '(SETQ Q (QUOTIENT 4: (EVAL (AEVAL 'F)) 4: (EVAL (AEVAL '(DF F X)))))$ Q=(2.0*X**2-5.0*X+6.0)/(4.0*X-5.0) 5: ALGEBRAIC$ 6: M := MAT(( A, 0, -1, 1), 6: ( 0, B^2, 0, 1), 6: (-1, B, B*C, 0), 6: ( 1, 0, -C, -D))$ 7: SYMBOLIC$ 8: FOR i:=1:4 DO 8: SYM!-GENTRAN '(LRSETQ (M i i) (AEVAL (MKQUOTE (LIST 'M i i))))$ M(1,1)=A M(2,2)=B**2 M(3,3)=B*C M(4,4)=-D \end{verbatim} \end{describe} \paragraph{SHAREd Variables} \label{share} \index{SHARE command} The REDUCE {\bf SHARE} command enables variables to be shared between algebraic and symbolic modes. Thus, we can derive an expression in algebraic mode, assign it to a shared variable, and then access the value of that variable to generate code from symbolic mode. \begin{describe}{Example:} \begin{verbatim} 1: ALGEBRAIC$ 2: SHARE dfx1$ 3: dfx1 := DF(X**4 - X**3 + 2*X**2 + 1, X)$ 4: SYMBOLIC$ 5: SYM!-GENTRAN '(RSETQ DERIV dfx1)$ DERIV=4.0*X**3-(3.0*X**2)+4.0*X \end{verbatim} \end{describe} \subsubsection{Special Translatable Forms} \label{special} Sections~\ref{explicit:type} through \ref{comments} described special functions that could be used to declare variable types and insert literal strings of characters into generated code. This section contains explanations of analogous prefix forms for usage in symbolic mode. \paragraph{Explicit Type Declarations} A similar form of the algebraic mode {\bf DECLARE} function is provided in symbolic mode: \begin{describe}{Syntax:} \index{DECLARE function} \begin{tabular}{ll} {\bf (DECLARE} & {\bf (}{\it type1 v1 v2 \dots\ vn1\/}{\bf )}\\ & {\bf (}{\it type2 v1 v2 \dots\ vn2\/}{\bf )}\\ & \ \ \ :\\ & {\bf (}{\it typen v1 v2 \dots\ vnn\/}{\bf )) }\\ \end{tabular} \end{describe} \begin{describe}{Arguments:} Each {\it v1 v2 \dots\ vn\/} is a sequence of one or more variables (optionally subscripted to indicate array dimensions -- in prefix form), or variable ranges (two letters concatenated together with "-" in between). {\it v\/}s are not evaluated unless given as arguments to {\bf EVAL}. Each {\it type\/} is a variable type in the target language. Each must be an atom, optionally concatenated to the atom {\bf IMPLICIT!\ } (note the trailing space). \index{IMPLICIT"! atom} {\it type\/}s are not evaluated unless given as arguments to {\bf EVAL}. \end{describe} \begin{describe}{Side Effect:} Entries are placed in the symbol table for each variable or variable range declared in the call to this function. The function call itself is removed from the statement group being translated. Then after translation, type declarations are generated from these symbol table entries before the resulting executable statements are printed. \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: SYMBOLIC$ 2: GENTRANLANG!* := 'FORTRAN$ 3: SYM!-GENTRAN 3: '(PROGN 3: (DECLARE (IMPLICIT! REAL!*8 A!-H O!-Z) 3: (INTEGER (M 4 4))) 3: (FOR I (1 1 4) DO 3: (FOR J (1 1 4) DO 3: (COND ((EQUAL I J) (SETQ (M I J) 1)) 3: (T (SETQ (M I J) 0))))) 3: (DECLARE (INTEGER I J)) : : 3: )$ IMPLICIT REAL*8 (A-H,O-Z) INTEGER M(4,4),I,J DO 25001 I=1,4 DO 25002 J=1,4 IF (I.EQ.J) THEN M(I,J)=1 ELSE M(I,J)=0 ENDIF 25002 CONTINUE 25001 CONTINUE : : 4: GENTRANLANG!* := 'RATFOR$ 5: SYM!-GENTRAN 5: '(PROCEDURE FAC NIL EXPR (N) 5: (BLOCK () 5: (DECLARE (FUNCTION FAC) 5: (INTEGER FAC N)) 5: (SETQ F (FOR I (1 1 N) PRODUCT I)) 5: (DECLARE (INTEGER F I)) 5: (RETURN F)))$ INTEGER FUNCTION FAC(N) INTEGER N,F,I { F=1 DO I=1,N F=F*I } RETURN(F) END 6: GENTRANLANG!* := 'C$ 7: SYM!-GENTRAN 7: '(PROCEDURE FAC NIL EXPR (N) 7: (BLOCK () 7: (DECLARE (INTEGER FAC N I F)) 7: (SETQ F (FOR I (1 1 N) PRODUCT I)) 7: (RETURN F)))$ int FAC(N) int N; { int I,F; { F=1; for (I=1;I<=N;++I) F*=I; } return(F); } 8: GENTRANLANG!* := 'PASCAL$ 9: SYM!-GENTRAN 9: '(PROCEDURE FAC NIL EXPR (N) 9: (BLOCK () 9: (DECLARE (INTEGER FAC N I F)) 9: (SETQ F (FOR I (1 1 N) PRODUCT I)) 9: (RETURN F)))$ FUNCTION FAC(N:INTEGER):INTEGER; LABEL 99999; VAR I,F: INTEGER; BEGIN BEGIN F:=1; FOR I:=1 TO N DO F:=F*I END; BEGIN FAC:=F; GOTO 99999{RETURN} END; 99999: END; \end{verbatim} \end{describe} \paragraph{Comments and Literal Strings} \index{comments ! in GENTRAN} \index{literals ! in GENTRAN} \ttindex{LITERAL} A form similar to the algebraic mode {\bf LITERAL} function is provided in symbolic mode: \begin{describe}{Syntax:} {\bf (LITERAL} {\it arg1 arg2 \dots\ argn\/}{\bf )} \end{describe} \begin{describe}{Arguments:} {\it arg1 arg2 \dots\ argn\/} is an argument sequence containing one or more {\it arg\/}s, where each {\it arg\/} either is, or evaluates to, an atom. The atoms {\bf TAB!*} and {\bf CR!*} have special meanings. \ttindex{TAB"!*} \ttindex{CR"!*} {\it arg\/}s are not evaluated unless given as arguments to {\bf EVAL}. \end{describe} \begin{describe}{Side Effect:} This form is replaced by the character sequence resulting from concatenation of the given atoms. Double quotes are stripped from all string type {\it arg\/}s, and the reserved atoms {\bf TAB!*} and {\bf CR!*} are replaced by a tab to the current level of indentation, and an end-of-line character, respectively. \end{describe} \begin{describe}{\example}\index{GENTRAN package ! example} \begin{verbatim} 1: SYMBOLIC$ 2: GENTRANLANG!* := 'FORTRAN$ 3: N := 100$ 4: SYM!-GENTRAN 4: '(PROGN 4: (LITERAL C TAB!* "--THIS IS A FORTRAN COMMENT--" 4: CR!* C CR!*) 4: (LITERAL TAB!* "DATA N/" (EVAL N) "/" CR!*))$ C --THIS IS A FORTRAN COMMENT-- C DATA N/100/ 5: GENTRANLANG!* := 'RATFOR$ 6: SYM!-GENTRAN 6: '(FOR I (1 1 N) DO 6: (PROGN 6: (LITERAL TAB!* "# THIS IS A RATFOR COMMENT" CR!*) 6: (LITERAL TAB!* "WRITE(6,10) (M(I,J),J=1,N)" CR!* 6: 10 TAB!* "FORMAT(1X,10(I5,3X))" CR!*)))$ DO I=1,N { # THIS IS A RATFOR COMMENT WRITE(6,10) (M(I,J),J=1,N) 10 FORMAT(1X,10(I5,3X)) } 7: GENTRANLANG!* := 'C$ 8: SYM!-GENTRAN 8: '(PROGN 8: (SETQ X 0) 8: (LITERAL "/* THIS IS A" CR!* " 8: C COMMENT */" CR!*))$ { X=0.0; /* THIS IS A C COMMENT */ } 9: GENTRANLANG!* := 'PASCAL$ 10: SYM!-GENTRAN 10: '(PROGN 10: (SETQ X (SIN Y)) 10: (LITERAL "{ THIS IS A PASCAL COMMENT }" CR!*))$ BEGIN X:=SIN(Y) { THIS IS A PASCAL COMMENT } END; \end{verbatim} \end{describe} \subsection{Template Processing} \index{template processing} The template processor can be invoked from either algebraic or symbolic mode. Section~\ref{templates} described the algebraic mode command. This section describes the analogous symbolic mode function. \begin{describe}{Syntax:}\index{SYM"!-GENTRANIN command} {\bf SYM!-GENTRANIN} {\it list-of-fnames\/}; \end{describe} \begin{describe}{Function Type:} expr \end{describe} \begin{describe}{Argument:} {\it list-of-fnames\/} evaluates to a LISP list containing one or more {\it fname\/}s, where each {\it fname\/} is one of: \begin{tabular}{lll} {\it an atom} & = & a template (input) file\\ {\bf T} & = & the terminal\\ \end{tabular} \end{describe} \begin{describe}{Side Effects:} {\bf SYM!-GENTRANIN} processes each template file in {\it list-of-fnames\/} sequentially. A template file may contain any number of parts, each of which is either an active or an inactive part. All active parts start with the character sequence {\bf ;BEGIN;} and end with {\bf ;END;}. The end of the template file is indicated by an extra {\bf ;END;} character sequence. Inactive parts of template files are assumed to contain code in the target language (FORTRAN, RATFOR, PASCAL or C, depending on the value of the global varibale {\bf GENTRANLANG!*}). All inactive parts are copied to the output. Comments delimited by the appropriate characters are also copied in their entirety to the output. Thus the character sequences {\bf ;BEGIN;} and {\bf ;END;} have no special meanings within comments. \index{;BEGIN; marker} \index{;END; marker} Active parts may contain any number of REDUCE expressions, statements, and commands. They are not copied directly to the output. Instead, they are given to REDUCE for evaluation in algebraic mode\footnote{ Active parts are evaluated in algebraic mode unless the mode is explicitly changed to symbolic from within the active part itself. This is true regardless of which mode the system was in when the template processor was called.}. All output generated by each evaluation is sent to the file(s) currently selected for output. Returned values are only printed on the terminal. Active parts will most likely contain calls to GENTRAN to generate code. This means that the result of processing a template file will be the original template file with all active parts replaced by generated code. \end{describe} \begin{describe}{Returned Value:} {\bf SYM!-GENTRANIN} returns the name(s) of the file(s) to which code was written. If code was written to one file, the returned value is an atom; otherwise, it is a list. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** NONEXISTENT INPUT FILE ***** TEMPLATE FILE ALREADY OPEN FOR INPUT ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \subsection{Output Redirection} \index{output redirection (temporary)} Section~\ref{GENTRAN:output} describes four slgebraic mode commands which select, open, and close output files. The algebraic mode commands \index{GENTRANOUT command} \index{GENTRANSHUT command} \index{GENTRANPUSH command} \index{GENTRANPOP command} {\bf GENTRANOUT}, {\bf GENTRANSHUT}, {\bf GENTRANPUSH}, and {\bf GENTRANPOP} are analogous to the symbolic mode {\bf SYM!-GENTRANOUT}, {\bf SYM!-GENTRANSHUT}, {\bf SYM!-GENTRANPUSH}, and {\bf SYM!-GENTRANPOP} functions, respectively. \subsubsection{SYM!-GENTRANOUT} \index{SYM"!-GENTRANOUT command} \begin{describe}{Syntax:} {\bf SYM!-GENTRANOUT} {\it list-of-fnames\/}; \end{describe} \begin{describe}{Function Type:} expr \end{describe} \begin{describe}{Argument:} {\it list-of-fnames\/} evaluates to a LISP list containing one or more {\it fname\/}s, where each {\it fname} is one of: \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf T} & = & the terminal\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{describe} \begin{describe}{Side Effect:} GENTRAN maintains a list of files currently open for output by GENTRAN {\it only}. {\bf SYM!-GENTRANOUT} inserts each file name represented in {\it list-of-fnames\/} into that list and opens each one for output. It also resets the currently selected output file(s) to be all of the files represented in {\it list-of-fnames}. \end{describe} \begin{describe}{Returned Value:} {\bf SYM!-GENTRANOUT} returns the name(s) of the file(s) represented by {\it list-of-fnames\/}; i.e., the current output file(s) after the command has been executed. If there is only one file selected for output, the returned value is an atom; otherwise, it is a list. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \subsubsection{SYM!-GENTRANSHUT}\index{SYM"!-GENTRANSHUT command} \begin{describe}{Syntax:} {\bf SYM!-GENTRANSHUT} {\it list-of-fnames\/} ; \end{describe} \begin{describe}{Function Type:} expr \end{describe} \begin{describe}{Argument:} {\it list-of-fnames\/} evaluates to a LISP list containing one or more {\it fnames}, where each {\it fname\/} is one of: \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{describe} \begin{describe}{Side Effects:} {\bf SYM!-GENTRANSHUT} creates a list of file names from {\it list-of-fnames}, deletes each from the output file list, and closes the corresponding files. If (all of) the current output file(s) are closed, then the current output file is reset to the terminal. \end{describe} \begin{describe}{Returned Value:} {\bf SYM!-GENTRANSHUT} returns the name(s) of the file(s) selected for output after the command has been executed. If there is only one file selected for output, the returned value is an atom; otherwise, it is a list. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** FILE NOT OPEN FOR OUTPUT ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \subsubsection{SYM!-GENTRANPUSH}\index{SYM"!-GENTRANPUSH command} \begin{describe}{Syntax:} {\bf SYM!-GENTRANPUSH} {\it list-of-fnames\/}; \end{describe} \begin{describe}{Function Type:} expr \end{describe} \begin{describe}{Argument:} {\it list-of-fnames\/} evaluates to a LISP list containing one or more {\it fname}s, each of which is one of: \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf T} & = & the terminal\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{describe} \begin{describe}{Side Effects:} {\bf SYM!-GENTRANPUSH} creates a list of file name(s) from {\it lis-of-fnames\/} and pushes that list onto the output stack. Each file in the list that is not already open for output is opened at this time. The current output file is reset to this new element on the top of the stack. \end{describe} \begin{describe}{Returned Value:} {\bf SYM!-GENTRANPUSH} returns the name(s) of the file(s) represented by {\it list-of-fnames\/}; i.e., the current output file(s) after the command has been executed. If there is only one file selected for output, the returned value is an atom; otherwise, it is a list. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** OUTPUT FILE ALREADY EXISTS OVERWRITE FILE? (Y/N) ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \subsubsection{SYM!-GENTRANPOP} \index{SYM"!-GENTRANPOP command} \begin{describe}{Syntax:} {\bf SYM!-GENTRANPOP} {\it list-of-fnames\/}; \end{describe} \begin{describe}{Function Type:} expr \end{describe} \begin{describe}{Argument:} {\it list-of-fnames\/} evaluates to a LISP list containing one or more {\it fname\/}s, where each {\it fname\/} is one of: \begin{tabular}{lll} {\it an atom} & = & an output file\\ {\bf T} & = & the terminal\\ {\bf NIL} & = & the current output file(s)\\ {\bf ALL!*} & = & all files currently open for output \\ & & by GENTRAN\\ \end{tabular} \end{describe} \begin{describe}{Side Effects:} {\bf SYM!-GENTRANPOP} deletes the top-most occurrence of the single element containing the file name(s) represented by {\it list-of-fnames\/} from the output stack. Files whose names have been completely removed from the output stack are closed. The current output file is reset to the (new) element on the top of the output stack. \end{describe} \begin{describe}{Returned Value:} {\bf SYM!-GENTRANPOP} returns the name(s) of the file(s) selected for output after the command has been executed. If there is only one file selected for output, the returned value is an atom; otherwise, it is a list. \end{describe} \begin{describe}{Diagnostic Messages:} \begin{verbatim} *** FILE NOT OPEN FOR OUTPUT ***** WRONG TYPE OF ARG \end{verbatim} \end{describe} \section{Translatable REDUCE Expressions \& Statements} \label{appa} A substantial subset of all REDUCE expressions and statements can be translated by GENTRAN into semantically equivalent code in the target numerical language\footnote{ It should be noted that call-by-value parameter passing is used in REDUCE, whereas call-by-address parameter passing is normally used in FORTRAN and RATFOR. GENTRAN does {\it not} attempt to simulate call-by-value passing in FORTRAN and RATFOR, although this could be done by generating temporary variables, assigning values to them, and using them in subprogram calls. \index{call-by-value} \index{call-by-address}}. This section contains examples and a formal definition of translatable REDUCE expressions and statements. \subsection{Examples of Translatable Statements} The following three tables contain listings of REDUCE statement types that can be translated by GENTRAN. An example of each statement type is shown, and FORTRAN, RATFOR, PASCAL and C code generated for each example is also shown. \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline simple &{\bf V:=X\^{}2+X\$} &\verb! V=X**2+X!\\ & & \\ matrix &{\bf M:=MAT((U,V),} &\verb! M(1,1)=U!\\ & {\bf\ \ \ \ \ \ \ \ (W,X))\$ } &\verb! M(1,2)=V!\\ & &\verb! M(2,1)=W!\\ & &\verb! M(2,2)=X!\\ & & \\ sum &{\bf S:=FOR I:=1:10} &\verb! S=0.0!\\ &{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb! DO 25001 I=1,10!\\ & &\verb! S=S+V(I)!\\ & &\verb!25001 CONTINUE!\\ & & \\ product &{\bf P:=FOR I:=2 STEP 2} &\verb! P=1!\\ &{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb! DO 25002 I=2,N,2!\\ &{\bf \ \ \ \ PRODUCT I\$} &\verb! P=P*I!\\ & &\verb!25002 CONTINUE!\\ & & \\ conditional & {\bf X := IF A$<$B THEN} &\verb! IF (A.LT.B) THEN!\\ & {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb! X=A!\\ & &\verb! ELSE!\\ & &\verb! X=B!\\ & &\verb! ENDIF!\\ & & \\ \hline\hline \end{tabular} \caption{REDUCE assignments translatable to FORTRAN} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline for &{\bf FOR I:=1:8 DO} &\verb! DO 25003 I=1,8!\\ &{\bf \ \ \ \ V(I):=0.0\$} &\verb! V(I)=0.0!\\ & &\verb!25003 CONTINUE!\\ & & \\ while &{\bf WHILE F(N)$>$0.0 DO} &\verb!25004 IF(.NOT.F(N).GT.0.0)!\\ & &\verb! . GOTO 25005!\\ &{\bf \ \ \ \ N:=N+1\$} &\verb! N=N+1!\\ & &\verb! GOTO 25004!\\ & &\verb!25005 CONTINUE!\\ & & \\ repeat &{\bf REPEAT X:=X/2.0} &\verb!25006 CONTINUE!\\ &{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb! X=X/2.0!\\ & &\verb! IF(.NOT.F(X).LT.0.0)!\\ & &\verb! . GOTO 25006!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE Loop structures translatable to FORTRAN} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline Conditionals:& &\\ & &\\ if &{\bf IF X$>$0.0} &\verb! IF (X.GT.0.0) THEN!\\ & {\bf \ \ \ \ \ \ \ THEN Y:=X\$} &\verb! Y=X!\\ & &\verb! ENDIF!\\ & &\\ if - else &{\bf IF X$>$0.0 THEN Y:=X} &\verb! IF (X.GT.0.0) THEN!\\ &{\bf\ \ \ \ ELSE Y:=-X\$}&\verb! Y=X!\\ & &\verb! ELSE!\\ & &\verb! Y=-X!\\ & &\verb! ENDIF!\\ & & \\\hline Unconditional& &\\ Transfer of & &\\ Control: & &\\ & &\\ goto&{\bf GOTO LOOP\$} &\verb! GOTO 25010!\\ & &\\ call&{\bf CALCV(V,X,Y,Z)\$} &\verb! CALL CALCV(V,X,Y,Z)!\\ & &\\ return &{\bf RETURN X\^{}2\$} &\verb! !{\it functionname\/}\verb!=X**2!\\ & &\verb! RETURN!\\ & & \\\hline Sequences \& & &\\ Groups: & &\\ & &\\ sequence &{\bf $<$$<$ U:=X\^{}2;}&\verb! U=X**2!\\ & {\bf \ \ \ \ \ \ \ \ V:=Y\^{}2$>$$>$\$} &\verb! V=Y**2!\\ & &\\ group &{\bf BEGIN}&\verb! U=X**2!\\ &{\bf\ \ \ \ U:=X\^{}2;}&\verb! V=Y**2!\\ &{\bf\ \ \ \ V:=Y\^{}2} &\\ &{\bf END\$}&\\ & & \\\hline\hline \end{tabular} \caption{REDUCE control structures translatable to FORTRAN} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf RATFOR CODE} \\ \hline\hline Assignments: & &\\ & & \\ simple &{\bf V:=X\^{}2+X\$} &\verb!V=X**2+X!\\ & & \\ matrix &{\bf M:=MAT((U,V),(W,X))\$} &\verb!M(1,1)=U!\\ & &\verb!M(1,2)=V!\\ & &\verb!M(2,1)=W!\\ & &\verb!M(2,2)=X!\\ & & \\ sum &{\bf S:=FOR I:=1:10} &\verb!S=0.0!\\ &{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!DO I=1,10!\\ & &\verb! S=S+V(I)!\\ & & \\ product &{\bf P:=FOR I:=2 STEP 2} &\verb!P=1!\\ &{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!DO I=2,N,2!\\ &{\ \ \ \ PRODUCT I\$} &\verb! P=P*I!\\ & & \\ conditional & {\bf X := IF A$<$B THEN} &\verb!IF (A<B)!\\ & {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb! X=A!\\ & &\verb!ELSE!\\ & &\verb! X=B!\\ & & \\\hline Control & & \\ Structures: & &\\ & & \\ Loops: & &\\ & &\\ for &{\bf FOR I:=1:8 DO} &\verb!DO I=1,8!\\ &{\bf \ \ \ \ V(I):=0.0\$} &\verb! V(I)=0.0!\\ & & \\ while &{\bf WHILE F(N)$>$0.0 DO} &\verb!WHILE(F(N)>0.0)!\\ &{\bf \ \ \ \ N:=N+1\$} &\verb! N=N+1!\\ & & \\ repeat &{\bf REPEAT X:=X/2.0} &\verb!REPEAT!\\ &{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb! X=X/2.0!\\ & &\verb!UNTIL(F(X)<0.0)!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to RATFOR} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf RATFOR CODE} \\ \hline\hline Conditionals:& &\\ & &\\ if &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!IF(X>0.0)!\\ & &\verb! Y=X!\\ & &\\ if - else &{\bf IF X$>$0.0 THEN Y:=X} &\verb!IF(X>0.0)!\\ &{\bf\ \ \ \ ELSE Y:=-X\$}&\verb! Y=X!\\ & &\verb!ELSE!\\ & &\verb! Y=-X!\\ & & \\\hline Unconditional& &\\ Transfer of & &\\ Control: & &\\ & &\\ goto&{\bf GOTO LOOP\$} &\verb!GOTO 25010!\\ & &\\ call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALL CALCV(V,X,Y,Z)!\\ & &\\ return &{\bf RETURN X\^{}2\$} &\verb!RETURN(X**2)!\\ & & \\\hline Sequences \& & &\\ Groups: & &\\ & &\\ sequence &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!U=X**2!\\ & &\verb!V=Y**2!\\ & &\\ group &{\bf BEGIN}&\verb!{!\\ &{\bf\ \ \ \ U:=X\^{}2;}& \verb! U=X**2!\\ &{\bf\ \ \ \ V:=Y\^{}2} & \verb! V=Y**2!\\ &{\bf END\$}&\verb!}!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to RATFOR} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline Assignments: & &\\ & & \\ simple &{\bf V:=X\^{}2+X\$} &\verb!V=X**2+X;!\\ & & \\ matrix &{\bf M:=MAT((U,V),} &\verb!BEGIN!\\ & {\bf \ \ \ \ \ \ \ \ (W,X))\$} &\verb! M(1,1)=U;!\\ & &\verb! M(1,2)=V;!\\ & &\verb! M(2,1)=W;!\\ & &\verb! M(2,2)=X;!\\ & &\verb!END;!\\ & & \\ sum &{\bf S:=FOR I:=1:10} &\verb!BEGIN!\\ &{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb! S=0.0!\\ & &\verb! FOR I:=1 TO 10 DO!\\ & &\verb! S:=S+V(I)!\\ & &\verb!END;!\\ & & \\ product &{\bf P:=FOR I:=2:N} &\verb!BEGIN!\\ &{\bf \ \ \ \ PRODUCT I\$} &\verb! P:=1;!\\ & &\verb! FOR I:=2 TO N DO!\\ & &\verb! P:=P*I!\\ & &\verb!END;!\\ & & \\ conditional & {\bf X := IF A$<$B THEN} &\verb!IF (A<B) THEN!\\ & \ \ \ \ \ \ {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb! X:=A;!\\ & &\verb!ELSE!\\ & &\verb! X:=B;!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to PASCAL} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline Control & & \\ Structures: & &\\ & & \\ Loops: & &\\ & &\\ for &{\bf FOR I:=1:8 DO} &\verb!FOR I:=1 TO 8 DO!\\ &{\bf \ \ \ \ V(I):=0.0\$} &\verb! V(I):=0.0;!\\ & & \\ while &{\bf WHILE F(N)$>$0.0 DO} &\verb!WHILE (F(N)>0.0)!\\ &{\bf \ \ \ \ N:=N+1\$} &\verb! N:=N+1.0;!\\ & & \\ repeat &{\bf REPEAT X:=X/2.0} &\verb!REPEAT!\\ &{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb! X:=X/2.0!\\ & &\verb!UNTIL F(X)<0.0;!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to PASCAL} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline Conditionals:& &\\ & &\\ if &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!IF X>0.0 THEN!\\ & &\verb! Y:=X;!\\ & &\\ if - else &{\bf IF X$>$0.0 THEN Y:=X} &\verb!IF X>0.0 THEN!\\ &{\bf\ \ \ \ ELSE Y:=-X\$}&\verb! Y:=X;!\\ & &\verb!ELSE!\\ & &\verb! Y:=-X;!\\ & & \\\hline Unconditional& &\\ Transfer of & &\\ Control: & &\\ & &\\ goto&{\bf GOTO LOOP\$} &\verb!GOTO 25010;!\\ & &\\ call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALCV(V,X,Y,Z);!\\ & &\\ return &{\bf RETURN X\^{}2\$} &{\it functionname\/}\verb!=X**2;!\\ & &\verb!GOTO 99999{RETURN}!\\ & &\verb!99999;!\\ & & \\\hline Sequences \& & &\\ Groups: & &\\ & &\\ sequence &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!BEGIN!\\ &&\verb! U:=X**2;!\\ &&\verb! V:=Y**2!\\ &&\verb!END;!\\ & &\\ group &{\bf BEGIN}&\verb!BEGIN!\\ &{\bf\ \ \ \ U:=X\^{}2;}&\verb! U:=X**2;!\\ &{\bf\ \ \ \ V:=Y\^{}2} &\verb! V:=Y**2!\\ &{\bf END\$}&\verb!END!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to PASCAL} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf C CODE} \\ \hline\hline Assignments: & &\\ & & \\ simple &{\bf V:=X\^{}2+X\$} &\verb!V=power(X,2)+X;!\\ & & \\ matrix &{\bf M:=MAT((U,V),(W,X))\$} &\verb!M[1][1]=U;!\\ & &\verb!M[1][2]=V;!\\ & &\verb!M[2][1]=W;!\\ & &\verb!M[2][2]=X;!\\ & & \\ sum &{\bf S:=FOR I:=1:10} &\verb!S=0.0;!\\ &{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!for(I=1;I<=10;++I)!\\ & &\verb! S+=V[I];!\\ & & \\ product &{\bf P:=FOR I:=2 STEP 2} &\verb!P=1;!\\ &{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!for(I=2;I<=N;++I)!\\ &{\ \ \ \ PRODUCT I\$} &\verb! P*=I;!\\ & & \\ conditional & {\bf X := IF A$<$B THEN} &\verb!if (A<B)!\\ & {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb! X=A;!\\ & &\verb!else!\\ & &\verb! X=B;!\\ & & \\\hline Control & & \\ Structures: & &\\ & & \\ Loops: & &\\ & &\\ for &{\bf FOR I:=1:8 DO} &\verb!for(I=1;I<=8;++I)!\\ &{\bf \ \ \ \ V(I):=0.0\$} &\verb! V[I]=0.0;!\\ & & \\ while &{\bf WHILE F(N)$>$0.0 DO} &\verb!while(F(N)>0.0)!\\ &{\bf \ \ \ \ N:=N+1\$} &\verb! N+=1;!\\ & & \\ repeat &{\bf REPEAT X:=X/2.0} &\verb!do!\\ &{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb! X/=2.0;!\\ & &\verb!while(F(X)>=0.0);!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to C} \end{table} \begin{table} \begin{tabular}{||l|l|l||}\hline\hline \multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} & \multicolumn{1}{c||}{\bf C CODE} \\ \hline\hline Conditionals:& &\\ & &\\ if &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!if(X>0.0)!\\ & &\verb! Y=X;!\\ & &\\ if - else &{\bf IF X$>$0.0 THEN Y:=X} &\verb!if(X>0.0)!\\ &{\bf\ \ \ \ ELSE Y:=-X\$}&\verb! Y=X;!\\ & &\verb!else!\\ & &\verb! Y=-X;!\\ & & \\\hline Unconditional& &\\ Transfer of & &\\ Control: & &\\ & &\\ goto&{\bf GOTO LOOP\$} &\verb!goto LOOP;!\\ & &\\ call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALCV(V,X,Y,Z);!\\ & &\\ return &{\bf RETURN X\^{}2\$} &\verb!return(power(X,2) );!\\ & & \\\hline Sequences \& & &\\ Groups: & &\\ & &\\ sequence &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!U=power(X,2);!\\ & &\verb!V=power(Y,2);!\\ & &\\ group &{\bf BEGIN}&\verb!{!\\ &{\bf\ \ \ \ U:=X\^{}2;}& \verb! U=power(x,2);!\\ &{\bf\ \ \ \ V:=Y\^{}2} & \verb! V=power(Y,2);!\\ &{\bf END\$}&\verb!}!\\ & & \\\hline\hline \end{tabular} \caption{REDUCE forms translatable to C} \end{table} \subsection{Formal Definition} The remainder of this section contains a formal definition of all REDUCE expressions, statements, and prefix forms that can be translated by GENTRAN into FORTRAN, RATFOR, PASCAL and C code. \begin{describe}{Preliminary Definitions} An {\it id\/} is an identifier. Certain {\it id\/}'s are reserved words and may not be used as array names or subprogram names. The complete list appears in the {\it Reserved Words\/} section. A {\it string\/} consists of any number of characters (excluding double quotes) which are enclosed in double quotes. \end{describe} \begin{describe}{Reserved Words}\index{reserved words} The following reserved words may not be used as array names or subprogram names\footnote{Note that names of other built-in REDUCE functions {\it can\/} be translated, but remember that they will be translated {\it literally\/} unless {\bf EVAL}'d first. For example: {\bf GENTRAN~DERIV~:=~DF(2*X\^{}2-X-1,~X)\$} generates {\tt DERIV=DF(2*X**2-X-1,X)} whereas {\bf GENTRAN~DERIV~:=:~DF(2*X\^{}2-X-1,~X)\$} generates {\tt DERIV=4*X-1} }: {\bf AND, BLOCK, COND, DIFFERENCE, EQUAL, EXPT, FOR, GEQ, GO, GREATERP, LEQ, LESSP, MAT, MINUS, NEQ, NOT, OR, PLUS, PROCEDURE, PROGN, QUOTIENT, RECIP, REPEAT, RETURN, SETQ, TIMES, WHILE, WRITE} \end{describe} \subsubsection{Translatable REDUCE Expressions and Statements} \begin{describe}{Expressions} \begin{tabular}{lll} \multicolumn{3}{l}{Arithmetic Expressions:} \\ & & \\ exp & ::= & {\it number} $\mid$ var $\mid$ funcall $\mid$ - exp $\mid$ / exp $\mid$ exp + exp $\mid$ \\ & & exp - exp $\mid$ exp * exp $\mid$ exp / exp $\mid$ exp ** exp $\mid$ \\ & & exp \^{} exp $\mid$ ( exp )\\\\ & & \\ var & ::= & {\it id} $\mid$ {\it id} ( exp$_1$, exp$_2$, \dots\ , exp$_n$ ) $n > 0$ \\ & & \\ funcall & ::= & {\it id} ( arg$_1$, arg$_2$, \dots\ , arg$_n$ ) $n \geq 0$ \\ & & \\ arg & ::= & exp $\mid$ logexp $\mid$ {\it string} \\ & &\\ \multicolumn{3}{l}{Logical Expressions:}\\ & & \\ logexp & ::= & {\it T} $\mid$ {\it NIL} $\mid$ var $\mid$ funcall $\mid$ exp $>$ exp $\mid$ exp $>$= exp $\mid$\\ & & exp = exp $\mid$ exp {\it NEQ} exp $\mid$ exp $<$ exp $\mid$ \\ & & exp $<$= exp $\mid$ {\it NOT\/} logexp $\mid$ logexp {\it AND\/} logexp $\mid$ \\ & & logexp {\it OR\/} logexp $\mid$ ( logexp )\\ \end{tabular} \end{describe} \begin{describe}{Operator Precedence} The following is a list of REDUCE arithmetic and logical operators in order of decreasing precedence: \begin{center} ** (or \^{}) / * --- + $<$ $<$= $>$ $>$= NEQ = NOT AND OR \end{center} When unparenthesised expressions are translated which contain operators whose precedence in REDUCE differs from that in the target language, parentheses are automatically generated. Thus the meaning of the original expression is preserved\footnote{ For example in REDUCE, {\bf NOT~A~=~B} and {\bf NOT~(A~=~B)} are equivalent, whereas in C, {\bf !~A~==~B} and {\bf (!A)~==~B} are equivalent. Therefore, {\bf NOT~A~=~B} is translated into C code which forces the REDUCE precedence rules: {\bf !(A~==~B)} }. \end{describe} \begin{describe}{Statements} \begin{tabular}{lll} stmt & ::= & assign $\mid$ break $\mid$ cond $\mid$ while $\mid$ repeat $\mid$ for $\mid$ goto $\mid$ label $\mid$ \\ & & call $\mid$ return $\mid$ stop $\mid$ stmtgp \\ \end{tabular} Assignment Statements: \begin{tabular}{llll} assign & ::= & \multicolumn{2}{l}{var := assign' $\mid$ matassign $\mid$ cond}\\ & & & \\ assign' & ::= & \multicolumn{2}{l}{exp $\mid$ logexp}\\ & & & \\ matassign & ::= & {\it id} := {\it MAT\/}(&(exp$_{11}$, \dots\ , exp$_{1m}$),\\ & & &(exp$_{21}$, \dots\ , exp$_{2m}$ ),\\ & & & \ \ \ \ \ \ :\\ & & & \ \ \ \ \ \ :\\ & & &( exp$_{n1}$, \dots\ , exp$_{nm}$ ) ) $n,m > 0$ \\ \end{tabular} Break Statement: break ::= {\it BREAK()} Conditional Statements: \begin{tabular}{lll} cond & ::= & {\it IF\/} logexp {\it THEN\/} stmt\\ & & {\it IF\/} logexp {\it THEN\/} stmt {\it ELSE\/} stmt\\ \end{tabular} Loops: \index{FOR loop} \index{WHILE loop} \index{REPEAT loop} \begin{tabular}{lll} while & ::= & {\it WHILE\/} logexp {\it DO\/} stmt\\ & &\\ repeat & ::= & {\it REPEAT\/} stmt {\it UNTIL\/} logexp\\ & &\\ for & ::= & {\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp {\it DO\/} stmt $\mid$\\ & &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it DO\/} stmt $\mid$\\ & &{\it FOR\/} var := exp : exp {\it DO\/} stmt $\mid$\\ & &var := for' $\mid$ \\ & &\\ for' & ::= & var := for' $\mid$\\ & &{\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp {\it SUM\/} exp $\mid$\\ & &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it SUM\/} exp $\mid$\\ & &{\it FOR\/} var := exp : exp {\it SUM\/} exp $\mid$\\ & &{\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp\\ & & \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {\it PRODUCT\/} exp $\mid$ \\ & &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it PRODUCT\/} exp $\mid$\\ & &{\it FOR\/} var := exp : exp {\it PRODUCT\/} exp\\ \end{tabular} Goto Statement: \begin{tabular}{lll} goto & ::= & {\it GOTO\/} label $\mid$ {\it GO TO\/} label\\ label & ::= & {\it id\/} :\\ \end{tabular} Subprogram Calls \& Returns \footnote{ Note that return statements can only be translated from inside of procedure definitions. \index{LITERAL command} The LITERAL function must be used to generate a return statement from anywhere else.}: \begin{tabular}{lll} call & ::= & {\it id\/} ( arg$_1$, arg$_2$, \dots\ , arg$_n$ ) $n \geq 0$\\ & &\\ return & ::= & {\it RETURN\/} $\mid$ {\it RETURN\/} arg\\ \end{tabular} Stop \& Exit Statements \footnote{ In certain cases it may be convenient to generate a FORTRAN STOP statement or a C EXIT statement. Since there is no semantically equivalent REDUCE statement, STOP() can be used and will be translated appropriately.}: stop ::= {\it STOP\/}() Statement Groups \footnote{ Note that REDUCE BEGIN\dots\ END statement groups are translated into RATFOR or C \{\dots\ \} statement groups, whereas REDUCE $<$$<$\dots\ $>$$>$ statement groups are translated into RATFOR or C statement {\it sequences}. When the target language is FORTRAN, both types of REDUCE statement groups are translated into statement sequences.}: \begin{tabular}{lll} stmtgp & ::= & $<$$<$ stmt$_1$ ; stmt$_2$ ; \dots\ ; stmt$_n$ $>$$>$ $\mid$\\ & &{\it BEGIN\/} stmt$_1$ ; stmt$_2$ ; \dots\ ; stmt$_n$ {\it END\/} $ n > 0$\\ \end{tabular} \end{describe} \begin{describe}{Subprogram Definitions} \begin{tabular}{lll} defn & ::= & {\it PROCEDURE id\/} ({\it id$_1$, id$_2$, \dots\ , id$_n$\/}) ; stmt $\mid$\\ & & {\it PROCEDURE id\/} ({\it id$_1$, id$_2$, \dots\ , id$_n$\/}) ; exp\ \ \ \ \ \ $n \geq 0$ \\ \end{tabular} \end{describe} \subsubsection{Translatable REDUCE Prefix Forms} \begin{describe}{Expressions} Arithmetic Expressions: \begin{tabular}{lll} exp & ::= & {\it number\/} $\mid$ funcall $\mid$ var $\mid$ ({\it DIFFERENCE\/} exp exp) $\mid$\\ & &({\it EXPT\/} exp exp) $\mid$ ({\it MINUS\/} exp) $\mid$ ({\it PLUS\/} exp exp') $\mid$\\ & & ({\it QUOTIENT\/} exp exp) $\mid$ ({\it RECIP\/} exp) $\mid$\\ & & ({\it TIMES\/} exp exp exp') $\mid$ ({\it !*SQ\/} sqform)\\ \end{tabular} where sqform is a standard quotient form equivalent to any acceptable prefix form. exp' ::= exp$_1$ exp$_2$ \dots\ exp$_n$ $n \geq 0$ Logical Expressions: \begin{tabular}{lll} logexp & ::= & {\it NIL\/} $\mid$ {\it T\/} $\mid$ funcall $\mid$ var $\mid$\\ & & ({\it AND\/} logexp logexp logexp') $\mid$ ({\it EQUAL\/} exp exp) $\mid$\\ & & ({\it GEQ\/} exp exp) $\mid$ ({\it GREATERP\/} exp exp) $\mid$ \\ & & ({\it LEQ\/} exp exp) $\mid$ ({\it LESSP\/} exp exp) $\mid$ \\ & & ({\it NEQ\/} exp exp) $\mid$ ({\it NOT\/} logexp) $\mid$ \\ & & ({\it OR\/} logexp logexp logexp')\\ & &\\ logexp' & ::= & logexp$_1$ logexp$_2$ \dots\ logexp$_n$ $n \geq 0$\\ \end{tabular} \end{describe} \begin{describe}{Statements} \begin{tabular}{lll} stmt & ::= & assign $\mid$ break $\mid$ call $\mid$ cond $\mid$ for $\mid$ goto $\mid$\\ & & label $\mid$ read $\mid$ repeat $\mid$ return $\mid$ stmtgp $\mid$\\ & & stop $\mid$ while $\mid$ write \\ & &\\ stmt' & ::= & stmt$_1$ stmt$_2$ \dots\ stmt$_n$ $n \geq 0$\\ \end{tabular} Assignment Statements: assign ::= ({\it SETQ\/} var exp) $\mid$ ({\it SETQ\/} var logexp) $\mid$ ({\it SETQ\/} id ({\it MAT\/} list list')) Conditional Statements: \begin{tabular}{lll} cond & ::= & ({\it COND\/} (logexp stmt) cond1) \\ & & \\ cond1 & ::= & (logexp stmt$_1$) \dots\ (logexp stmt$_n$) $n \geq 0$\\ \end{tabular} Loops: \begin{tabular}{lll} for & ::= & ({\it FOR\/} var (exp exp exp) {\it DO\/} stmt) $\mid$\\ & & ({\it SETQ\/} var ({\it FOR\/} var (exp exp exp) {\it SUM\/} exp) $\mid$\\ & & ({\it SETQ\/} var ({\it FOR\/} var (exp exp exp) \\ & & \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {\it PRODUCT\/} exp)\\ & &\\ repeat & ::= & ({\it REPEAT\/} stmt logexp)\\ & &\\ while & ::= & ({\it WHILE\/} logexp stmt) \end{tabular} Go To Statements: \begin{tabular}{lll} break & ::= & ({\it BREAK\/})\\ & & \\ goto & ::= & ({\it GO\/} label)\\ & & \\ label & ::= & {\it id}\\ \end{tabular} Subprogram Calls \& Returns: \begin{tabular}{lll} call & ::= & ({\it id\/} arg')\\ & &\\ return & ::= & ({\it RETURN\/}) $\mid$ ({\it RETURN\/} arg)\\ \end{tabular} Stop \& Exit Statements: stop ::= ({\it STOP\/}) Statement Groups: stmtgp ::= ({\it PROGN\/} stmt stmt') $\mid$ ({\it BLOCK\/} (id') stmt') I/O Statements: \begin{tabular}{lll} read & ::= & ({\it SETQ\/} var ({\it READ\/}))\\ & &\\ write & ::= & ({\it WRITE\/} arg arg')\\ \end{tabular} Subprogram Definitions: defn ::= ({\it PROCEDURE id NIL EXPR\/} (id') stmt) \end{describe} \begin{describe}{Miscellaneous} \begin{tabular}{lll} funcall & ::= & ({\it id\/} arg')\\ & &\\ var & ::= & {\it id\/} $\mid$ ({\it id\/} exp exp')\\ & &\\ arg & ::= & {\it string\/} $\mid$ exp $\mid$ logexp\\ & &\\ arg' & ::= & arg$_1$ arg$_2$ \dots\ arg$_n$ $n \geq 0$ \\ & &\\ list & ::= & (exp exp')\\ & &\\ list' & ::= & list$_1$ list$_2$ \dots\ list$_n$ $n \geq 0$ \\ & &\\ id' & ::= & {\it id$_1$ id$_2$} \dots\ {\it id$_n$} $n \geq 0$ \\ \end{tabular} \end{describe} \section{List of Commands, Switches, \& Variables} \label{appb} \begin{describe}{COMMANDS} \index{GENTRAN command} {\bf GENTRAN} {\it stmt\/} [{\bf OUT}{\it f1,f2,\dots\ ,fn\/}]{\it ;} \index{GENTRANIN command} {\bf GENTRANIN} {\it f1,f2,\dots\ ,fm\/} [{\bf OUT}{\it f1,f2,\dots\ ,fn\/}]{\it ;} \index{GENTRANOUT command} {\bf GENTRANOUT} {\it f1,f2,\dots\ ,fn;} \index{GENTRANSHUT command} {\bf GENTRANSHUT} {\it f1,f2,\dots\ ,fn;} \index{GENTRANPUSH command} {\bf GENTRANPUSH} {\it f1,f2,\dots\ ,fn;} \index{GENTRANPOP command} {\bf GENTRANPOP} {\it f1,f2,\dots\ ,fn;} \end{describe} \begin{describe}{SPECIAL FUNCTIONS \& OPERATORS} \ttindex{EVAL} {\bf EVAL} {\it exp} \index{::=} {\it var} {\bf ::=} {\it exp;} \index{:=:} {\it var} {\bf :=:} {\it exp;} \index{::=:} {\it var} {\bf ::=:} {\it exp;} \ttindex{LSETQ} {\it var} {\bf LSETQ} {\it exp;} \ttindex{RSETQ} {\it var} {\bf RSETQ} {\it exp;} \ttindex{LRSETQ} {\it var} {\bf LRSETQ} {\it exp;} \index{DECLARE function} {\bf DECLARE} {\it v1,v2,\dots\ ,vn\/}{\bf :} {\it type;} \begin{tabular}{ll} {\bf DECLARE}\\ {\bf $<$$<$}\\ &{\it v11,v12,\dots\ ,v1n} {\bf :} {\it type1\/}{\bf ;}\\ &{\it v12,v22,\dots\ ,v2n} {\bf :} {\it type2\/}{\bf ;}\\ & \ \ \ :\\ & \ \ \ :\\ &{\it vm1,vm2,\dots\ ,vmn} {\bf :} {\it typen\/}{\bf ;}\\ {\bf $>$$>$}{\it ;} \end{tabular} \ttindex{LITERAL} {\bf LITERAL} {\it arg1,arg2,\dots\ ,argn;} \end{describe} \begin{describe}{MODE SWITCHES} {\bf PERIOD} \index{PERIOD switch} {\bf GENTRANSEG} \index{GENTRANSEG switch} {\bf GENDECS} \index{GENDECS switch} {\bf DOUBLE} \index{DOUBLE switch} {\bf MAKECALLS} \index{MAKECALLS switch} {\bf KEEPDECS} \index{KEEPDECS switch} {\bf GETDECS} \index{GETDECS switch} \end{describe} \begin{describe}{VARIABLES} {\bf GENTRANLANG!*} \ttindex{GENTRANLANG!*} {\bf MAXEXPPRINTLEN!*} \ttindex{MAXEXPPRINTLEN!*} {\bf TEMPVARNAME!*} \ttindex{TEMPVARNAME!*} {\bf TEMPVARNUM!*} \ttindex{TEMPVARNUM!*} {\bf TEMPVARTYPE!*} \ttindex{TEMPVARTYPE!*} {\bf GENSTMTNUM!*} \ttindex{GENSTMTNUM!*} {\bf GENSTMTINCR!*} \ttindex{GENSTMTINCR!*} {\bf TABLEN!*} \ttindex{TABLEN!*} {\bf FORTLINELEN!*} \ttindex{FORTLINELEN!*} {\bf RATLINELEN!*} \ttindex{RATLINELEN!*} {\bf CLINELEN!*} \ttindex{CLINELEN!*} {\bf PASCLINELEN!*} \ttindex{PASCLINELEN!*} {\bf MINFORTLINELEN!*} \ttindex{MINFORTLINELEN!*} {\bf MINRATLINELEN!*} \ttindex{MINRATLINELEN!*} {\bf MINCLINELEN!*} \ttindex{MINCLINELEN!*} {\bf MINPASCLINELEN!*} \ttindex{MINPASCLINELEN!*} {\bf DEFTYPE!*} \ttindex{DEFTYPE!*} \end{describe} \begin{describe}{TEMPORARY VARIABLE GENERATION, MARKING \& UNMARKING} {\bf TEMPVAR} {\it type;} \ttindex{TEMPVAR} {\bf MARKVAR} {\it var;} \ttindex{MARKVAR} {\bf UNMARKVAR} {\it var;} \ttindex{UNMARKVAR} \end{describe} \begin{describe}{EXPLICIT GENERATION OF TYPE DECLARATIONS} {\bf GENDECS} {\it subprogname;} \ttindex{GENDECS switch} \end{describe} \begin{describe}{SYMBOLIC MODE FUNCTIONS} {\bf SYM!-GENTRAN} {\it form;} \index{SYM"!-GENTRAN command} {\bf SYM!-GENTRANIN} {\it list-of-fnames;} \index{SYM"!-GENTRANIN command} {\bf SYM!-GENTRANOUT} {\it list-of-fnames;} \index{SYM"!-GENTRANOUT command} {\bf SYM!-GENTRANSHUT} {\it list-of-fnames;} \index{SYM"!-GENTRANSHUT command} {\bf SYM!-GENTRANPUSH} {\it list-of-fnames;} \index{SYM"!-GENTRANPUSH command} {\bf SYM!-GENTRANPOP} {\it list-of-fnames;} \index{SYM"!-GENTRANPOP command} \end{describe} \begin{describe}{SYMBOLIC MODE SPECIAL FORMS} \begin{tabular}{ll} \ttindex{DECLARE} {\bf (DECLARE} & {\bf (}{\it type1 v11 v12 \dots\ v1n\/}{\bf )}\\ & {\bf (}{\it type2 v21 v22 \dots\ v2n\/}{\bf )}\\ & \ \ \ :\\ & \ \ \ :\\ & {\bf (}{\it typen vn1 vn2 \dots\ vnn\/}{\bf ))}\\ \end{tabular} {\bf (LITERAL} {\it arg1 arg2 \dots\ argn\/}{\bf )} \ttindex{LITERAL} {\bf (EVAL} {\it exp\/}{\bf )} \ttindex{EVAL} {\bf (LSETQ} {\it var exp\/}{\bf )} \ttindex{LSETQ} {\bf (RSETQ} {\it var exp\/}{\bf )} \ttindex{RSETQ} {\bf (LRSETQ} {\it var exp\/}{\bf )} \ttindex{LRSETQ} \end{describe} \section{The Programs {\tt M1.F} and {\tt M2.F}.} \label{appc} This section contains the two files generated in chapter 6. Contents of file m1.f: \begin{framedverbatim} M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10 . +J30Y+J10Y M(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*DCOS(DBLE( . Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+J30Y M(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30) M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+ . J30Y M(2,3)=0.0D0 M(3,3)=9.0D0*P**2*M30+J30X MIV(1,1)=(-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-( . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y)+9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2* . M30*J30X)-(DSIN(DBLE(Q3))**2*J30Y*J30X)+DSIN(DBLE(Q3)) . **2*J30Z*J30X+81.0D0*P**4*M30**2+9.0D0*P**2*M30*J30Y+ . 9.0D0*P**2*M30*J30X+J30Y*J30X)/(729.0D0*DSIN(DBLE(Q3)) . **4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE(Q3 . ))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*DSIN( . DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+ . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0* . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3 . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P** . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30* . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+ . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y* . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-( . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))** . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2) . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6 . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0* . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE( . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30* . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-( . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3 . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P** . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y* . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2* . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-( . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2* . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN( . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2 . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3)) . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6* . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+ . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0* . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2* . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30* . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X) MIV(1,2)=(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Y-(9.0D0*DSIN(DBLE(Q3)) . **2*P**2*M30*J30Z)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30* . J30X+DSIN(DBLE(Q3))**2*J30Y*J30X-(DSIN(DBLE(Q3))**2* . J30Z*J30X)-(81.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4* . M30**2)-(9.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30* . J30X)-(81.0D0*P**4*M30**2)-(9.0D0*P**2*M30*J30Y)-( . 9.0D0*P**2*M30*J30X)-(J30Y*J30X))/(729.0D0*DSIN(DBLE( . Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE . (Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0* . DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+ . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0* . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3 . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P** . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30* . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+ . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y* . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-( . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))** . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2) . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6 . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0* . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE( . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30* . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-( . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3 . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P** . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y* . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2* . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-( . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2* . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN( . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2 . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3)) . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6* . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+ . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0* . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2* . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30* . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X) MIV(1,3)=(-(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P** . 4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2 . *M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2 . *M30*J30Z+81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**4* . M30**2+9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30* . J30Y)/(729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P** . 6*M30**3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P . **4*M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2 . ))**2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4* . Y*M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2* . J30Y)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)+9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(9.0D0*DSIN(DBLE . (Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(DBLE(Q3))**4*P** . 2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y . *J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3 . ))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3))**4*J30Y**2*J30X . )+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE( . Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DSIN( . DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y)-( . 729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(81.0D0*DSIN( . DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN(DBLE(Q3))** . 2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))**2*P**4*M30 . **2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J10Y)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J30X)-(9.0D0*DSIN . (DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(Q3))**2*P**4* . M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30Y . *J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30X*J30)+ . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2-(9.0D0*DSIN( . DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*DSIN(DBLE(Q3)) . **2*P**2*M30*J30Z*J10Y+9.0D0*DSIN(DBLE(Q3))**2*P**2* . M30*J30Z*J30X-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y* . J30X)-(DSIN(DBLE(Q3))**2*P**2*J30Y*M10*J30X)+DSIN(DBLE . (Q3))**2*P**2*J30Z*M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y* . J30X*J30)+DSIN(DBLE(Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3 . ))**2*J30Y*J10Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X . -(729.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30 . **3)-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* . M30*J30Y*J30X+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10* . J30X+J30Y*J10Y*J30X) MIV(2,2)=(-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2* . P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-( . 9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+9.0D0*DSIN( . DBLE(Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*M30*J30X)-(DSIN(DBLE(Q3))**2*Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Z*J30X+162.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2 . ))*P**4*M30**2+18.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P . **2*M30*J30X+162.0D0*P**4*M30**2+9.0D0*P**4*M30*M10+ . 9.0D0*P**2*M30*J30Y+9.0D0*P**2*M30*J10Y+18.0D0*P**2* . M30*J30X+P**2*M10*J30X+J30Y*J30X+J10Y*J30X)/(729.0D0* . DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0 . *DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y- . (81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30** . 2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-( . 81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2* . Y*M30*J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y . **2)+9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0 . *DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3)) . **4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30 . )-(DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4* . J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2 . ))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE . (Q2))**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2* . P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10 . )-(81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0* . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE( . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30* . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-( . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3 . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P** . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y* . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2* . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-( . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2* . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN( . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2 . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3)) . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6* . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+ . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0* . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2* . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30* . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X) MIV(2,3)=(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**4* . M30**2+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30 . *J30Y-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30 . *J30Z)-(81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*DCOS(DBLE . (Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3 . ))*DSIN(DBLE(Q2))*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))* . DSIN(DBLE(Q2))*P**2*M30*J30Y))/(729.0D0*DSIN(DBLE(Q3)) . **4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE(Q3) . )**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*DSIN( . DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+ . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0* . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3 . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P** . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30* . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+ . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y* . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-( . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))** . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2) . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6 . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0* . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE( . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30* . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-( . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3 . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P** . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y* . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2* . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-( . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2* . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN( . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2 . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3)) . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6* . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+ . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0* . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2* . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30* . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X) MIV(3,3)=(9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30-(9.0D0 . *DSIN(DBLE(Q3))**4*P**2*M30*J30Y)+DSIN(DBLE(Q3))**4*Y* . J30Y*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2)+DSIN(DBLE(Q3))**4*J30Y*J30Z-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**2*P . **4*M30*M10)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+ . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J10Y)-(DSIN(DBLE(Q3))**2*P**2*J30Y* . M10)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10-(DSIN(DBLE(Q3))** . 2*Y*J30Y*J30)+DSIN(DBLE(Q3))**2*J30Y**2-(DSIN(DBLE(Q3) . )**2*J30Y*J10Y)+DSIN(DBLE(Q3))**2*J30Z*J10Y-(81.0D0* . DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*M30**2)+ . 81.0D0*P**4*M30**2+9.0D0*P**4*M30*M10+9.0D0*P**2*M30* . J30Y+9.0D0*P**2*M30*J10Y+P**2*J30Y*M10+J30Y*J10Y)/( . 729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30** . 3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30 . **2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P . **4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30** . 2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+ . 9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE . (Q3))**4*P**2*Y*M30*J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4* . P**2*M30*J30Y**2)+9.0D0*DSIN(DBLE(Q3))**4*P**2*M30* . J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30X) . +DSIN(DBLE(Q3))**4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3))**4* . Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN . (DBLE(Q3))**4*J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))** . 2*DSIN(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3) . )**2*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y)-(729.0D0*DSIN . (DBLE(Q3))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P . **6*M30**2*M10)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30** . 2*J30)+81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-( . 81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J10Y)-(81.0D0* . DSIN(DBLE(Q3))**2*P**4*M30**2*J30X)-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P** . 4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10* . J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-( . 9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30X*J30)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3 . ))**2*P**2*M30*J30Y*J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2 . *M30*J30Z*J10Y+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z* . J30X-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-( . DSIN(DBLE(Q3))**2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))** . 2*P**2*J30Z*M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X* . J30)+DSIN(DBLE(Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2 . *J30Y*J10Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-( . 729.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30** . 3)-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0 . *P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2 . *M30*J30Y*J30X+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10* . J30X+J30Y*J10Y*J30X) DO 25005 J=1,3 DO 25006 K=J+1,3 M(K,J)=M(J,K) MIV(K,J)=MIV(J,K) 25006 CONTINUE 25005 CONTINUE \end{framedverbatim} \newpage Contents of file m2.f: \begin{framedverbatim} M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10 . +J30Y+J10Y(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-( . DSIN(DBLE(Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0* . DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+ . J30Y(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2* . M30) M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE( . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+ . J30Y M(2,3)=0.0D0 M(3,3)=9.0D0*P**2*M30+J30X T1=-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(9.0D0*DSIN( . DBLE(Q3))**2*P**2*M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**2*P . **2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30X)-( . DSIN(DBLE(Q3))**2*J30Y*J30X)+DSIN(DBLE(Q3))**2*J30Z* . J30X+81.0D0*P**4*M30**2+9.0D0*P**2*M30*J30Y+9.0D0*P**2 . *M30*J30X+J30Y*J30X T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30 . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))** . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y* . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y) . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30) T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-( . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30** . 3) T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4* . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2* . J30X) T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0 . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y* . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2 . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3)) . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z* . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y* . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS( . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3) T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* ; M30*J30Y*J30X MIV(1,1)=T1/(T0+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10* . J30X+J30Y*J10Y*J30X) T0=81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2+9.0D0*DSIN(DBLE . (Q3))**2*P**2*M30*J30Y-(9.0D0*DSIN(DBLE(Q3))**2*P**2* . M30*J30Z)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30X+DSIN( . DBLE(Q3))**2*J30Y*J30X-(DSIN(DBLE(Q3))**2*J30Z*J30X)-( . 81.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-( . 9.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*J30X)-( . 81.0D0*P**4*M30**2)-(9.0D0*P**2*M30*J30Y) T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30 . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))** . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y* . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y) . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30) T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-( . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30** . 3) T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4* . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2* . J30X) T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0 . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y* . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2 . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3)) . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z* . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y* . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS( . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3) T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* . M30*J30Y*J30X MIV(1,2)=(T0-(9.0D0*P**2*M30*J30X)-(J30Y*J30X))/(T1+ . 9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y* . J30X) T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30 . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))** . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y* . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y) . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30) T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-( . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30** . 3) T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4* . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2* . J30X) T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0 . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y* . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2 . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3)) . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z* . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y* . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS( . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3) T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* . M30*J30Y*J30X MIV(1,3)=(-(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P** . 4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2 . *M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2 . *M30*J30Z+81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**4* . M30**2+9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30* . J30Y)/(T0+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+ . J30Y*J10Y*J30X) T0=-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(9.0D0* . DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+9.0D0*DSIN(DBLE(Q3)) . **2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30* . J30X)-(DSIN(DBLE(Q3))**2*Y*J30X*J30)+DSIN(DBLE(Q3))**2 . *J30Z*J30X+162.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4* . M30**2+18.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30* . J30X+162.0D0*P**4*M30**2 T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30 . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))** . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y* . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y) . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30) T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-( . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30** . 3) T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4* . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2* . J30X) T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0 . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y* . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2 . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3)) . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z* . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y* . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS( . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3) T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* . M30*J30Y*J30X MIV(2,2)=(T0+9.0D0*P**4*M30*M10+9.0D0*P**2*M30*J30Y+ . 9.0D0*P**2*M30*J10Y+18.0D0*P**2*M30*J30X+P**2*M10*J30X . +J30Y*J30X+J10Y*J30X)/(T1+9.0D0*P**2*M30*J10Y*J30X+P** . 2*J30Y*M10*J30X+J30Y*J10Y*J30X) T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30 . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))** . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y* . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y) . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30) T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-( . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30** . 3) T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4* . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2* . J30X) T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0 . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y* . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2 . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3)) . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z* . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y* . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS( . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3) T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* . M30*J30Y*J30X MIV(2,3)=(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**4* . M30**2+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30 . *J30Y-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30 . *J30Z)-(81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*DCOS(DBLE . (Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3 . ))*DSIN(DBLE(Q2))*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))* . DSIN(DBLE(Q2))*P**2*M30*J30Y))/(T0+9.0D0*P**2*M30*J10Y . *J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X) T0=9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30-(9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y)+DSIN(DBLE(Q3))**4*Y*J30Y* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30)-(DSIN(DBLE(Q3))**4* . J30Y**2)+DSIN(DBLE(Q3))**4*J30Y*J30Z-(81.0D0*DSIN(DBLE . (Q3))**2*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**2*P**4* . M30*M10)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+ . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y)-(DSIN( . DBLE(Q3))**2*P**2*J30Y*M10)+DSIN(DBLE(Q3))**2*P**2* . J30Z*M10-(DSIN(DBLE(Q3))**2*Y*J30Y*J30)+DSIN(DBLE(Q3)) . **2*J30Y**2-(DSIN(DBLE(Q3))**2*J30Y*J10Y)+DSIN(DBLE(Q3 . ))**2*J30Z*J10Y-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2 . ))**2*P**4*M30**2)+81.0D0*P**4*M30**2+9.0D0*P**4*M30* . M10+9.0D0*P**2*M30*J30Y T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30 . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))** . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y* . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y) . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0* . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30) T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-( . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN( . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3)) . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X* . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3) . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-( . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30** . 3) T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4* . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-( . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3)) . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4* . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2* . J30X) T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0 . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE( . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y* . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2 . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0* . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0 . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3)) . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z* . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y* . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS( . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3) T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4* . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2* . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+ . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0* . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2* . M30*J30Y*J30X MIV(3,3)=(T0+9.0D0*P**2*M30*J10Y+P**2*J30Y*M10+J30Y* . J10Y)/(T1+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+ . J30Y*J10Y*J30X) DO 25007 J=1,3 DO 25008 K=J+1,3 M(K,J)=M(J,K) MIV(K,J)=MIV(J,K) 25008 CONTINUE 25007 CONTINUE \end{framedverbatim} \bibliography{gentran} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/groebner.bib version [36d46646a2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Bibliography for groebner.tex @ARTICLE{Boege:86, AUTHOR = "W. Boege and R. Gebauer and H. Kredel", TITLE = "Some Examples for Solving Systems of Algebraic Equations by Calculating {Groebner} Bases", JOURNAL = "J. Symbolic Computation", YEAR = 1986, VOLUME = 2, NUMBER = 1, PAGES = "83-98", MONTH = "March"} @INCOLLECTION{Buchberger:85, AUTHOR = "B. Buchberger", TITLE = "Groebner Bases: An Algorithmic Method in Polynomial Ideal Theory", EDITOR = "N. K. Bose", BOOKTITLE = "Progress, directions and open problems in multidimensional systems theory", PAGES = "184-232", PUBLISHER = "Dordrecht: Reidel", YEAR = 1985} @INCOLLECTION{Buchberger:88, AUTHOR = "B. Buchberger", TITLE = "Applications of Groebner Bases in Non-Linear Computational Geometry", EDITOR = "R. Janssen", BOOKTITLE = "Trends in Computer Algebra", PAGES = "52-80", PUBLISHER = "Berlin, Heidelberg", YEAR = 1988} @BOOK{Davenport:88a, AUTHOR = "J. H. Davenport and Y. Siret and E. Tournier", TITLE = "Computer Algebra, Systems and Algorithms for Algebraic Computation", PUBLISHER = "Academic Press", PRINTING = "2nd", YEAR = 1989} @INCOLLECTION{Ebert:81, AUTHOR = "K. H. Ebert and P. Deuflhard", EDITOR = "W. Jaeger", TITLE = "Modelling of Chemical Reaction Systems", PUBLISHER = "Springer Verlag", BOOKTITLE = "Springer Ser. Chem. Phys", VOLUME = 18, YEAR = 1981} @TECHREPORT{Faugere:89, AUTHOR = "J. C. Faug{\`e}re and P. Gianni and D. Lazard and T. Mora", TITLE = "Efficient Computation of Zero-Dimensional Groebner Bases by Change of Ordering", YEAR = 1989} @ARTICLE{Gebauer:88, AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller", TITLE = "On an Installation of {Buchberger's} Algorithm", JOURNAL = "J. Symbolic Computation", YEAR = 1988, VOLUME = 6, NUMBER = "2 and 3", PAGES = "275-286"} @ARTICLE{Kredel:88, AUTHOR = "Heinz Kredel", TITLE = "Admissible termorderings used in Computer Algebra Systems", JOURNAL = "{SIGSAM} Bulletin", YEAR = 1988, VOLUME = 22, NUMBER = 1, PAGES = "28-31", MONTH = "January"} @TECHREPORT{Melenk:88, AUTHOR = "H. Melenk and H. M. M{\"o}ller and W. Neun", TITLE = "On Gr{\"o}bner Bases Computation on a Supercomputer Using {REDUCE}", INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin", YEAR = 1988, TYPE = "Preprint", NUMBER = "SC 88-2", MONTH = "January"} |
Added r34.1/doc/groebner.tex version [8b158513e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{GROEBNER: A Package for Calculating Groebner Bases} \date{} \author{ H. Melenk \& W. Neun \\[0.05in] Konrad--Zuse--Zentrum \\ f\"ur Informationstechnik Berlin \\ Heilbronner Strasse 10 \\ D--1000 Berlin 31 \\ Federal Republic of Germany \\[0.05in] Email: melenk@sc.zib--berlin.de \\[0.05in] and \\[0.05in] H.M. M\"oller \\[0.05in] Fernuniversit\"at Hagen \\ FB Math und Informatik\\ Postfach 940 \\ D--5800 Hagen \\ Federal Republic of Germany\\[0.05in] Email: ma105@dhafeu11.bitnet} \begin{document} \maketitle \index{Groebner Bases} Groebner bases are a valuable tool for solving problems in connection with multivariate polynomials, such as solving systems of algebraic equations and analyzing polynomial ideals. For a definition of Groebner bases, a survey of possible applications and further references, see~\cite{Buchberger:85}. Examples are given in \cite{Boege:86}, in \cite{Buchberger:88} and also in the test file for this package. \index{GROEBNER package} \index{Buchberger's Algorithm} The GROEBNER package calculates Groebner bases using the Buchberger algorithm. It can be used over a variety of different coefficient domains, and for different variable and term orderings. The current version of the package uses parts of the previous version, written by R. Gebauer, A.C. Hearn, H. Kredel and M. M\"oller. The algorithms implemented in the current version are documented in \cite{Faugere:89} and \cite{Gebauer:88}. \subsubsection*{Incompatibilities with the Groebner package in REDUCE 3.3:} \begin{itemize} \item In contrast to the previous version, the polynomials in the Groebner bases by default now have non fractional coefficients; the fractional forms can be generated by dividing each polynomial by its leading coefficient or by setting ON RATIONAL. \ttindex{GREDUCE} \index{PREDUCE} \item The routines GREDUCE and PREDUCE now avoid fractional coefficients by reducing a constant multiple of the input polynomial instead of the polynomial itself (``pseudo reduction'' ) as long as RATIONAL is off. \item The term order modes were cleaned up so that their names now correspond to the literature: \begin{center} \begin{tabular}{c} INVLEX $\rightarrow$ LEX, INVTOTALDEGREE $\rightarrow$ GRADLEX, \\ TOTALDEGREE $\rightarrow$ REVGRADLEX \end{tabular} \end{center} For compatibility reasons, the old names (except the old LEX, which did not represent an order usable in the Groebner context) are still supported. \end{itemize} \section{Background} % Section 1.1 \subsection{Variables, Domains and Polynomials} The various functions of the Groebner package manipulate equations and/or polynomials; equations are internally transformed into polynomials by forming the difference of left-hand side and right-hand side. All manipulations take place in a ring of polynomials in some variables $x1, \ldots , xn$ over a coefficient domain $D$: \[ D [x1,\ldots , xn], \] where $D$ is a field or at least a ring without zero divisors. The set of variables $x1,\ldots ,xn$ can be given explicitly by the user (optional parameter) or it is extracted automatically from the input expressions. All REDUCE kernels can play the role of ``variables'' in this context; examples are %{\small \begin{verbatim} X Y Z22 SIN(ALPHA) COS(ALPHA) C(1,2,3) C(1,3,2) FARINA4711 \end{verbatim} %} The domain $D$ is the current REDUCE domain with those kernels adjoined, which are not members of the list of variables. So the elements of $D$ may be complicated polynomials themselves over kernels not in the list of variables; if, however, the variables are extracted automatically from the input expressions, $D$ is identical with the current REDUCE domain. It is useful to regard kernels not being members of the list of variables as ``parameters'', e.g. \[ \begin{array}{c} a * x + (a - b) * y**2 \;\mbox{ with ``variables''}\{x,y\} \\ \mbox{and ``parameters'' $\;a\;$ and $\;b\;$}\;. \end{array} \] The current version of the Buchberger algorithm has two internal modes, a field mode and a ring mode. In the starting phase the algorithm analyzes the domain type; if it recognizes $D$ as being a ring it uses the ring mode, otherwise the field mode is needed. Normally field calculations occur only if all coefficients are numbers and if the current REDUCE domain is a field (e.g. rational numbers, modular numbers). In general, the ring mode is the faster one (compared in cases where both are applicable). When no specific REDUCE domain is selected, the ring mode is used, even if the input formulas contain fractional coefficients: they are multiplied by their common denominators so that they become integer polynomials. %Section 1.2 \subsection{Term Ordering} \par In the theory of Groebner bases, the terms of polynomials are considered as ordered. The following order modes are available in the current package: \index{LEX ! term order} \index{GRADLEX ! term order} \index{REVGRADLEX ! term order} \begin{center} LEX, GRADLEX, REVGRADLEX \end{center} All orderings are based on an ordering among the variables. For each pair of variables $(a,b)$ an order relation must be defined, e.g. ``$ a\gg b $''. The greater sign $\gg$ does not represent a numerical relation among the variables; it can be interpreted only in terms of formula representation: ``$a$'' will be placed in front of ``$b$'' or ``$a$'' is more complicated than ``$b$''. The sequence of variables constitutes this order base. So the notion of \[ \{x1,x2,x3\} \] as a list of variables at the same time means \[ x1 \gg x2 \gg x3 \] with respect to the term order. If terms (products of powers of variables) are compared with LEX, that term is chosen which has a greater variable or a higher degree if the greatest variable is the first in both. With GRADLEX the sum of all exponents (the total degree) is compared first, and if that does not lead to a decision, the LEX method is taken for the final decision. The REVGRADLEX method also compares the total degree first, but afterward it uses the LEX method in the reverse direction; this is the method originally used by Buchberger. \example with $\{x,y,z\}$: \index{GROEBNER package ! example} \[ \begin{array}{rlll} \multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf LEX:}}\\ x * y **3 & \gg & y ** 48 & \mbox{(heavier variable)} \\ x**4 * y**2 & \gg & x**3 * y**10 & \mbox{(higher degree in 1st variable)} \vspace*{2mm} \\ \multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf GRADLEX:}} \\ y**3 * z**4 & \gg & x**3 * y**3 & \mbox{(higher total degree)} \\ x**3 * y**3 & \gg & y**3 * z**3 & \mbox{(equal total degree)} \vspace*{2mm}\\ \multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf REVGRADLEX:}} \\ y**3 * z**4 & \gg & x**3 * y**3 & \mbox{(higher total degree)} \\ x**3 * y**3 & \ll & y**3 * z**3 & \mbox{(equal total degree,} \\ & & & \mbox{so reverse order of LEX)} \end{array} \] The formal description of the term order modes is similar to \cite{Kredel:88}; this description regards only the exponents of a term, which are written as vectors of integers with $0$ for exponents of a variable which does not occur: \[ \begin{array}{l} (e) = (e1,\ldots , en) \;\mbox{ representing }\; x1**e1 \ x2**e2 \cdots xn**en. \\ \deg(e) \; \mbox{ is the sum over all elements of } \;(e) \\ (e) \gg (l) \Longleftrightarrow (e)-(l)\gg (0) = (0,\ldots ,0) \end{array} \] \[ \begin{array}{rll} \multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf LEX:}} \\ (e) > lex > (0) & \Longrightarrow & e_k > 0 \mbox{ and } e_j =0 \mbox{ for }\; j=1,\ldots , k-1\vspace*{2mm} \\ \multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf GRADLEX:}} \\ (e) >gl> (0) & \Longrightarrow & \deg(e)>0 \mbox { or } (e) >lex> (0)\vspace*{2mm} \\ \multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf REVGRADLEX:}}\\ (e) >rgl> (0) & \Longrightarrow & \deg(e)>0 \mbox{ or }(e) <lex< (0) \end{array} \] Note that the LEX ordering is identical to the standard REDUCE kernel ordering, when KORDER is set explicitly to the sequence of variables. \index{default ! term order} LEX is the default term order mode in the Groebner package. It is beyond the scope of this manual to discuss the functionality of the term order modes. See \cite{Buchberger:88}. Most operators in this package accept a list of variables as an optional last parameter. If this parameter is given explicitly, it defines the names of the variables and their sequence at the same time. If the parameter is omitted, the variables are extracted from the expressions automatically and the REDUCE system order defines their sequence; this can be influenced by setting an explicit order via the KORDER statement. The result of a Groebner calculation is algebraically correct only with respect to the term order mode and the variable sequence which was in effect during the calculation. This is important if several calls to the Groebner package are done with the result of the first being the input of the second call. % Section 1.3 \subsection{The Buchberger Algorithm} \index{Buchberger's Algorithm} The Buchberger algorithm of the package is based on {\sc Gebauer/M\"oller} \cite{Gebauer:88}. Most of the improvements are documented in \cite{Melenk:88}. % Chapter 2 \section{Loading of the Package} The following command loads the Groebner basis package into REDUCE (this syntax may vary according to implementation): \begin{center} load groebner; \end{center} The package contains various operators, and switches for control over the reduction process. These are discussed in the following. % Chapter 3 \section{The Basic Operators} % Section 3.1 \subsection{Term Ordering Mode} \begin{description} \ttindex{TORDER} \item [{\it TORDER}] $m$; where $m$ is the name of a term ordering mode LEX, GRADLEX, REV\-GRAD\-LEX (or another implemented mode). TORDER sets the term ordering mode. The default mode is LEX. The previous ordering mode is returned. \ttindex{GVARS} \item[{\it GVARS}] ({\it\{exp$1$, exp$2$, $ \ldots$, exp$n$\}}); where $\{exp1, exp2, \ldots , expn\}$ is a list of expressions or equations. GVARS extracts from the expressions $\{exp1, exp2, \ldots , expn\}$ the kernels, which can play the role of variables for a Groebner calculation. \end{description} % Section 3.2 \subsection{GROEBNER: Calculation of a Groebner Basis} \begin{description} \ttindex{GROEBNER} \item[{\it GROEBNER}] $(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots , varn\}]); $ where $\{exp1, exp2, \ldots , expm\}$is a list of expressions or equations, and \linebreak[4] $\{var1, var2, \ldots , varn\}$ is an optional list of variables. GROEBNER calculates the Groebner basis of the given set of expressions with respect to the given set of variables in the order given. If the variable list is omitted, the variables in the expression list are used, ordered according to the system variable order. The Groebner basis is a list of polynomials. The Groebner basis $\{1\}$ means that the ideal generated by the input polynomials is the whole polynomial ring, or equivalently, that the input polynomials have no zeros in common. As a side effect, the sequence of variables is stored as a REDUCE list in the shared variable \ttindex{gvarslast} \begin{center} gvarslast . \end{center} This is important if the variables are extracted automatically or if the variables are reordered because of optimization and if the sequences are needed afterwards for subsequent calculations (e.g. for GREDUCE). \end{description} \example \index{GROEBNER package ! example} ${\it groebner} (\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3, $ \\ \hspace*{+1cm}$2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3,$ \\ \hspace*{+1cm}$x**3*y + x**2*y + 3*x**3 + 2*x**2 \}); $ %{\small \begin{verbatim} 2 {8*X - 2*Y + 5*Y + 3, 3 2 2*Y - 3*Y - 16*Y + 21} \end{verbatim} %} {\it gvarslast}; \\ %{\small \begin{verbatim} {X,Y} \end{verbatim} %} This example used the default system variable ordering, which was $\{x,y\}$. With the other variable ordering, a different basis results: {\it groebner} $(\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x = 3,$ \\ \hspace*{+1cm} $2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x = -3,$ \\ \hspace*{+1cm} $x**3*y + x**2*y + 3*x**3 + 2*x**2 \}, \{y,x\})$; %{\small \begin{verbatim} 2 {2*Y + 2*X - 3*X - 6, 3 2 2*X - 5*X - 5*X} \end{verbatim} %} Another basis yet again results with a different term ordering: \begin{center} {\it torder revgradlex;} \end{center} LEX {\it groebner} $(\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x = 3,$ \\ \hspace*{+1cm} $2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x = -3,$ \\ \hspace*{+1cm} $x**3*y + x**2*y + 3*x**3 + 2*x**2 \}, \{y,x\}); $ %{\small \begin{verbatim} 2 {2*X - 3*X + 2*Y - 6, X*Y + X - Y + 3, 2 2*Y - 8*X - 5*Y - 3} \end{verbatim} %} The operation of GROEBNER can be controlled by the following switches: \begin{description} \ttindex{GROEBOPT} \item[GROEBOPT] -- If set ON, the sequence of variables is optimized with respect to execution speed; the algorithm involved is described in~\cite{Boege:86}; note that the final list of variables is available in \ttindex{GVARSLAST} GVARSLAST. An explicitly declared dependency supersedes the variable optimization. For example \begin{center} {\it depend} $a$, $x$, $y$; \end{center} guarantees that $a$ will be placed in front of $x$ and $y$. So GROEBOPT can be used even in cases where elimination of variables is desired. By default GROEBOPT is off, conserving the original variable sequence. \ttindex{GROEBPREREDUCE} \item[GROEBPREREDUCE] -- If set ON, GROEBNER tries to simplify the input expressions: if the head term of an input expression is a multiple of the head term of another expression, it can be reduced; these reductions are done cyclicly as long as possible in order to shorten the main part of the algorithm. By default GROEBPREREDUCE is off; \ttindex{GROEBFULLREDUCTION} \item[GROEBFULLREDUCTION] -- If set off, the reduction steps during the \linebreak[4] GROEBNER operation are limited to the pure head term reduction; subsequent terms are reduced otherwise. By default GROEBFULLREDUCTION is on. \ttindex{GLTBASIS} \item[GLTBASIS] -- If set on, the leading terms of the result basis are extracted. They are collected in a basis of monomials, which is available as value of the global variable with the name GLTB. \end{description} The following switches control the print output of GROEBNER; by default all these switches are set OFF and nothing is printed. \begin{description} \ttindex{GROEBSTAT} \item[GROEBSTAT] -- A summary of the computation is printed including the computing time, the number of intermediate $H$--polynomials and the counters for the hits of the criteria. \ttindex{TRGROEB} \item[TRGROEB] -- Includes GROEBSTAT and the printing of the intermediate $H$-polynomials. \ttindex{TRGROEBS} \item[TRGROEBS] -- Includes TRGROEB and the printing of intermediate $S$--poly\-nomials. \ttindex{TRGROEB1} \item[TRGROEB1] -- The internal pairlist is printed when modified. \end{description} %Section3.3new \subsection{GZERODIM?: Test of $\dim = 0$} \begin{description} \ttindex{GZERODIM?} \item[{\it GZERODIM}!?] $\left(bas[,\{var1,\ldots , varn\}]\right)$ \\ where {\it bas} is a Groebner basis in the current ordering with the specified variables. The result is {\it NIL}, if {\it bas} is the basis of an ideal of polynomials with more than finitely many common zeros. If the ideal is zero dimensional, i. e. the polynomials of the ideal have only finitely many zeros in common, the result is an integer $k$ which is the number of these common zeros (counted with multiplicities). \end{description} %Section 3.4new \subsection{GLEXCONVERT: Conversion of an Arbitrary Groebner Basis into a Lexical One} \begin{description} \ttindex{GLEXCONVERT} \item[{\it GLEXCONVERT}] $ \left(\{exp,\ldots , expm\} \left[,\{var1 \ldots , varn\}\right]\left[,MAXDEG=mx\right]\right.$ \\ $\left.\left[,NEWVARS=\{nv1, \ldots , nvk\}\right]\right) $ \\ when $\{exp1, \ldots , expm\}$ is Groebner basis with variables $\{var1, \ldots , varn\}$ in the current term order mode, $mx$ is an integer, $\{nv1, \ldots , nvk\}$ is a subset of the basis variables. \end{description} GLEXCONVERT converts a basis of a zero-dimensional ideal (finite number of isolated solutions) from arbitrary ordering into a basis under {\it lex} ordering. During the call of GLEXCONVERT the original ordering of the input basis must be still active! NEWVARS defines the new variable sequence. If omitted, the original variable sequence is used. If only a subset of variables is specified here, the partial ideal basis is evaluated. For the calculation of a univariate polynomial, NEW\-VARS should be a list with one element. MAXDEG is an upper limit for the degrees. The algorithm stops with an error message, if this limit is reached. A warning occurs, if the ideal is not zero dimensional. GLEXCONVERT is an implementation of the FLGM algorithm by \linebreak[4] {\sc Faug{\`e}re}, {\sc Gianni}, {\sc Lazard} and {\sc Mora} \cite{Faugere:89}. In general, the calculation of a Groebner basis with a graded ordering and subsequent conversion to {\it lex} is faster than a direct {\it lex} calculation. Additionally, GLEXCONVERT can be used to transform a {\it lex} basis into one with different variable sequence, and it supports the calculation of a univariate polynomial. If the latter exists, the algorithm is even applicable in the non zero-dimensional case, if such polynomial exists. \example \index{GROEBNER package ! example} {\it torder gradlex;} $ g := groebner (\{ f1 := 45*p + 35*s -165*b -36,$ \\ \hspace*{+1cm} $35*p + 40*z + 25*t - 27*s, 15*w + 25*p*s +30*z -18*t $ \\ \hspace*{+1cm} $-165*b**2, -9*w + 15*p*t + 20*z*s, $ \\ \hspace*{+1cm} $ w*p + 2*z*t - 11*b**3, 99*w - 11*s*b +3*b**2, $ \\ \hspace*{+1cm} $ b**2 + 33/50*b + 2673/10000\}, \{w,p,z,t,s,b\});$ \begin{verbatim} G := {60000*W + 9500*B + 3969, 1800*P - 3100*B - 1377, 18000*Z + 24500*B + 10287, 750*T - 1850*B + 81, 200*S - 500*B - 9, 2 10000*B + 6600*B + 2673} \end{verbatim} {\it glexconvert}$\left(g,\{w,p,z,t,s,b\},maxdeg=5,newvars=\{w\}\right)$ \begin{verbatim} 2 100000000*W + 2780000*W + 416421 \end{verbatim} {\it glexconvert}$\left(g,\{w,p,z,t,s,b\},maxdeg=5, newvars=\{p\}\right),$ \begin{verbatim} 2 6000*P - 2360*P + 3051 \end{verbatim} % Section 3.4 \subsection{GROEBNERF: Factorizing Groebner Bases} % Subsection 3.4.1 \subsubsection{Background} If Groebner bases are computed in order to solve systems of equations or to find the common roots of systems of polynomials, the factorizing version of the Buchberger algorithm can be used. The theoretical background is simple: if a polynomial $p$ can be represented as a product of two (or more) polynomials, e.g. $h= f*g$, then $h$ vanishes if and only if one of the factors vanishes. So if during the calculation of a Groebner basis $h$ of the above form is detected, the whole problem can be split into two (or more) disjoint branches. Each of the branches is simpler than the complete problem; this saves computing time and space. The result of this type of computation is a list of (partial) Groebner bases; the solution set of the original problem is the union of the solutions of the partial problems, ignoring the multiplicity of an individual solution. If a branch results in a basis $\{1\}$, then there is no common zero, i.e. no additional solution for the original problem, contributed by this branch. % Subsection 3.4.2 \subsubsection{GROEBNERF Call} \ttindex{GROEBNERF} The syntax of GROEBNERF is the same as for GROEBNER. \[ \mbox{\it GROEBNERF}(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots , varn\}]); \] where $\{exp1, exp2, \ldots , expm\} $ is a list of expressions or equations, \linebreak[4] and $\{var1, var2,\ldots , varn\}$ is an optional list of variables. GROEBNERF tries to separate polynomials into individual factors and to branch the computation in a recursive manner (factorization tree). The result is a list of partial Groebner bases. If no factorization can be found or if all branches but one lead to the trivial basis $\{1\}$, the result has only one basis; nevertheless it is a list of lists of polynomials. If no solution is found, the result will be $\{\{1\}\}$. Multiplicities (one factor with a higher power, the same partial basis twice) are deleted as early as possible in order to speed up the calculation. The factorizing is controlled by some switches. As a side effect, the sequence of variables is stored as REDUCE list in the shared variable \begin{center} gvarslast . \end{center} If GLTBASIS is on, a corresponding list of leading term bases is also produced and is available in the variable GLTB. \example \index{GROEBNER package ! example} {\it groebnerf} $(\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x = 3,$ \\ \hspace*{+1cm} $ 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x = -3, $\\ \hspace*{+1cm} $ x**3*y + x**2*y + 3*x**3 + 2*x**2 \}, \{y,x\});$ %{\small \begin{verbatim} {{Y - 3,X}, 2 {2*Y + 2*X - 1,2*X - 5*X - 5}} \end{verbatim} %} It is obvious here that the solutions of the equations can be read off immediately. All switches from GROEBNER are valid for GROEBNERF as well: \ttindex{GROEBOPT} \ttindex{GROEBPREREDUCE} \ttindex{GLTBASIS} \ttindex{BROEBFULLREDUCTION} \ttindex{GROEBSTAT} \ttindex{TRGROEB} \ttindex{TRGROEBS} \ttindex{TRGROEB1} \begin{center} \begin{tabular}{l} GROEBOPT \\ GROEBPREREDUCE \\ GLTBASIS \\ GROEBFULLREDUCTION \\ GROEBSTAT \\ TRGROEB \\ TRGROEBS \\ TRGROEB1 \end{tabular} \end{center} \subsubsection*{Additional switches for GROEBNERF:} \begin{description} \ttindex{GROEBRES} \item[GROEBRES] -- If ON, a resultant is calculated under certain circumstances (one bivariate $H$--polynomial is followed by another one). This shortens the calculation sometimes. By default GROEBRES is off. \ttindex{TRGROEBR} \item[TRGROEBR] -- All intermediate partial basis are printed when detected. By default TRGROEBR is off. \end{description} {\bf GROEBMONFAC GROEBRESMAX GROEBRESTRICTION} \\ \hspace*{.5cm} These variables are described in the following paragraphs. % Subsection 3.4.3 \subsubsection{Suppression of Monomial Factors} The factorization in GROEBNERF is controlled by the following \ttindex{GROEBMONFAC} switches and variables. The variable GROEBMONFAC is connected to the handling of ``monomial factors''. A monomial factor is a product of variable powers as a factor, e.g. $ x**2*y$ in $x**3*y - 2*x**2*y**2$. A monomial factor represents a solution of the type ``$ x = 0$ or $y = 0$'' with a certain multiplicity. With GROEB\-NERF \ttindex{GROEBNERF} the multiplicity of monomial factors is lowered to the value of the shared variable \ttindex{GROEBMONFAC} \begin{center} GROEBMONFAC \end{center} which by default is 1 (= monomial factors remain present, but their multiplicity is brought down). With \begin{center} GROEBMONFAC := 0 \end{center} the monomial factors are suppressed completely. \example\index{GROEBNER package ! example} Equations extracted from a differential equation system for a chemical reaction system for pyridine, in: {\sc Ebert/Deuflhard/Jaeger} (1981) \cite{Ebert:81}). \[ \begin{array}{lll} f1 & := & -1*A + p9*B; \\ f2 & := & p1*A - p2*B - p3*C*B + p7*D - p9*B + p10*D*F; \\ f3 & := & p2*B - p3*B*C - 2*p4*C*C - p6*C + p8*E \\ & & \;\;+ p10*D*F + 2*p11*E*F;\\ f4 & := & p3*B*C - p5*D - p7*D - p10*D*F; \\ f5 & := & p4*C*C + p5*D -p8*E - p11*E*F; \\ f6 & := & p3*B*C + p4*C*C + p6*C - p10*D*F - p11*E*F; \\ f7 & := & p6*C + p7*D + p8*E; \\ \multicolumn{3}{l}{\mbox{\it polys}\; :=\;\{f1,f2,f3,f4,f5,f6,f7\} \$ \,vars\; : =\; \{A,B,C,D,E,F\}\$} \\ \multicolumn{3}{l}{\mbox{\it groebmonfac}\; :=\; 1; \%\mbox{\it allowing monomial factors with exponent $1$}} \\ \multicolumn{3}{l}{\mbox{\it res} \;:=\; \mbox{\it groebnerf $($polys,vars$)$};} \end{array} \] %{\small \begin{verbatim} RES := {{A,E,B,D,C}, {A, - E*P8 - C*P6,B,F*P6*P11 + C*P4*P8 + P6*P8,D}} % the above result has two partial bases; they have in % common that A,B and D are forced to zero \end{verbatim} %} groebmonfac := 0; \% now suppressing monomial factors at all \[ \mbox{\it res} := \mbox{\it groebnerf }(\mbox{\it polys,vars}); \] %{\small \begin{verbatim} RES := {{1}}; % with this configuration there is no solution at all. (The % system has no solution with only nonzero variable values) \end{verbatim} %} % Subsection 3.4.4 \subsubsection{Limitation on the Number of Results} The shared variable \ttindex{GROEBRESMAX} \begin{center} GROEBRESMAX \end{center} controls the number of partial results. Its default value is 300. If groebresmax partial results are calculated, the calculation is terminated. % Subsection 3.4.5 \subsubsection{Restriction to Real Nonnegative Solutions} In some applications only nonnegative values or positive definite values for the variables are interesting as solutions for a given set of equations. If a polynomial has no (strictly) positive zero, then every system containing it has no nonnegative or strictly positive solution. Therefore, the Buchberger algorithm tests the coefficients of the polynomials for equal sign if requested. For example, in $13*x + 15*y*z $ can be zero with real nonnegative values for $x, y$ and $z$ only if $x=0$ and $y=0$ or $ z=0$; this is a sort of ``factorization by restriction''. A polynomial $13*x + 15*y*z + 20$ never can vanish with nonnegative real variable values. By setting the shared variable \ttindex{GROEBRESTRICTION} \begin{center} GROEBRESTRICTION \end{center} GROEBNERF is informed of the type of restriction the user wants to impose on the solutions: \begin{center} \begin{tabular}{l} {\it GROEBRESTRICTION:=NONEGATIVE;} \\ \hspace*{+.5cm} only nonnegative real solutions are of interest\vspace*{4mm} \\ {\it GROEBRESTRICTION:=POSITIVE;} \\ \hspace*{+.5cm}only nonnegative and nonzero solutions are of interest. \end{tabular} \end{center} If GROEBNERF detects a polynomial which formally conflicts with the restriction, it either splits the calculation into separate branches, or, if a violation of the restriction is determined, it cancels the actual calculation branch. % Section 3.6 \subsection{GREDUCE, PREDUCE: Reduction of Polynomials} % Subsection 3.6.1 \subsubsection{Background} \label{GROEBNER:background} Reduction of a polynomial ``p'' modulo a given sets of polynomials ``B'' is done by the reduction algorithm incorporated in the Buchberger algorithm. Informally it can be described for polynomials over a field as follows: \begin{center} \begin{tabular}{l} loop1: \hspace*{2mm}\% head term elimination \\ \hspace*{-1cm} if there is one polynomial $b$ in $B$ such that the leading \\ term of $p$ is a multiple of the leading term of $p$ do \\ $p := p - lt(p)/lt(b) * b$ (the leading term vanishes)\\ \hspace*{-1cm} do this loop as long as possible; \\ loop2: \hspace*{2mm} \% elimination of subsequent terms \\ \hspace*{-1cm} for each term $s$ in $p$ do \\ if there is one polynomial $b$ in $B$ such that $s$ is a\\ multiple of the leading term of $p$ do \\ $p := p - s/lt(b) * b$ (the term $s$ vanishes) \\ \hspace*{-1cm}do this loop as long as possible; \end{tabular} \end{center} If the coefficients are taken from a ring without zero divisors we cannot divide by each possible number like in the field case. But using that in the field case $c*p $ is reduced to $c*q $, if $ p $ is reduced to $ q $, for arbitrary numbers $ c $, the reduction for the ring case uses the least $ c $ which makes the (field) reduction for $ c*p $ integer. The result of this reduction is returned as (ring) reduction of $ p $ eventually after removing the content, i.e. the greatest common divisor of the coefficients. The result of this type of reduction is also called a pseudo reduction of $ p $. % Subsection 3.5.2 \subsubsection{Reduction via Groebner Basis Calculation} \ttindex{GREDUCE} \[ \mbox{\it GREDUCE}(exp, \{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots , varn\}]); \] where {\it exp} is an expression, and $\{exp1, exp2,\ldots , expm\}$ is a list of any number of expressions or equations and $\{var1, var2,$ $\ldots , varn\}$ is an optional list of variables. GREDUCE first converts the list of expressions $\{exp1, \ldots , expn\}$ to a Groeb\-ner basis, and then reduces the given expression modulo that basis. An error results if the list of expressions is inconsistent. The returned value is an expression representing the reduced polynomial. As a side effect, GREDUCE sets the variable {\it gvarslast} in the same manner as GROEBNER does. \example\index{GROEBNER package ! example} (Note: This example assumes a new session, and not the above settings.) {\it greduce} $( 5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y$\\ \hspace*{+1cm} $ + 8*x**2 + 3/2*x - 9/2, $\\ \hspace*{+1cm} $\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3,$ \\ \hspace*{+1cm} $ 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3,$ \\ \hspace*{+1cm} $ x**3*y + x**2*y + 3*x**3 + 2*x**2 \});$ %{\small \begin{verbatim} 2 Y \end{verbatim} %} % Subsection 3.5.3 \subsubsection{Reduction with Respect to Arbitrary Polynomials} \ttindex{PREDUCE} \[ PREDUCE(exp, \{exp1, exp2,\ldots , expm\}[,\{var1, var2,\ldots , varn\}]); \] where $ exp $ is an expression, and $\{exp1, exp2, \ldots , expm \}$ is a list of any number of expressions or equations and $\{var1, var2, \ldots , varn\}$ is an optional list of variables. PREDUCE reduces the given expression modulo the set $\{exp1, \ldots , expm\}$. If this set is a Groebner basis, the obtained reduced expression is uniquely determined. If not, then it depends on the subsequence of the single reduction steps (see~\ref{GROEBNER:background}). PREDUCE does not check, whether $\{exp1, exp2, \ldots , expm\}$ is a Groebner basis in the actual order. Therefore, if the expressions are a Groebner basis calculated earlier with a variable sequence given explicitly or modified by optimization, the sequence of variables should be given as a parameter explicitly. \example (PREDUCE with an arbitrary set of polynomials): \index{GROEBNER package ! example} {\it preduce} $ ( 5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y + 8*x**2 + 3/2*x - 9/2, $ \\ \hspace*{+1cm} $ \{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3, $ \\ \hspace*{+1cm} $ 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3, $ \\ \hspace*{+1cm} $ x**3*y + x**2*y + 3*x**3 + 2*x**2 \}); $ %{\small \begin{verbatim} 2 2 12*X + 7*X*Y - 11*X + 30*Y + 5*Y - 15 \end{verbatim} %} \example (PREDUCE called with a Groebner basis): \index{GROEBNER package ! example} \[ \begin{array}{ll} gb := groebner & ( \{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3, \\ & 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3, \\ & x**3*y + x**2*y + 3*x**3 + 2*x**2 \}) \\ \multicolumn{2}{l}{preduce (5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y} \\ \multicolumn{2}{l}{\hspace*{+1cm}+ 8*x**2 + 3/2*x - 9/2, gb);} \end{array} \] %{\small \begin{verbatim} 2 Y \end{verbatim} %} % Subsection 3.5.4 \subsubsection{Reduction Tree} In some case not only the results produced by GREDUCE and PREDUCE are of interest, but the reduction process is of some value too. If the switch \ttindex{GROEBPROT} \begin{center} GROEBPROT \end{center} is set on, GREDUCE and PREDUCE produce as a side effect a trace of their work as a REDUCE list of equations in the shared variable \ttindex{GROEBPROTFILE} \begin{center} GROEBPROTFILE. \end{center} Its value is a list of equations with a variable ``candidate'' playing the role of the object to be reduced. The polynomials are cited as $``poly1'', ``poly2'', \ldots\;.$ If read as assignments, these equations form a program which leads from the reduction input to its result. Note that, due to the pseudo reduction with a ring as the coefficient domain, the input coefficients may be changed by global factors. \example \index{GROEBNER package ! example} {\it on groebprot} \$ \\ {\it preduce} $ (5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y + 8*x**2 $ \\ \hspace*{+1cm} $+ 3/2*x - 9/2, gb);$ \begin{verbatim} 2 Y \end{verbatim} {\it groebprotfile;} \begin{verbatim} 2 2 2 {CANDIDATE=4*X *Y + 16*X + 5*X*Y + 3*X + 10*Y + 3*Y - 9, 2 POLY1=8*X - 2*Y + 5*Y + 3, 3 2 POLY2=2*Y - 3*Y - 16*Y + 21, CANDIDATE=2*CANDIDATE, CANDIDATE= - X*Y*POLY1 + CANDIDATE, CANDIDATE= - 4*X*POLY1 + CANDIDATE, CANDIDATE=4*CANDIDATE, 3 CANDIDATE= - Y *POLY1 + CANDIDATE, CANDIDATE=2*CANDIDATE, 2 CANDIDATE= - 3*Y *POLY1 + CANDIDATE, CANDIDATE=13*Y*POLY1 + CANDIDATE, CANDIDATE=CANDIDATE + 6*POLY1, 2 CANDIDATE= - 2*Y *POLY2 + CANDIDATE, CANDIDATE= - Y*POLY2 + CANDIDATE, CANDIDATE=CANDIDATE + 6*POLY2} \end{verbatim} This means \begin{eqnarray*} \lefteqn{ 16 (5 y^2 + 2 x^2 y + \frac{5}{2} x y + \frac{3}{2} y + 8 x^2+ \frac{3}{2} x - \frac{9}{2})=} \\ & & (-8 x y -32 x -2 y^3 -3 y^2 + 13 y + 6) \mbox{POLY1} \\ & & \; + (-2 y^2 -2 y + 6) \mbox{POLY2 } \; + y^2. \end{eqnarray*} % new 3.6/Sept 21 \subsection{Tracing with GROEBNERT and PREDUCET} Given a set of polynomials $\{f_1,\ldots ,f_k\}$ and their Groebner basis $\{g_1,\ldots ,g_l\}$, it is well known that there are matrices of polynomials $C_{ij}$ and $D_{ji}$ such that \[ f_i = \displaystyle{\sum\limits_j} C_{ij} g_j \;\mbox{ and } g_j = \displaystyle{\sum\limits_i} D_{ji} f_i \] and these relations are needed explicitly sometimes. In {\sc Buchberger} \cite{Buchberger:85}, such cases are described in the context of linear polynomial equations. The standard technique for computing the above formulae is to perform Groebner reductions, keeping track of the computation in terms of the input data. In the current package such calculations are performed with (an internally hidden) cofactor technique: the user has to assign unique names to the input expressions and the arithmetic combinations are done with the expressions and with their names simultaneously. So the result is accompanied by an expression which relates it algebraically to the input values. \ttindex{GROEBNERT} \ttindex{PREDUCET} There are two complementary operators with this feature: GROEBNERT and PREDUCET; functionally they correspond to GROEBNER and PREDUCE. However, the sets of expressions here {\it {\bf must be}} equations with unique single identifiers on their left side and the {\it lhs} are interpreted as names of the expressions. Their results are sets of equations (GROEBNERT) or equations (PREDUCET), where a {\it lhs} is the computed value, while the {\it rhs} is its equivalent in terms of the input names. \example \index{GROEBNER package ! example} We calculate the Groebner basis for an ellipse (named ``$p1$'' ) and a line (named ``$p2$'' ); $p2$ is member of the basis immediately and so the corresponding first result element is of a very simple form; the second member is a combination of $p1$ and $p2$ as shown on the {\it rhs} of this equation: \noindent{\it gb1:=groebnert$({p1=2*x**2+4*y**2-100,p2=2*x-y+1})$;} \begin{verbatim} GB1 := {2*X - Y + 1=P2, 2 9*Y - 2*Y - 199= - 2*X*P2 - Y*P2 + 2*P1 + P2} \end{verbatim} \example \index{GROEBNER package ! example} We want to reduce the polynomial \verb+ x**2+ {\it wrt} the above Groebner basis and need knowledge about the reduction formula. We therefore extract the basis polynomials from $GB1$, assign unique names to them (here $G1$, $G2$) and call PREDUCET. The polynomial to be reduced here is introduced with the name $Q$, which then appears on the {\it rhs} of the result. If the name for the polynomial is omitted, its formal value is used on the right side too. \noindent{\it gb$2$ := for $k := 1:$length gb$1$ collect $\Bigl(mkid(g,k) = lhs$ part$(gb1,k)\Bigr)$;} \begin{verbatim} 2 GB2 := {G1=2*X - Y + 1,G2=9*Y - 2*Y - 199} \end{verbatim} \noindent{\it preducet$(q=x**2,gb2)$;} \begin{verbatim} - 16*Y + 208= - 18*X*G1 - 9*Y*G1 + 36*Q + 9*G1 - G2 \end{verbatim} \noindent{\it preducet$(x**2,gb2)$;} \begin{verbatim} 2 - 16*Y + 208=36*X - 18*X*G1 - 9*Y*G1 + 9*G1 - G2 \end{verbatim} In both cases the output means \[ x^2 = (\frac{1}{2} x + \frac{1}{4} y - \frac{1}{4}) G1 + \frac{1}{36} G2 + (-\frac{4}{9} y + \frac{52}{9}). \] \example \index{GROEBNER package ! example} If we reduce a polynomial which is member of the ideal, we consequently get a result with {\it lhs} zero: \noindent{\it preducet$(q=2*x**2+4*y**2-100,gb2)$; } \begin{verbatim} 0= - 2*X*G1 - Y*G1 + 2*Q + G1 - G2 \end{verbatim} This means \[ Q = ( x + \frac{1}{2} y - \frac{1}{2}) G1 + \frac{1}{2} G2. \] With these operators the matrices $C_{ij}$ and $D_{ji}$ are available implicitly, $D_{ji}$ as side effect of GROEBNERT, $C_{ij}$ by {\it calls} of PREDUCET of $f_i$ {\it wrt} $\{g_j\}$. The latter by definition will have the {\it lhs} zero and a {\it rhs} with linear $f_i$. If $\{1\}$ is the Groebner basis, the GROEBNERT calculation gives a ``proof'', showing, how $1$ can be computed as combination of the input polynomials. \paragraph{Remark:} Compared to the non-tracing algorithms, these operators are much more time consuming. So they are applicable only on small sized problems. % *** SO BESSER ?? %Section 3.8 \subsection{GROEBNERM: Groebner Bases for Modules} Polynomial r-tuples $(p1,\ldots,pr) $ can be added componentwise and multiplied by $ p*(p1,\ldots,pr) := (p*p1,\ldots,p*pr) $ for arbitrary polynomials $p.$ Given finitely many of such polynomial r-tuples $P1:=(p11,\ldots,p1r),\ldots,Pm:=(pm1,\ldots,pmr),$ the polynomial module \[ M := \{ g1*P1 + \cdots + gm*Pm \mid g1,\ldots,gm \mbox{ polynomials} \} \] possesses a Groebner basis for arbitrary admissible term orderings and arbitrary weights. \ttindex{GROEBNERM} The operator GROEBNERM calculates the Groebner basis of the module \[ \mbox{GROEBNERM } \bigl(\{expr1, \ldots , exprm\} [,\{var1, \ldots , varn\} [, \{w_1, \ldots , w_r] ] \bigr) \] where \begin{quote} $\{expr1, \ldots , exprm\}$ are r-tuples of polynomials written as list, \linebreak[4]$\{var1, \ldots , varn\}$ is an optional list of variables and $\{w_1, \ldots , w_r\}$ is a list of positive integers $<1000$. \end{quote} Alternatively the {\it expr} can be expression of the form \[ p= \{pol1, \ldots , polr\} \] with a ``name''--variable as with GROEBNERT. In this case, a tracing Groebner basis calculation is performed. The $\{w1, \ldots , wr\}$ are weights assigned to the components of the vector space, if a graduated ordering is active. If omitted, all components are weighted with 1. \example \index{GROEBNER package ! example} \[ \begin{array}{lll} B & := & \{\{ 1 , 0 , 0 , 0 , 0 \}, \\ & & \;\;\{ 0 , 0 , 0 , 0 , -1\}, \\ & & \;\;\{ 0 , 0 , 0 , 1 , 0\}, \\ & & \;\;\{ 0 , 0 , -1 , 0 , x^2\}\}\$ \vspace*{4mm} \\ D & := & \{\{ -x , y , 1 , 0 , 0 \}, \\ & &\;\;\{ 0 ,5x^2 , y , 1 , 0 \}, \\ & &\;\;\{ 0 , 0 ,4x^2 , 5y , y\}, \\ & &\;\;\{ 0 , 5 , 0 , x^2 , y \}\}; \end{array} \] groebnerM (append$(b,d)\, ,\;\{x,y\}\,, \;\{4,4,5,6,7\}$); \begin{verbatim} 2 {{0,5,0,X ,Y}, 2 {0,0,-1,0,X }, { - X,Y,1,0,0}, {1,0,0,0,0}, {0,1,0,0,0}, {0,0,1,0,0}, {0,0,0,1,0}, {0,0,0,0,-1}} \end{verbatim} \[ \begin{array}{lllll} \mbox{Btagged} & := & \{t1 & = & \{ 1 , 0 , 0 , 0 , 0 \}, \\ & & \;\; t2 & = & \{ 0 , 0 , 0 , 0 , -1 \}, \\ & & \;\; t3 & = & \{ 0 , 0 , 0 , 1 , 0 \}, \\ & & \;\; t4 & = & \{ 0 , 0 , -1 , 0 , x^2 \}\}\$ \end{array} \] \noindent groebnerM (append(btagged,d) , $\{x,y\} \,, \;\{4,4,5,6,7\}$); \begin{verbatim} 2 {{0,5,0,X ,Y}, 2 {0,0,-1,0,X }=T4, { - X,Y,1,0,0}, {1,0,0,0,0}=T1, 2 - X *T3 + Y*T2 {0,1,0,0,0}=-----------------, 5 2 {0,0,1,0,0}= - X *T2 - T4, {0,0,0,1,0}=T3, {0,0,0,0,-1}=T2} \end{verbatim} %Section 3.9 \subsection{Additional Orderings} Besides the basic orderings, there are ordering options which are used for special purposes. %Section 3.7.1 \subsubsection{Separating the Variables into Groups } \index{grouped ordering} It is often desirable to separate variables and formal parameters in a system of polynomials. This can be done with a {\it lex} Groebner basis. That however may be hard to compute as it does more separation than necessary. The following orderings group the variables into two (or more) sets, where inside each set a classical ordering acts, while the sets are handled via their total degrees, which are compared in elimination style. So the Groebner basis will eliminate the members of the first set, if algebraically possible. {\it Torder} here gets an additional parameter which describe the grouping \ttindex{TORDER} \begin{center}{\it \begin{tabular}{l} TORDER gradlexgradlex, n; \\ TORDER gradlexrevgradlex, n; \\ TORDER lexgradlex, n; \\ TORDER lexrevgradlex, n; \end{tabular}} \end{center} Here the integer $n$ is the number of variables in the first group and the names combine the local ordering for the first and second group, e.g. \begin{center} \begin{tabular}{llll} \multicolumn{4}{l}{{\it lexgradlex}, 3 for $\{x_1,x_2,x_3,x_4,x_5\}$:} \\ \multicolumn{4}{l}{$x_1^{i_1}\ldots x_5^{i_5} \gg x_1^{j_1}\ldots x_5^{j_5}$} \\ if & & & $(i_1,i_2,i_3) \gg_{lex}(j_1,j_2,j_3)$ \\ & or & & $(i_1,i_2,i_3) = (j_1,j_2,j_3)$ \\ & & and & $(i_4,i_5) \gg_{gradlex}(j_4,j_5)$ \end{tabular} \end{center} Note that in the second place there is no {\it lex} ordering available; that would not make sense. \subsubsection{Weighted Ordering} \ttindex{TORDER} \index{weighted ordering} The statement \begin{center} \begin{tabular}{cl} {\it TORDER} & weighted, $n_1,n_2,n_3 \ldots$ ; \\ or \\ {\it TORDER} & weighted, $\{n_1,n_2,\ldots\}$ \end{tabular} \end{center} establishes a graduated ordering, where the exponents first are multiplied by the given weights. If there are less weight values than variables, the weight 1 is added automatically. \subsubsection{Arbitrary Ordering} \index{arbitrary ordering} \ttindex{TORDER} If none of the given orderings fulfills the requirements, the user can supply a private ordering in form of a procedure: \begin{center} {\it TORDER} private, $\langle${\it name}$\rangle$; \end{center} where $\langle${\it name}$\rangle$ is the name of a procedure. This procedure must have the following properties: \begin{itemize} \item written in symbolic mode (or LISP), \item accept 2 parameters $v_1$, $v_2$, which are vectors with the exponents to be compared beginning with index 1 \item return \[ \begin{array}{rll} -1 & \mbox{ if } & v_1 \ll v_2 \\ 0 & \mbox{ if } & v_1 = v_2 \\ +1 & \mbox{ if } & v_1 \gg v_2 \end{array} \] \end{itemize} This procedure should be compiled because it is called very frequently. Operators for fast vector access and fast integer arithmetic should be used where available. A simple specimen for this procedure is: \begin{center} \begin{tabular}{l} \hspace*{-1cm}symbolic procedure specimen $(v_1,v_2)$; \vspace*{1mm}\\ \% simulating a 2 dim {\it lex} ordering. \\ if $getv(v1,1) < getv(v2,1)$ then $-1$ else \\ if $getv(v1,1) > getv(v2,1)$ then $1$ else \\ if $getv(v1,2) < getv(v2,2)$ then $-1$ else \\ if $getv(v1,2) > getv(v2,2)$ then $1$ else 0; \vspace*{2mm} \\ \hspace*{-1cm}torder private, specimen; \end{tabular} \end{center} where e.g. with PSL-based REDUCE {\it getv} should be replaced by {\it igetv} and $\#>$ resp $\#<$ should be used instead of the generic comparisons. During initialization, the Groebner package tests if the procedure represents an admissible ordering. However, this test cannot be complete and so the responsibility remains with the user. % Chapter 4 \section{Ideal Decomposition \& Equation System Solving} Based on the elementary Groebner operations, the Groebner package offers additional operators, which allow the decomposition of an ideal or of a system of equations down to the individual solutions. % Section 4.1 \subsection{Solutions Based on Lex Type Groebner Bases} % Subsection 4.1.1 \subsubsection{GROESOLVE: Solution of a Set of Polynomial Equations} \ttindex{GROESOLVE} \ttindex{GROEBNERF} The GROESOLVE operator incorporates a macro algorithm; lexical Groebner bases are computed by GROEBNERF and decomposed into simpler ones by ideal decomposition techniques; if algebraically possible, the problem is reduced to univariate polynomials which are solved by SOLVE; if ROUNDED is on, numerical approximations are computed for the roots of the univariate polynomials. \[ GROESOLVE(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots , varn\}]); \] where $\{exp1, exp2,\ldots , expm\}$ is a list of any number of expressions or equations, $\{var1, var2, \ldots , varn\}$ is an optional list of variables. The result is a set of subsets. The subsets contain the solutions of the polynomial equations. If there are only finitely many solutions, then each subset is a set of expressions of triangular type $\{exp1, exp2,\ldots , expn\},$ where $exp1$ depends only on $var1,$ $exp2$ depends only on $var1$ and $var2$ etc. until $expn$ which depends on $var1,\ldots,varn.$ This allows a successive determination of the solution components. If there are infinitely many solutions, some subsets consist in less than $n$ expressions. By considering some of the variables as ``free parameters'', these subsets are usually again of triangular type. \example (intersections of a line with a circle): \index{GROEBNER package ! example} \[ GROESOLVE(\{x**2 - y**2 - a, p*x+q*y+s\},\{x,y\}); \] %{\small \begin{verbatim} 2 2 2 2 2 {{X=(SQRT( - A*P + A*Q + S )*Q - P*S)/(P - Q ), 2 2 2 2 2 Y= - (SQRT( - A*P + A*Q + S )*P - Q*S)/(P - Q )}, 2 2 2 2 2 {X= - (SQRT( - A*P + A*Q + S )*Q + P*S)/(P - Q ), 2 2 2 2 2 Y=(SQRT( - A*P + A*Q + S )*P + Q*S)/(P - Q )}} \end{verbatim} %} % Subsection 4.1.2 \subsubsection{GROEPOSTPROC: Postprocessing of a Groebner Basis} \ttindex{GROEPOSTPROC} In many cases, it is difficult to do the general Groebner processing. If a Groebner basis with a {\it lex} ordering is calculated already (e.g. by very individual parameter settings), the solutions can be derived from it by a call to GROEPOSTPROC. GROESOLVE is functionally equivalent to a call to GROEBNERF and subsequent calls to GROEPOSTPROC for each partial basis. \[ GROEPOSTPROC(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots , varn\}]); \] where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of expressions, \linebreak[4] $\{var1, var2, \ldots ,$ $ varn\}$ is an optional list of variables. The expressions must be a {\it lex} Groebner basis with the given variables; the ordering must be still active. The result is the same as with GROESOLVE. \begin{verbatim} groepostproc({x3**2 + x3 + x2 - 1, x2*x3 + x1*x3 + x3 + x1*x2 + x1 + 2, x2**2 + 2*x2 - 1, x1**2 - 2},{x3,x2,x1}); {{X3= - SQRT(2), X2=SQRT(2) - 1, X1=SQRT(2)}, {X3=SQRT(2), X2= - (SQRT(2) + 1), X1= - SQRT(2)}, SQRT(4*SQRT(2) + 9) - 1 {X3=-------------------------, 2 X2= - (SQRT(2) + 1), X1=SQRT(2)}, - (SQRT(4*SQRT(2) + 9) + 1) {X3=------------------------------, 2 X2= - (SQRT(2) + 1), X1=SQRT(2)}, SQRT( - 4*SQRT(2) + 9) - 1 {X3=----------------------------, 2 X2=SQRT(2) - 1, X1= - SQRT(2)}, \end{verbatim} \newpage %JBM \begin{verbatim} - (SQRT( - 4*SQRT(2) + 9) + 1) {X3=---------------------------------, 2 X2=SQRT(2) - 1, X1= - SQRT(2)}} \end{verbatim} % Subsection 4.1.3 \subsubsection{IDEALQUOTIENT: Quotient of an Ideal and an Expression} \ttindex{IDEALQUOTIENT} \index{ideal quotient} Let $I$ be an ideal and $f$ be a polynomial in the same variables. Then the algebraic quotient is defined by \[ I:f = \{ p \;| \; p * f \;\mbox{ member of }\; I\}\;. \] The ideal quotient $I:f$ contains $I$ and is obviously part of the whole polynomial ring, i.e. contained in $\{1\}$. The case $I:f = \{1\}$ is equivalent to $f$ member of $I$. The other extremal case, $I:f=I$, occurs, when $f$ does not vanish at any general zero of $I$. The explanation of the notion `general zero' introduced by van der Waerden, however, is beyond the aim of this manual. The operation of GROESOLVE/GROEPOSTPROC is based on nested ideal quotient calculations. If $I$ is given by a basis and $f$ is given as an expression, the quotient can be calculated by \[ IDEALQUOTIENT (\{exp1, \ldots , expm\}, exp [,\{var1, \ldots , varn\}]); \] where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of expressions or equations, {\it exp} is a single expression or equation and $\{var1, var2, \ldots , varn\}$ is an optional list of variables. IDEALQUOTIENT calculates the algebraic quotient of the ideal $I$ with the basis $\{exp1, exp2, \ldots , expm\}$ and {\it exp} with respect to the variables given or extracted. $\{exp1, exp2, \ldots , expm\}$ is not necessarily a Groebner basis. As long as the switch GROEBIDQBASIS is on (default), the result is the Groebner basis of the quotient. With OFF GROEBIDQBASIS, the final Groebner basis calculation is suppressed; that makes sense, if e.g. a chain of quotients has to be calculated and the time for the additional normalizations should be saved; the result then is a basis for the quotient, which, however, in general does not have the Groebner properties. % Section 4.2 \subsection{Operators for Groebner Bases in all Term Orderings} \index{Hilbert polynomial} In some cases where no Groebner basis with lexical ordering can be calculated, a calculation with a total degree ordering is still possible. Then the Hilbert polynomial gives information about the dimension of the solutions space and for finite sets of solutions univariate polynomials can be calculated. The solutions of the equation system then is contained in the cross product of all solutions of all univariate polynomials. % Subsection 4.2.1 \subsubsection{HILBERTPOLYNOMIAL: Hilbert Polynomial of an Ideal} \ttindex{HILBERTPOLYNOMIAL} This algorithm was contributed by {\sc Joachim Hollman}, Royal Institute of Technology, Stockholm (private communication). \[ HILBERTPOLYNOMIAL (\{exp1, \ldots , expm\} [,\{var1, \ldots , varn\}])\;; \] where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of expressions or equations, $\{var1, var2, \ldots , varn\}$ is an optional list of variables. HILBERTPOLYNOMIAL calculates the Hilbert polynomial of the ideal with basis $\{exp1, exp2, \ldots , expm\}$ with respect to the variables given or extracted provided the given term ordering is compatible with the degree, such as the GRADLEX- or REVGRADLEX-ordering. The term ordering of the basis must be active and $\{exp1, exp2,\ldots$, $ expm\}$ should be a Groebner basis with respect to this ordering. The Hilbert polynomial gives information about the cardinality of solutions of the system $\{exp1, exp2, \ldots , expm\}$: if the Hilbert polynomial is an integer, the system has only a discrete set of solutions and the polynomial is identical with the number of solutions counted with their multiplicities. Otherwise the degree of the Hilbert polynomial is the dimension of the solution space. If the Hilbert polynomial is not a constant, it is constructed with the variable ``X'' regardless of whether $x$ is member of $\{var1, var2, \ldots , varn\}$ or not. The value of this polynomial at sufficiently large numbers ``X'' is the difference of the dimension of the linear vector space of all polynomials of degree $ \leq X $ minus the dimension of the subspace of all polynomials of degree $\leq X $ which belong also to the ideal. \paragraph{Remark:} The number of zeros in an ideal and the Hilbert polynomial depend only on the leading terms of the Groebner basis. So if a subsequent Hilbert calculation is planned, the Groebner calculation should be performed with ON GLTBASIS and the value of GLTB (or its elements in a Groebnerf context) should be given to HILBERTPOLYNOMIAL. In this manner, a lot of computing time can be saved in the case of large bases. % Chapter 5. \section{Calculations ``by Hand''} The following operators support the explicit calculation with polynomials in a distributive representation on the REDUCE top level. So they allow one to do Groebner type evaluations stepwise by separate calls. Note that the normal REDUCE arithmetic can be used for arithmetic combinations of monomials and polynomials. % Subsection 5.1 \subsection{Representing Polynomials in Distributive Form} \ttindex{GSORT} \[ GSORT (p[,\{var1, var2, \ldots , varm\}]); \] where $p$ is a polynomial or a list of polynomials, $\{var1, var2, \ldots , varm\}$ in the optional list of variables. If $p$ is a single polynomial, the result is a reordered version of $p$ in the distributive representation according to the variables and the current term order mode; if $p$ is a list, its members are converted into distributive representation and the result is the list sorted by the term ordering of the leading terms; zero polynomials are eliminated from the result. \example \index{GROEBNER package ! example} {\it korder alpha,beta,gamma;}\\ {\it dip} := {\it gsort$($gamma$*($alpha$-1)**\,2 *($beta$+1)**\,2)$;} %{\small \begin{verbatim} 2 2 2 DIP := ALPHA *BETA *GAMMA + 2*ALPHA *BETA*GAMMA 2 2 + ALPHA *GAMMA - 2*ALPHA*BETA *GAMMA - 4*ALPHA*BETA*GAMMA 2 - 2*ALPHA*GAMMA + BETA *GAMMA + 2*BETA*GAMMA + GAMMA \end{verbatim} %} % Subsection 5.2 \subsection{Splitting of a Polynomial into Leading Term and Reductum<} \ttindex{GSPLIT} \[ GSPLIT (p[,\{var1, var2,\ldots ,varm\}]); \] where $p$ is a polynomial, $\{var1, var2, \ldots , varm\}$ in the optional list of variables. GSPLIT converts the polynomial $p$ into distributive representation and splits it into leading monomial and reductum. The result is a list with two elements, the leading monomial and the reductum. \example \index{GROEBNER package ! example} {\it gsplit(dip); } %{\small \begin{verbatim} 2 2 {ALPHA *BETA *GAMMA, 2 2 2 2*ALPHA *BETA*GAMMA + ALPHA *GAMMA - 2*ALPHA*BETA *GAMMA 2 - 4*ALPHA*BETA*GAMMA - 2*ALPHA*GAMMA + BETA *GAMMA + 2*BETA*GAMMA + GAMMA} \end{verbatim} %} % Section 5.3 \subsection{Calculation of Buchberger's S-polynomial} \ttindex{GSPOLY} \[ GSPOLY (p1,p2[,\{var1, var2, \ldots , varm\}]); \] where $p1$ and $p2$ are polynomials, $\{var1, var2, \ldots , varm\}$ in the optional list of variables. GSPOLY calculates the $S$-polynomial from $p1$ and $p2$; Example for a complete calculation (taken from {\sc Davenport et al.} \cite{Davenport:88a}): \hspace*{+1cm}{\it \% initial system} \\ \hspace*{+1cm}{\it korder x,y,z; torder lex;} \\ \hspace*{+1cm} $g1 := x**3*y*z - x*z**2;$\\ \hspace*{+1cm} $g2 := x*y**2*z - x*y*z; $ \\ \hspace*{+1cm} $g3 := x**2*y**2 - z;$ \hspace*{+1cm}{\it \% first S-polynomial} \\ \hspace*{+1cm} $g4 := gspoly(g2,g3);$ %{\small \begin{verbatim} 2 2 G4 := X *Y*Z - Z \end{verbatim} %} \hspace*{+1cm}{\it \% next S-polynomial} \\ \hspace*{+1cm} $p := gspoly(g2,g4); $ %{\small \begin{verbatim} 2 2 P := X *Y*Z - Y*Z \end{verbatim} %} \hspace*{+1cm}{\it \% and reducing, here only by g4, but preduce needs a list} \\ \hspace*{+1cm} $g5 := preduce(p,\{g4\}); $ %{\small \begin{verbatim} 2 2 G5 := - Y*Z + Z \end{verbatim} %} \hspace*{+1cm}{\it \% last S-polynomial} \\ \hspace*{+1cm}$ g6 := gspoly(g4,g5);$ %{\small \begin{verbatim} 2 2 3 G6 := X *Z - Z \end{verbatim} %} \hspace*{+1cm}{\it \% and the final basis sorted descending} \\ \hspace*{+1cm}{\it gsort} $(\{g2,g3,g4,g5,g6\});$ %{\small \begin{verbatim} 2 2 {X *Y - Z, 2 2 X *Y*Z - Z , 2 2 3 X *Z - Z , 2 X*Y *Z - X*Y*Z, 2 2 - Y*Z + Z } \end{verbatim} %} \bibliography{groebner} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/install.tex version [315e3fbdc8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \addtolength{\topmargin}{-.5cm} \documentstyle[11pt]{report} \parindent 0pt \parskip 6pt \pagestyle{empty} \setlength{\topsep}{0.5\baselineskip} % above and below environments \setlength{\itemsep}{\topsep} \setlength{\abovedisplayskip}{\topsep} % for "long" equations \setlength{\belowdisplayskip}{\topsep} \renewcommand{\arraystretch}{1.3} \renewcommand{\thechapter}{\arabic{chapter}} \renewcommand{\thesection}{\arabic{section}.} \renewcommand{\thesubsection}{\arabic{subsection}.} \newcommand{\REDUCE}{REDUCE} % The following are version dependent. \newcommand{\system}{Sun Microsystems SPARC systems and Sun 4} \newcommand{\programsize}{2.5} % megabytes \newcommand{\virtualsize}{5} % megabytes \newcommand{\timingmachine}{Sun 4/260} \newcommand{\machinefactors}{SparcStation 1+&0.9 \\ SparcStation 2 &0.7 \\ SparcServer &0.9 \\ Sun 4/110 &1.1 \\ Sun 4/65 &1.0} \newcommand{\cartridgecommand}{{\tt tar xbf 126 /dev/rst0}} \newcommand{\tapespace}{8.8} % megabytes \newcommand{\createtime}{11} % seconds \newcommand{\executablespace}{2.5} % megabytes \newcommand{\testtime}{5.5} % seconds \begin{document} \begin{titlepage} \samepage %\vspace*{1cm} \begin{center} \begin{minipage}{10cm} \begin{center} {\LARGE {\bf REDUCE} Installation Guide for the} \vspace*{2mm} \\ {\LARGE {\system} Workstations} \\[0.3cm] {\LARGE Version 3.4} \\[0.3cm] {\large by} \\[0.3cm] {\Large Anthony C. Hearn}\\ {\large RAND} \\ {\large Santa Monica, CA 90407-2138 USA} \\[0.3cm] {\large and} \\[0.3cm] {\Large Winfried Neun}\\ {\large ZIB} \\ {\large 1000 Berlin 31, FRG} \\[0.3cm] {\large July 1991}\\[0.5cm] \vfill {\bf Abstract} \end{center} \end{minipage} \end{center} This guide describes the {\REDUCE} distribution tape and procedures for installing, testing and maintaining {\REDUCE} for the {\system} workstation. \begin{center} {ZIB Publication M 2.011.04} \\*[1cm] Copyright \copyright 1991 by RAND and ZIB. All rights reserved. \end{center} \nopagebreak Registered system holders may reproduce all or any part of this publication for internal purposes, provided that the source of the material is clearly acknowledged, and the copyright notice is retained. \end{titlepage} \newpage \tableofcontents \thispagestyle{empty} \newpage \setcounter{page}{1} \pagestyle{plain} \section{Introduction} This guide describes the {\REDUCE} distribution tape and procedures for installing, testing and maintaining {\REDUCE} on the {\system} workstation. {\REDUCE} is based on Standard Lisp, and this version requires the availability of Portable Standard Lisp (PSL), version 3.4 or later. The PSL files necessary to run {\REDUCE} are included on the system tape. This is not however a complete PSL system and in particular does not include PSL sources. A complete PSL, if needed, is available separately from the Konrad-Zuse-Zentrum by contacting: \begin{center} Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin \\ - Symbolik - \\ Heilbronner Str. 10 \\ 1000 Berlin 31 \\ Federal Republic of Germany \\ Telephone: (+49) 30 89604 195 \\ Electronic Mail: melenk@sc.ZIB-Berlin.dbp.de \\ or: melenk@sc.ZIB-Berlin.de (Internet) \\ Facsimile: (+49) 30 89604 125. \end{center} The distributed version of {\REDUCE} requires approximately {\programsize} megabytes for the program alone without taking into account workspace requirements. It takes its default execution size from the underlying PSL system, which is approximately {\virtualsize} megabytes, and can be enlarged at runtime (see REDUCE User's Guide). The job times given in this guide are for the {\timingmachine}. The following approximate adjustment factors for other machines have been found to apply: \begin{center} \begin{tabular}{ll} \machinefactors \end{tabular} \end{center} \newpage \section{Description of the {\REDUCE} Distribution Tape} The distribution tape is in {\tt tar} format, and was written from the {\REDUCE} root directory. The files are organized in sub-directories, where the sub-directory name describes the contents of the directory, e.g., ./reduce.rootdir/doc. The names and contents of these sub-directories are: \begin{enumerate} \item[{\bf doc}] {\REDUCE} documents, including descriptions of all user contributed packages and the following: \begin{center} \begin{tabular}{rl} reduce.tex & {\REDUCE} User's Manual in \LaTeX\ format \\ install.tex & Installation instructions in \LaTeX\ format \\ oper.tex & System specific operation notes in \LaTeX\ format \\ sl.doc & Standard LISP Report in plain text format. % bugs33.doc & Known bugs and problems in REDUCE 3.3. \end{tabular} \end{center} \item [{\bf fasl} ] Binary versions of sources for fast loading {\REDUCE} functions \item [{\bf lib}] {\REDUCE} user library \item [{\bf log} ] Depository for log files created during system building and testing (initially empty) \item [{\bf psl}] PSL binaries and related files needed to run {\REDUCE} \item [{\bf src}] Sources for creating {\REDUCE}, written in both PSL and RLISP \item [{\bf util}] Appropriate scripts for building {\REDUCE}, etc. \item [{\bf xlog}] ``Exemplary" log files for comparison with your own such files \item [{\bf xmpl}] {\REDUCE} tests, demonstrations and the interactive lessons. \end{enumerate} \section{Installing {\REDUCE}} The following description assumes that {\tt csh} is used as the command shell. If a different shell is used, please change the commands accordingly. To install {\REDUCE}, you need to create a directory for the {\REDUCE} file system. This is identified as ``\$reduce" from now on. It is assumed that you have write access to this directory. Connect to this directory, mount the tape and type for a 1/2" tape \begin{center} \begin{tabbing} and for cartridge tape xxx \= tar x \kill \> {\tt tar x} \\ and for a cartridge tape \\ \> {\cartridgecommand} \end{tabbing} \end{center} This will retrieve all files, and requires approximately {\tapespace} megabytes of disk space. Finally, please run the commands: \begin{center} \begin{tabbing} and for cartridge tape xxx \= tar x \kill \> util/sparsify psl/bpsl \\ and \\ \> util/sparsify reduce \\ which will diminish the disk space requirements. \end{tabbing} \end{center} In most cases the installation of Reduce is complete after unloading the tape. The location of the {\REDUCE} root directory is essential for using {\REDUCE}. Please advise users to set the variable {\tt reduce} in their environment to this location. It may be useful to add a link from one of the standard directories for binaries (e.g. /usr/local/bin) to the reduce root directory. Alternatively, if you prefer not to ask users to set {\tt reduce}, the {\tt reduce} script in the util directory, suitably modified for local file conventions, could be installed in say /usr/local/bin. {\REDUCE} is stored in the system as a binary executable disk file \$reduce/reduce. If modifications of the default settings are requested, one can rebuild this file, which is on the tape, by the following commands: \begin{verbatim} setenv reduce <REDUCE root directory> $reduce/util/mkreduce \end{verbatim} Output from this step is logged to the file \$reduce/log/mkreduce.log. The mkreduce script builds a {\REDUCE} image of the size described above. This is usually adequate for most calculations. If you require a larger (or smaller) image, you should edit the mkreduce script, and modify the numbers in the call of bpsl. In particular, the ``td'' parameter is the total heap and binary program space size (in bytes). During the building of the {\REDUCE} binary, messages saying that various functions have been defined, or not defined, are normal, and can therefore be ignored. \section{Printing Documents} The distributed documents are in the directory \$reduce/doc. The \LaTeX\ files need processing before they can be printed. Plain text files may be printed using standard UNIX utilities. They are paginated and formatted with standard ASCII control characters. A maximum of sixty print lines per page are assumed. The left margin offset must be supplied by the user. \section{Testing {\REDUCE}} To test the {\REDUCE} installation enter: \begin{verbatim} reduce.bindir/reduce in "$reduce/xmpl/reduce.tst"; \end{verbatim} This requires about {\testtime} seconds on the system as described above. Other programs for testing the {\REDUCE} system assembly may also be found in the directory \$reduce/xmpl. \section{Running {\REDUCE} Programs} Once reduce.bindir in the user's search path, {\REDUCE} is simply invoked with its name: \begin{verbatim} reduce \end{verbatim} {\REDUCE} will respond with a banner line and then prompt for the first line of input: \begin{verbatim} REDUCE 3.4, 15-Jul-91 ... 1: \end{verbatim} Prototypical instructions for using this version of {\REDUCE} are available as the file \$reduce/doc/oper.tex. You should edit this to reflect your site-specific implementation before issuing it to users. System independent instructions for the use of {\REDUCE} are given in the {\REDUCE} User's Manual. \section{Working with Minimal Disk Space} Many of the {\REDUCE} system files are not necessary for running {\REDUCE}. In situations where disk space is at a premium, the following files may be deleted from disk: \begin{enumerate} \item[--] all files in the sub-directories doc, src, util, xlog, log and xmpl, \item[--] the files in the sub-directory psl which are listed in the file cleanup.csh in this sub-directory, \item[--] the files alg.b, arith.b, entry.b, mathpr.b, module.b, poly.b, prolog.b, rend.b, and rlisp.b in the sub-directory fasl. \end{enumerate} After rebuilding or copying the files psl/bpsl and reduce, you should run the program {\tt util/sparsify} with the relevant filename as parameter. This will drastically reduce the amount of disk space used. Although the sub-directories doc and xmpl are not necessary, it is advisable to leave at least the {\REDUCE} manual, system operating instructions, the documents for the user packages and the {\REDUCE} interactive lessons on line for users. \section{Rebuilding REDUCE FASL Files} Because of its organization into independently compilable modules, the current {\REDUCE} system is fairly easy to maintain. If any source updates are necessary, they can be incorporated into the appropriate files using a convenient editor. Once any of the system source files have been updated, it is necessary to rebuild (compile) the equivalent fast loading modules in order to utilize the changes. To rebuild any of the {\REDUCE} fasl files, connect to the directory \$reduce and call the script: \begin{verbatim} util/mkfasl xxx \end{verbatim} where {\tt xxx} is the appropriate package name, e.g. rend to rebuild \$reduce/fasl/rend.b from \$reduce/src/rend.red. If any of the fasl files used in building the {\REDUCE} system are changed (alg, arith, entry, mathpr, module, poly, prolog, rend, and rlisp), the reduce binary image will need to be rebuilt with the script: \begin{verbatim} util/mkreduce \end{verbatim} A separate utility script \$reduce/util/build is available for completely rebuilding all of the {\REDUCE} fasl files. This should normally never be required and is included only in case the system becomes so corrupted that it is no longer possible to rebuild even single modules with the mkfasl procedure. \section{Maintaining {\REDUCE}} The {\tt util} directory includes a number of scripts that are useful for the ongoing maintenance of {\REDUCE}. Most of these are only of interest to the system maintainer, although some (such as {\tt mkslfile} and {\tt test}) may be of interest to the general user. Several of these scripts have been described earlier in this Guide. However, for completeness, they are all described in this section. The scripts are as follows: \paragraph{build} This is used to rebuild the complete {\REDUCE} fast-loading (fasl) file system from scratch. It first uses the script {\tt dbuild} to build a version of {\REDUCE} suitable for compiling all packages, and then uses the script {\tt xbuild} to create the actual fasl files. \paragraph{check-all} This can be used to check the logs generated by {\tt test-all} with the ``exemplary" versions found in {\tt xlog}. It produces a {\tt diff} of each log referenced in {\tt test-all}. \paragraph{dbuild} This is used by {\tt build} (q.v.) to build a version of {\REDUCE} suitable for compiling all packages. \paragraph{mkfasl} This creates a single fasl file from a package file. It is used in the form {\tt mkfasl <package-name> }. \paragraph{mkfasl2} This creates a single fasl file from a package file in the \$2 directory. It is normally used to make fasl files from the {\tt lib} directory, in which it is used in the form {\tt mkfasl <package-name> lib}. \paragraph{mkreduce} This has been mentioned earlier. It creates the {\REDUCE} executable from PSL sources and {\REDUCE} fasl files. \paragraph{mkslfile} This has also been mentioned earlier. It generates a Lisp equivalent of {\REDUCE} or RLISP source files. \paragraph{reduce} This is a prototypical script that can be installed, say, in /usr/local/bin, to set the environment variable {\tt reduce}, and call the {\REDUCE} executable. \paragraph{reduce-names} This file is normally used as an argument to {\tt source} to set up symbolic names for the {\REDUCE} sub-directories. It must be modified to conform to local file conventions. \paragraph{sparsify} This utility is used to remove ``dead" space from various PSL binary files that grow in size when copied. In addition to the executable, the source ({\tt sparsify.c}) and a UNIX ``man" page ({\tt sparsify.l}) are included. \paragraph{test} This can be used to run one of the test files in the {\tt xmpl} directory. {\tt test <file>} will run a test file, $<$file$>$.tst that does not require the explicit loading of a package. If a package must be loaded to run a test (e.g., algint), the name of the required package should be provided as a second argument to {\tt test}. \paragraph{test-all} This script runs all the tests contained in the xmpl directory, using the {\tt test} script on each one. This script takes about 45 minutes to run on a SPARCstation 1. \paragraph{testlib} This can be used to run the test files in the {\tt lib} directory. {\tt testlib <package>} will run the test file {\tt <package>.tst} in the {\tt lib} directory, assuming the fasl file for that package has been built. \paragraph{xbuild} This is used by {\tt build} to generate a complete set of fasl files by applying the {\tt mkfasl} script to each package. \section{Program Registration} After installing {\REDUCE}, please fill out the accompanying registration form and send to: \begin{center} Dr. Anthony C. Hearn \\ RAND \\ 1700 Main Street \\ Santa Monica, CA 90407-2138 \\ Telephone (213) 393-0411 \\ Facsimile (213) 393-4818 \\ Email: reduce@rand.org \end{center} This should be done so that you can be advised direct of any changes which are made to the system. Furthermore, the copyright statement on the {\REDUCE} documents requires such registration as a requirement for their local distribution. The test time requested on the registration form is the time printed by the final call of {\tt showtime} in the output from the test described in the section ``Testing {\REDUCE}". \section{Inquiries and Reporting of Errors} We would appreciate hearing about other bugs you encounter or questions you may have regarding the assembly or the operation of the system. Suspected errors should be accompanied by the relevant job output and a copy of the input source. Corrections for documented problems or other improvements to the system are also welcomed. \newpage \pagestyle{empty} \begin{center} {\Large\bf REDUCE 3.4 Registration Form} \end{center} After installing {\REDUCE}, please fill out this form and send to the listed address. This should be done so that you can be advised direct of any changes made to the system. Furthermore, returning the registration form is a requirement for local reproduction of the {\REDUCE} documentation. \vspace*{3mm} \\ Date: \hrulefill \vspace*{3mm}\\ Contact Person: \hrulefill\ \vspace*{3mm}\\ Organization: \hrulefill \vspace*{3mm} \\ Address: \hrulefill \vspace*{3mm} \\ \hspace*{16 mm} \hrulefill \vspace*{3mm} \\ \hspace*{16 mm} \hrulefill \vspace*{3mm} \\ Telephone: \hrulefill\ \vspace*{3mm} \\ Network Address: \hrulefill \\ {\small (Indicate network: Internet, BITNET, EARN, UUCP, etc)} \vspace*{3 mm} \\ REDUCE Supplier: \hrulefill \\[3mm] Computer Description: \vspace*{3 mm} \\ Vendor: \hrulefill \vspace*{2mm} Model: \hrulefill \vspace*{2mm} Operating System: \hrulefill \\ Please indicate the test time as printed by the final call of {\tt showtime} in the output from the installation test described in the section ``Testing {\REDUCE}" of the {\REDUCE} Installation Guide. Also give the total system time, region (virtual) and real system memory available, if applicable. \vspace*{4mm} \\ Time: \hrulefill Total System Time: \hrulefill\ Region: \hrulefill \vspace*{4mm} \\ Real System Memory: \hrulefill .\hspace*{5cm} \vspace*{3 mm} \\ Please also write on the back of this form any comments you may have about the installation procedure, and system documentation and performance. \\[3mm] \noindent If you would like to be listed in a published registry of {\REDUCE} system holders, please check here $\Box$ . \end{document} |
Added r34.1/doc/limits.tex version [6dec75d187].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{A REDUCE Limits Package} \date{} \author{Stanley L. Kameny \\ Email: stan\%valley.uucp@rand.org} \begin{document} \maketitle \index{LIMITS package} LIMITS is a fast limit package for REDUCE for functions which are continuous except for computable poles and singularities, based on some earlier work by Ian Cohen and John P. Fitch. The Truncated Power Series package is used for non-critical points, at which the value of the function is the constant term in the expansion around that point. \index{l'H\^{o}pital's rule} l'H\^{o}pital's rule is used in critical cases, with preprocessing of $\infty - \infty$ forms and reformatting of product forms in order to apply l'H\^{o}pital's rule. A limited amount of bounded arithmetic is also employed where applicable. \section{Normal entry points} \ttindex{LIMIT} \vspace{.1in} \noindent {\tt LIMIT}(EXPRN:{\em algebraic}, VAR:{\em kernel}, LIMPOINT:{\em algebraic}):{\em algebraic} \vspace{.1in} This is the standard way of calling limit, applying all of the methods. The result is the limit of EXPRN as VAR approaches LIMPOINT. \section{Direction-dependent limits} \ttindex{LIMIT+} \ttindex{LIMIT-} \vspace{.1in} \noindent {\tt LIMIT!+}(EXPRN:{\em algebraic}, VAR:{\em kernel}, LIMPOINT:{\em algebraic}):{\em algebraic} \\ \noindent {\tt LIMIT!-}(EXPRN:{\em algebraic}, VAR:{\em kernel}, LIMPOINT:{\em algebraic}):{\em algebraic} \vspace{.1in} If the limit depends upon the direction of approach to the {\tt LIMPOINT}, the functions {\tt LIMIT!+} and {\tt LIMIT!-} may be used. They are defined by: \vspace{.1in} \noindent{\tt LIMIT!+ (LIMIT!-)} (EXP,VAR,LIMPOINT) $\rightarrow$ \\ \hspace*{2em}{\tt LIMIT}(EXP*,$\epsilon$,0) EXP*=sub(VAR=VAR+(-)$\epsilon^2$,EXP) \section{Diagnostic Functions} \ttindex{LIMIT0} \vspace{.1in} \noindent {\tt LIMIT0}(EXPRN:{\em algebraic}, VAR:{\em kernel}, LIMPOINT:{\em algebraic}):{\em algebraic} \vspace{.1in} This function will use all parts of the limits package, but it does not combine log terms before taking limits, so it may fail if there is a sum of log terms which have a removable singularity in some of the terms. \ttindex{LIMIT1} \vspace{.1in} \noindent {\tt LIMIT1}(EXPRN:{\em algebraic}, VAR:{\em kernel}, LIMPOINT:{\em algebraic}):{\em algebraic} \vspace{.1in} \index{TPS package} This function uses the TPS branch only, and will fail if the limit point is singular. \ttindex{LIMIT2} \vspace{.1in} \begin{tabbing} {\tt LIMIT2}(\=TOP:{\em algebraic}, \\ \>BOT:{\em algebraic}, \\ \>VAR:{\em kernel}, \\ \>LIMPOINT:{\em algebraic}):{\em algebraic} \end{tabbing} \vspace{.1in} This function applies l'H\^{o}pital's rule to the quotient (TOP/BOT). \end{document} |
Added r34.1/doc/odesolve.tex version [2e6aef1b7f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \date{} \title{ODESOLVE} \author{Malcolm A.H. MacCallum \\ Queen Mary and Westfield College, London \\ Email: mm@maths.qmw.ac.uk \\[0.1in] Other contributors: Francis Wright, Alan Barnes} \begin{document} \maketitle \index{ODESOLVE package} \index{ordinary differential equations} The ODESOLVE package is a solver for ordinary differential equations. At the present time it has very limited capabilities, \begin{enumerate} \item it can handle only a single scalar equation presented as an algebraic expression or equation, and \item it can solve only first-order equations of simple types, linear equations with constant coefficients and Euler equations. \end{enumerate} \noindent These solvable types are exactly those for which Lie symmetry techniques give no useful information. \section{Use} The only top-level function the user should normally invoke is: \ttindex{ODESOLVE} \vspace{.1in} \begin{tabbing} {\tt ODESOLVE}(\=EXPRN:{\em expression, equation}, \\ \>VAR1:{\em variable}, \\ \>VAR2:{\em variable}):{\em list-algebraic} \end{tabbing} \vspace{.1in} \noindent {\tt ODESOLVE} returns a list containing an equation (like solve): \begin{description} \item[EXPRN] is a single scalar expression such that EXPRN = 0 is the ordinary differential equation (ODE for short) to be solved, or is an equivalent equation. \item[VAR1] is the name of the dependent variable. \item[VAR2] is the name of the independent variable \end{description} \noindent (For simplicity these will be called y and x in the sequel) The returned value is a list containing the equation giving the general solution of the ODE (for simultaneous equations this will be a list of equations eventually). It will contain occurrences of the \index{ARBCONST operator} operator {\tt ARBCONST} for the arbitrary constants in the general solution. The arguments of {\tt ARBCONST} should be new, as with {\tt ARBINT} etc. in SOLVE. A counter {\tt !!ARBCONST} is used to arrange this (similar to the way {\tt ARBINT} is implemented). Some other top-level functions may be of use elsewhere, especially: \ttindex{SORTOUTODE} \vspace{.1in} \noindent{\tt SORTOUTODE}(EXPRN:{\em algebraic}, Y:{\em var}, X:{\em var}): {\em expression} \vspace{.1in} \noindent which finds the order and degree of the EXPRN as a differential equation for Y with respect to Y and sets the linearity and highest derivative occurring in reserved variables ODEORDER, ODEDEGREE, \ttindex{ODEORDER} \ttindex{ODEDEGREE} \ttindex{ODELINEARITY} \ttindex{HIGHESTDERIV} ODELINEARITY and HIGHESTDERIV. An expression equivalent to the ODE is returned, or zero if EXPRN (equated to 0) is not an ODE in the given vars. Only in the version using variation of parameters: \ttindex{CORFACTOR} \vspace{.1in} \begin{tabbing} {\tt COFACTOR}(\=ROW:{\em integer}, \\ \>COLUMN:{\em integer}, \\ \>MATRIX:{\em matrix}):{\em algebraic} \end{tabbing} \vspace{.1in} \noindent The cofactor of the element in row ROW and column COLUMN of matrix MATRIX is returned. Errors occur if ROW or COLUMN do not simplify to integer expressions or if MATRIX is not square. \section{Tracing} Some rudimentary tracing is provided and is activated by the switch TRODE \index{tracing ! ODESOLVE} \ttindex{TRODE} (analogous to TRFAC and TRINT) \section{Comments} The intention in the long run is to develop a rather general and powerful ordinary differential equation solver incorporating the methods detailed below. At present the program has not been optimized for efficiency and much work remains to be done to convert algebraic mode procedures to more efficient symbolic mode replacements. No attempt is made to extend the REDUCE integrator, although this is in some sense a problem of ODEs. Thus the equation $\frac{dy}{dx} = g(x)$ will be solved if and only if $\int g(x) dx$ succeeds. The available and planned coverage is as follows: \begin{itemize} \item First-order equations: (first degree unless otherwise stated) \begin{itemize} \item Quadrature of $\frac{df}{dx} = g(x)$ \item Linear equations \item Separable equations \item (Algebraically) homogeneous equations \item Equations reducible to the previous case by linear transformations \item Exact equations \item Bernoulli equations \end{itemize} The above are already implemented. Further 1st order cases are not: \begin{itemize} \item Riccati equations using Schmidt's methods and other special cases \item Hypotheses on the integrating factor following Char (SYMSAC 81) or Shtokhamer, Glinos and Caviness. \item Higher degree cases \end{itemize} \item Linear equations of higher order \begin{itemize} \item Constant coefficients case for driving terms solvable by variation of parameters using the integrator (Choice of method is discussed in the source of module lccode). \end{itemize} The above is already implemented. Further higher order methods are not: \begin{itemize} \item More complex driving terms via Laplace transforms (?) \item Variable coefficients: Watanabe (EUROSAM 84) methods including Kovacic's algorithm as extended by Singer \item Factorization of operators as in Schwarz's ISSAC-89 paper or Berkovich's 1990 book \item Other methods based on Galois theory (see Ulmer's preprints from Karlsruhe, 1989, 1990 and Singer's 1989 review) or other ways of hunting Liouvillian solutions (see Singer's review in J. Symb. Comp., 1990). \end{itemize} \item Non-linear equations of order 2 and higher \begin{itemize} \item Lie algebra of point symmetries e.g. using Wolf's CRACK now available in REDUCE \item Other special ansatze (see Wolf. op. cit), in particular contact transformations for 2nd order cases \end{itemize} \item Possibly (?) exploitation of Cartan's methods for equivalence of differential equations. \end{itemize} \end{document} |
Added r34.1/doc/oper.tex version [4b082b74e9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \hoffset -.5cm \documentstyle[11pt]{report} \parindent 0pt \parskip 6pt \pagestyle{empty} \setlength{\topsep}{0.5\baselineskip} % above and below environments \setlength{\itemsep}{\topsep} \setlength{\abovedisplayskip}{\topsep} % for "long" equations \setlength{\belowdisplayskip}{\topsep} \renewcommand{\arraystretch}{1.3} \renewcommand{\thechapter}{\arabic{chapter}} \renewcommand{\thesection}{\arabic{section}.} \renewcommand{\thesubsection}{\arabic{subsection}.} \newcommand{\REDUCE}{REDUCE} % The following are version dependent. \newcommand{\system}{Sun Microsystems SPARC systems and Sun 4} \newcommand{\programsize}{2.5} % megabytes \newcommand{\virtualsize}{128} % megabytes \newcommand{\timingmachine}{Sun 4/260} \newcommand{\machinefactors}{SparcStation 1+&0.9 \\ SparcStation 2 &0.7 \\ SparcServer &0.9 \\ Sun 4/110 &1.1 \\ Sun 4/65 &1.0} \newcommand{\cartridgecommand}{tar xbf 126 /dev/rst0} \newcommand{\tapespace}{8.8} % megabytes \newcommand{\createtime}{11} % seconds \newcommand{\executablespace}{2.5} % megabytes \newcommand{\testtime}{5.5} % seconds \newcommand{\floatingpointdigits}{12} \begin{document} \vspace*{1cm} \begin{center} {\LARGE {\bf REDUCE} User's Guide for the } \vspace*{2mm} \\ {\LARGE {\system} Workstations} \\ \vspace*{.5cm} {\LARGE Version 3.4} \\[0.3cm] {\large by} \\[0.3cm] {\Large Anthony C. Hearn}\\ {\large RAND} \\ {\large Santa Monica, CA 90407-2138 USA} \\[0.3cm] {\large and} \\[0.3cm] {\Large Winfried Neun}\\ {\large ZIB} \\ {\large 1000 Berlin 31, FRG} \\[0.3cm] {\large July 1991}\\[0.5cm] \vfill {\bf Abstract} \end{center} This document describes operating procedures for running {\REDUCE} specific to the {\system} workstations. \begin{center} {ZIB Publication M 2.010.04} \\ \vspace*{1cm} Copyright \copyright 1991 by RAND and ZIB. All rights reserved. \end{center} Registered system holders may reproduce all or any part of this publication for internal purposes, provided that the source of the material is clearly acknowledged, and the copyright notice is retained. \newpage \tableofcontents \thispagestyle{empty} \newpage \setcounter{page}{1} \pagestyle{plain} \section{Preliminary} This document describes operating procedures for running {\REDUCE} specific to the {\system} workstations. It supplements the {\REDUCE} User's Manual, describing features, extensions and limitations specific to this implementation of {\REDUCE}. This manual assumes that {\tt csh} is used as the command shell. If a different shell is used, please change commands or filenames accordingly. The files that form the {\REDUCE} system are stored under the {\REDUCE} root directory, identified here as ``\$reduce''. To execute {\REDUCE} first check that the {\REDUCE} binary directory, identified here as {\tt reduce.bindir} is included in your search path. If not, the path definition in your .login or .cshrc file should be modified accordingly, e.g.: \begin{verbatim} set path=( <reduce.bindir> $path) \end{verbatim} Alternatively, for calling {\REDUCE} without a search path reference, you can put an entry in the .login or .cshrc file to define an alias for calling {\REDUCE} directly, e.g.: \begin{verbatim} alias reduce <reduce.bindir>/reduce \end{verbatim} In order to access the {\REDUCE} directories most easily, you should also include the statement (csh dependent) \begin{verbatim} setenv reduce <REDUCE root directory> \end{verbatim} Directories of interest to the general user include \$reduce/doc, containing relevant documents and \$reduce/xmpl, containing various examples of the use of {\REDUCE}. The more serious user may also be interested in the {\REDUCE} sources stored in the directory \$reduce/src. \\ To run {\REDUCE}, you enter (in lower case only) \begin{verbatim} reduce \end{verbatim} or, if you like a simple protocol of your session written into a file, \begin{verbatim} reduce | tee <file> \end{verbatim} after which {\REDUCE} will respond with a banner line and then prompt for the first line of input: \begin{verbatim} REDUCE 3.4, 15-Jul-91 ... 1: \end{verbatim} You can now begin entering commands. Alternatively you can enter the full pathname: \begin{verbatim} <reduce.bindir>/reduce \end{verbatim} \section{{\REDUCE} Documentation} {\REDUCE} documents are kept in the directory \$reduce/doc . These include descriptions of all user contributed packages and the following: \begin{center} \begin{tabular}{rl} reduce.tex & {\REDUCE} User's Manual in \LaTeX\ format \\ install.tex & Installation instructions in \LaTeX\ format \\ oper.tex & System specific operation notes in \LaTeX\ format \\ sl.doc & Standard LISP Report in plain text format. % bugs33.doc & Known bugs and problems in REDUCE 3.3. \end{tabular} \end{center} \section{An Introduction to {\REDUCE}} New users of {\REDUCE} are advised to process the seven {\REDUCE} Lessons, which are available as \$reduce/xmpl/less$\langle$i$\rangle$. For example, to run Lesson 1, you would say: \begin{verbatim} in "$reduce/xmpl/less1"; \end{verbatim} A number of example files are also contained in the \$reduce/xmpl directory. These show how many of the facilities available in {\REDUCE} are used. \section{Resource Requirement} The distributed version of {\REDUCE} requires approximately {\executablespace} megabytes for storage of the executable binary file. At run time, it takes its default execution size from the underlying PSL system. This size can be changed with the \verb|set_heap_size| command (see chapter 7). This implementation will allocate up to {\virtualsize} megabytes dynamically, if the operating system supplies a sufficiently large swap space on disks. \section{File Handling} The file names that appear in {\tt in}, {\tt out} and {\tt shut} statements follow normal UNIX conventions. If the name contains uppercase or special characters (e.g., \verb| $ ~ . /|) it must be enclosed in double quotes (``FileName"). Whereas, if an identifier is used as a filename all characters are interpreted as lower case. Filenames containing patterns \verb| ~user, ~/ or $var| are expanded , whereas patterns including \verb| * , ? , {...} or [...]| are not expanded. If you execute the statement (csh dependent) \begin{verbatim} source $reduce/util/reduce-names \end{verbatim} (preferably in your .login or .cshrc file), {\REDUCE} sub-directories such as \$reduce/xmpl can then be referenced using symbolic names. These are formed by prefixing \$r to the sub-directory names. Thus less1 can also be input by the statement \begin{verbatim} in "$rxmpl/less1"; \end{verbatim} \section{Internal Parameters} \subsection{Object Sizes} The maximum string and identifier lengths are limited only by the underlying PSL base. The current implementation allows several thousand characters in both identifiers and strings. However, we recommend that such names be limited to 24 characters or less for compatibility with other versions of {\REDUCE}. In the default precision, floating point numbers are printed in fixed-point notation rounded to {\floatingpointdigits} digits. Arbitrary precision integer and real arithmetic are supported. \subsection{Special Characters and Interrupts} Lower case input is permitted, but converted to upper case unless the switch {\tt raise} is off. The end-of-file character is $\langle$control$\rangle$D. A terminal interrupt (often $\langle$del$\rangle$ or $\langle$control$\rangle$C) causes the current calculation to halt. The user is then prompted whether to continue the evaluation. If not, {\REDUCE} prompts for the next command. In some cases the continuation prompt may be omitted and {\REDUCE} immediately prompts for the next command. $\langle$escape$\rangle$ is used to terminate strings in the {\REDUCE} interactive editor. \subsection{Miscellaneous} There is no link currently to an external editor. The internal ordering on alphabetic characters is from A through Z followed by a through z. Times (as reported by {\tt on time; } or {\tt showtime;}) are given in milliseconds, and measure execution time and garbage collection time separately. They do not include operating system overhead (e.g., swapping time). To exit {\REDUCE} use {\tt bye;} . Alternatively, if you want to continue the {\REDUCE} session later use {\tt <control>Z}. To restart, one says {\tt fg}, or another valid UNIX command for this purpose. Use the UNIX {\tt kill} command to remove the job. \section{Customizing the {\REDUCE} Environment} \subsection{Size of Working Space} Depending on the complexity of your application, the amount of storage used by {\REDUCE} for storing and manipulating your data will vary considerably. You may get an idea of the storage requirements however by turning on the switch {\tt gc}: \begin{verbatim} on gc; \end{verbatim} You will then get messages like: \begin{verbatim} *** Garbage collection starting *** GC 2: 15-Jul-91 16:12:53 (~ 1836 ms cpu time, gc : 28 %) *** time 289 ms, 50167 occupied, 51876 recovered, 949833 free \end{verbatim} at various points in your calculation. From these statistics you can see the amount of storage used, the free memory, and the percentage of cpu time spent on memory management (garbage collection). If the percentage is high, more than 20\% say, it is recommended that you increase memory size. This can be done by the command: \begin{verbatim} set_heap_size nnnnnnn; \end{verbatim} where nnnnnnn is the size in machine words of the dynamic storage. The default will be (in most cases) 1000000 words. The present memory size is returned by: \begin{verbatim} set_heap_size nil; \end{verbatim} \subsection{Initial Commands} When {\REDUCE} is initialized, a .reducerc file, if present, will be read from the user's home directory. This file can contain any {\REDUCE} or PSL commands needed for customizing the {\REDUCE} environment. Typically these are load commands to load specific user modules or the inclusion of local user directories through the LOADDIRECTORIES facilities. See the PSL manual for more information on this feature. The commands in the .reducerc file must be in Standard Lisp syntax. To display {\REDUCE} commands in Standard Lisp syntax, the {\REDUCE} {\tt on defn} feature can be used. The script \$reduce/util/mkslfile is available for converting an entire file to Standard Lisp syntax. For further details, the Standard Lisp Report should be consulted. \section{Communicating with UNIX} There are two different ways for a {\REDUCE} user to communicate with the UNIX operating system: It is possible to issue a UNIX command and return to {\REDUCE} at its completion by means of the command {\tt system}. Alternatively, some UNIX functions are built into the REDUCE executable directly such that the user can influence the present task and interpret the system's return value. The argument to {\tt system} is a string which is then passed as a UNIX command to your default shell. For example, \begin{verbatim} system "vi foo/bah"; \end{verbatim} will edit the file foo/bah using the "vi" editor, and \begin{verbatim} system "lpr foo/bah"; \end{verbatim} will print the same file. If you want to change for example your current working directory the command: \begin{verbatim} system "cd /tmp"; \end{verbatim} is not of much use, since the {\tt cd} command is run in a UNIX child's environment and not in the Reduce task environment. In this case the command \begin{verbatim} cd "/tmp"; \end{verbatim} will produce the desired effect. More internally available functions are provided, including {\tt pwd}, {\tt getenv} and {\tt setenv}. The latter work as described in the UNIX ``man" pages, i.e., they expect parameters as strings, e.g. \begin{center} \begin{tabular}{l@{\rm\quad returns }l} \tt pwd(); & \tt "/tmp/" \\ \tt setenv ("hugo","otto"); & \tt NIL \rm and then \\ \tt getenv "hugo"; & \tt "otto" \end{tabular} \end{center} \section{Implementation Dependent Error Messages} A number of error messages from the underlying PSL system may be seen from time to time. These include: \paragraph{Floating point exception.} Probably means a division by zero has been attempted or a floating-point overflow has happend. \paragraph{Heap space exhausted.} Your problem is too large in its present form for the available workspace; either change your problem formulation or ask your site consultant to build a bigger system for you. \paragraph{Non-numeric argument in arithmetic.} This means that a Lisp arithmetic routine has been called with an invalid argument. \paragraph{Segmentation violation.} This indicates an illegal memory reference. It can arise from applying the Lisp function {\tt car} to an atom in compiled code. \paragraph{Bus error.} This indicates an illegal memory reference. It can arise from applying the Lisp function {\tt car} to an atom in compiled code. \paragraph{Binding stack overflow, restarting...} This can arise from the evaluation of very complicated expressions. You can increase the binding stack by the \verb|set_bndstk_size| command. For example, to set this to 100000, use: \begin{verbatim} set_bndstk_size 100000; \end{verbatim} \section{Further Help} For further help with {\REDUCE}, please contact: \begin{center} $\langle$list your site consultant here$\rangle$ \end{center} \end{document} |
Added r34.1/doc/orthovec.bib version [0560bdcb53].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | @ARTICLE{Eastwood:87, AUTHOR = "James W. Eastwood", TITLE = "Orthovec: A {REDUCE} Program for {3-D} Vector Analysis in Orthogonal Curvilinear Coordinates", JOURNAL = "Comp. Phys. Commun.", YEAR = 1987, VOLUME = 47, NUMBER = 1, PAGES = "139-147", MONTH = "October"} @ARTICLE{Eastwood:91, AUTHOR = "James W. Eastwood", TITLE = "{ORTHOVEC:} version 2 of the {REDUCE} program for {3-D} vector analysis in orthogonal curvilinear coordinates", JOURNAL = "Comp. Phys. Commun.", YEAR = 1991, VOLUME = 64, NUMBER = 1, PAGES = "121-122", MONTH = "April"} @BOOK{Speigel:59, AUTHOR = "M . Speigel", TITLE = "Vector Analysis", PUBLISHER = "Scheum Publishing Co.", YEAR = 1959} |
Added r34.1/doc/orthovec.tex version [e04d92936c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{ORTHOVEC: Version 2 of the REDUCE program for 3-D vector analysis in orthogonal curvilinear coordinates} \date{} \author{James W.~Eastwood \\ AEA Technology \\ Culham Laboratory \\ Abingdon \\ Oxon OX14 3DB \\[0.1in] Email: eastwood\#jim\%nersc.mfenet@ccc.nersc.gov \\[0.1in] June 1990} \begin{document} \maketitle \index{ORTHOVEC package} The revised version of ORTHOVEC is a collection of REDUCE 3.4 procedures and operations which provide a simple to use environment for the manipulation of scalars and vectors. Operations include addition, subtraction, dot and cross products, division, modulus, div, grad, curl, laplacian, differentiation, integration, ${\bf a \cdot \nabla}$ and Taylor expansion. Version 2 is summarized in \cite{Eastwood:91}. It differs from the original (\cite {Eastwood:87}) in revised notation and extended capabilities. %\begin{center} %{\Large{\bf New Version Summary}} %\end{center} %\begin{tabular}{ll} %\underline{Title of program}:&ORTHOVEC\\[2ex] %\underline{Catalogue number}:&AAXY\\[2ex] %\underline{Program obtainable from}: &CPC Program Library,\\ %&Queen's University of Belfast, N.~Ireland\\[2ex] %\underline{Reference to original program}: &CPC 47 (1987) 139-147\\[2ex] %\underline{Operating system}:&UNIX, MS-DOS + ARM-OS\\[2ex] %\underline{Programming Language used}: &REDUCE 3.4\\[2ex] %\underline{High speed storage required}: &As for %the underlying PSL/REDUCE \\ %&system, typically $>$ 1 Megabyte\\[2ex] %\underline{No. of lines in combined programs and test deck}:&600 \\[2ex] %\underline{Keywords}: & Computer Algebra, Vector Analysis,\\ %& series Expansion, Plasma Physics, \\ %&Hydrodynamics, Electromagnetics.\\[2ex] %\underline{Author of original program}: &James W. EASTWOOD\\[2ex] %\underline{Nature of Physical Problem}: %&There is a wide range using vector\\ %& calculus in orthogonal curvilinear coordinates\\ %& and vector integration, differentiation\\ %& and series expansion.\\[2ex] %\underline{Method of Solution}: & computer aided algebra using\\ %&standard orthogonal curvilinear coordinates\\ %&for differential and integral operators.\\[2ex] %\underline{Typical running time}: %& This is strongly problem dependent:\\ %&the test examples given took respectively\\ %& 10,19 and 48 seconds on a SUN 4/310,\\ %&SUN 4/110 and ACORN Springboard. \\[2ex] %\underline{Unusual Features of the Program}: %&The REDUCE procedures use\\ %&LISP vectors \cite{r2} %to provide a compact\\ %&mathematical notation similar\\ %& to that normally found in vector\\ %& analysis textbooks.\\ %\end{tabular} \section{Introduction} The revised version of ORTHOVEC\cite{Eastwood:91} is, like the original\cite{Eastwood:87}, a collection of REDUCE procedures and operators designed to simplify the machine aided manipulation of vectors and vector expansions frequently met in many areas of applied mathematics. The revisions have been introduced for two reasons: firstly, to add extra capabilities missing from the original and secondly, to tidy up input and output to make the package easier to use. \newpage The changes from Version 1 include: \begin{enumerate} \item merging of scalar and vector unary and binary operators, $+, - , *, / $ \item extensions of the definitions of division and exponentiation to vectors \item new vector dependency procedures \item application of L'H\^opital's rule in limits and Taylor expansions \item a new component selector operator \item algebraic mode output of LISP vector components \end{enumerate} The LISP vector primitives are again used to store vectors, although with the introduction of LIST types in algebraic mode in REDUCE 3.4, the implementation may have been more simply achieved using lists to store vector components. The philosophy used in Version 2 follows that used in the original: namely, algebraic mode is used wherever possible. The view is taken that some computational inefficiencies are acceptable if it allows coding to be intelligible to (and thence adaptable by) users other than LISP experts familiar with the internal workings of REDUCE. Procedures and operators in ORTHOVEC fall into the five classes: initialisation, input-output, algebraic operations, differential operations and integral operations. Definitions are given in the following sections, and a summary of the procedure names and their meanings are give in Table 1. The final section discusses test examples. \section{Initialisation}\label{vstart} \ttindex{VSTART} The procedure VSTART initialises ORTHOVEC. It may be called after ORTHOVEC has been INputted (or LOADed if a fast load version has been made) to reset coordinates. VSTART provides a menu of standard coordinate systems:- \begin{enumerate} \index{cartesian coordinates} \item cartesian $(x, y, z) = $ {\tt (x, y, z)} \index{cylindrical coordinates} \item cylindrical $(r, \theta, z) = $ {\tt (r, th, z)} \index{spherical coordinates} \item spherical $(r, \theta, \phi) = $ {\tt (r, th, ph) } \item general $( u_1, u_2, u_3 ) = $ {\tt (u1, u2, u3) } \item others \end{enumerate} which the user selects by number. Selecting options (1)-(4) automatically sets up the coordinates and scale factors. Selection option (5) shows the user how to select another coordinate system. If VSTART is not called, then the default cartesian coordinates are used. ORTHOVEC may be re-initialised to a new coordinate system at any time during a given REDUCE session by typing \begin{verbatim} VSTART $. \end{verbatim} \section{Input-Output} ORTHOVEC assumes all quantities are either scalars or 3 component vectors. To define a vector $a$ with components $(c_1, c_2, c_3)$ use the procedure SVEC as follows \ttindex{SVEC} \begin{verbatim} a := svec(c1, c2, c3); \end{verbatim} The standard REDUCE output for vectors when using the terminator ``$;$'' is to list the three components inside square brackets $[\cdots]$, with each component in prefix form. A replacement for the standard REDUCE procedure MAPRIN is included in the package to change the output of LISP vector components to algebraic notation. The procedure \ttindex{VOUT} VOUT (which returns the value of its argument) can be used to give labelled output of components in algebraic form: e.g., \begin{verbatim} b := svec (sin(x)**2, y**2, z)$ vout(b)$ \end{verbatim} The operator {\tt \_} can be used to select a particular component (1, 2 or 3) for output e.g. \begin{verbatim} b_1 ; \end{verbatim} \section{Algebraic Operations} Six infix operators, sum, difference, quotient, times, exponentiation and cross product, and four prefix operators, plus, minus, reciprocal and modulus are defined in ORTHOVEC. These operators can take suitable combinations of scalar and vector arguments, and in the case of scalar arguments reduce to the usual definitions of $ +, -, *, /, $ etc. The operators are represented by symbols \index{+ ! 3-D vector} \index{- ! 3-D vector} \index{/ ! 3-D vector} \index{* ! 3-D vector} \index{* ! 3-D vector} \index{"\^{} ! 3-D vector} \index{$><$ ! 3-D vector} \begin{verbatim} +, -, /, *, ^, >< \end{verbatim} \index{$><$ ! diphthong} The composite {\tt ><} is an attempt to represent the cross product symbol $\times$ in ASCII characters. If we let ${\bf v}$ be a vector and $s$ be a scalar, then valid combinations of arguments of the procedures and operators and the type of the result are as summarised below. The notation used is\\ {\em result :=procedure(left argument, right argument) } or\\ {\em result :=(left operand) operator (right operand) } . \\ \newpage \underline{Vector Addition} \\ \ttindex{VECTORPLUS} \ttindex{VECTORADD} \index{vector ! addition} \begin{tabular}{rclcrcl} {\bf v} &:=& VECTORPLUS({\bf v}) &{\rm or}& {\bf v} &:=& + {\bf v} \\ s &:=& VECTORPLUS(s) &{\rm or} & s &:=& + s \\ {\bf v} &:=& VECTORADD({\bf v},{\bf v}) &{\rm or }& {\bf v} &:=& {\bf v} + {\bf v} \\ s &:=& VECTORADD(s,s) &{\rm or }& s &:=& s + s \\ \end{tabular} \\ \underline{Vector Subtraction} \\ \ttindex{VECTORMINUS} \ttindex{VECTORDIFFERENCE} \index{vector ! subtraction} \begin{tabular}{rclcrcl} {\bf v} &:=& VECTORMINUS({\bf v}) &{\rm or}& {\bf v} &:=& + {\bf v} \\ s &:=& VECTORMINUS(s) &{\rm or} & s &:=& + s \\ {\bf v} &:=& VECTORDIFFERENCE({\bf v},{\bf v}) &{\rm or }& {\bf v} &:=& {\bf v} + {\bf v} \\ s &:=& VECTORDIFFERENCE(s,s) &{\rm or }& s &:=& s + s \\ \end{tabular} \\ \underline{Vector Division}\\ \ttindex{VECTORRECIP} \ttindex{VECTORQUOTIENT} \index{vector ! division} \begin{tabular}{rclcrcl} {\bf v} &:=& VECTORRECIP({\bf v}) &{\rm or}& {\bf v} &:=& / {\bf v} \\ s &:=& VECTORRECIP(s) &{\rm or} & s &:=& / s \\ {\bf v} &:=& VECTORQUOTIENT({\bf v},{\bf v}) &{\rm or }& {\bf v} &:=& {\bf v} / {\bf v} \\ {\bf v} &:=& VECTORQUOTIENT({\bf v}, s ) &{\rm or }& {\bf v} &:=& {\bf v} / s \\ {\bf v} &:=& VECTORQUOTIENT( s ,{\bf v}) &{\rm or }& {\bf v} &:=& s / {\bf v} \\ s &:=& VECTORQUOTIENT(s,s) &{\rm or }& s &:=& s / s \\ \end{tabular} \\ \underline{Vector Multiplication}\\ \ttindex{VECTORTIMES} \index{vector ! multiplication} \begin{tabular}{rclcrcl} {\bf v} &:=& VECTORTIMES( s ,{\bf v}) &{\rm or }& {\bf v} &:=& s * {\bf v} \\ {\bf v} &:=& VECTORTIMES({\bf v}, s ) &{\rm or }& {\bf v} &:=& {\bf v} * s \\ s &:=& VECTORTIMES({\bf v},{\bf v}) &{\rm or }& s &:=& {\bf v} * {\bf v} \\ s &:=& VECTORTIMES( s , s ) &{\rm or }& s &:=& s * s \\ \end{tabular} \\ \underline{Vector Cross Product} \\ \ttindex{VECTORCROSS} \index{cross product} \index{vector ! cross product} \begin{tabular}{rclcrcl} {\bf v} &:=& VECTORCROSS({\bf v},{\bf v}) &{\rm or }& {\bf v} &:=& {\bf v} $\times$ {\bf v} \\ \end{tabular} \\ \underline{Vector Exponentiation}\\ \ttindex{VECTOREXPT} \index{vector ! exponentiation} \begin{tabular}{rclcrcl} s &:=& VECTOREXPT ({\bf v}, s ) &{\rm or }& s &:=& {\bf v} \^{} s \\ s &:=& VECTOREXPT ( s , s ) &{\rm or }& s &:=& s \^{} s \\ \end{tabular} \\ \underline{Vector Modulus}\\ \ttindex{VMOD} \index{vector ! modulus} \begin{tabular}{rcl} s &:=& VMOD (s)\\ s &:=& VMOD ({\bf v}) \\ \end{tabular} \\ All other combinations of operands for these operators lead to error messages being issued. The first two instances of vector multiplication are scalar multiplication of vectors, the third is the \index{vector ! dot product} \index{vector ! inner product} \index{inner product} \index{dot product} product of two scalars and the last is the inner (dot) product. The prefix operators {\tt +, -, /} can take either scalar or vector arguments and return results of the same type as their arguments. VMOD returns a scalar. In compound expressions, parenthesis may be used to specify the order of combination. If parentheses are omitted the ordering of the operators, in increasing order of precedence is \begin{verbatim} + | - | dotgrad | * | >< | ^ | _ \end{verbatim} and these are placed in the precedence list defined in REDUCE after $<$. The differential operator DOTGRAD is defined in the \index{DOTGRAD operator} following section, and the component selector {\tt \_} was introduced in section 3. Vector divisions are defined as follows: If ${\bf a}$ and ${\bf b}$ are vectors and $c$ is a scalar, then \begin{eqnarray*} {\bf a} / {\bf b} & = & \frac{{\bf a} \cdot {\bf b}}{ \mid {\bf b} \mid^2}\\ c / {\bf a} & = & \frac{c {\bf a} }{ \mid {\bf a} \mid^2} \end{eqnarray*} Both scalar multiplication and dot products are given by the same symbol, braces are advisable to ensure the correct precedences in expressions such as $({\bf a} \cdot {\bf b}) ({\bf c} \cdot {\bf d})$. Vector exponentiation is defined as the power of the modulus:\\ ${\bf a}^n \equiv {\rm VMOD}(a)^n = \mid {\bf a} \mid^n$ \section{Differential Operations} Differential operators provided are div, grad, curl, delsq, and dotgrad. \index{div operator} \index{grad operator} \index{curl operator} \index{delsq operator} \index{dotgrad operator} All but the last of these are prefix operators having a single vector or scalar argument as appropriate. Valid combinations of operator and argument, and the type of the result are shown in table~\ref{vvecttable}. \begin{table} \begin{center} \begin{tabular}{rcl} s & := & div ({\bf v}) \\ {\bf v} & := & grad(s) \\ {\bf v} & := & curl({\bf v}) \\ {\bf v} & := & delsq({\bf v}) \\ s & := & delsq(s) \\ {\bf v} & := & {\bf v} dotgrad {\bf v} \\ s & := & {\bf v} dotgrad s \end{tabular} \end{center} \caption{ORTHOVEC valid combinations of operator and argument}\label{vvecttable} \end{table} All other combinations of operator and argument type cause error messages to be issued. The differential operators have their usual meanings~\cite{Speigel:59}. The coordinate system used by these operators is set by invoking VSTART (cf. Sec.~\ref{vstart}). The names {\tt h1}, {\tt h2} and {\tt h3 } are reserved for the scale factors, and {\tt u1}, {\tt u2} and {\tt u3} are used for the coordinates. A vector extension, VDF, of the REDUCE procedure DF allows the differentiation of a vector (scalar) with respect to a scalar to be performed. Allowed forms are \ttindex{VDF} VDF({\bf v}, s) $\rightarrow$ {\bf v} and VDF(s, s) $\rightarrow$ s , where, for example\\ \begin{eqnarray*} {\tt vdf( B,x)} \equiv \frac{\partial {\bf B}}{\partial x} \end{eqnarray*} The standard REDUCE procedures DEPEND and NODEPEND have been redefined to allow dependences of vectors to be compactly defined. For example \index{DEPEND statement} \index{NODEPEND statement} \begin{verbatim} a := svec(a1,a2,a3)$; depend a,x,y; \end{verbatim} causes all three components {\tt a1},{\tt a2} and {\tt a3} of {\tt a} to be treated as functions of {\tt x} and {\tt y}. Individual component dependences can still be defined if desired. \begin{verbatim} depend a3,z; \end{verbatim} The procedure VTAYLOR gives truncated Taylor series expansions of scalar or vector functions:- \ttindex{VTAYLOR} \begin{verbatim} vtaylor(vex,vx,vpt,vorder); \end{verbatim} returns the series expansion of the expression VEX with respect to variable VX \ttindex{VORDER} about point VPT to order VORDER. Valid combinations of argument types are shown in table~\ref{ORTHOVEC:validexp}. \\ \begin{table} \begin{center} \begin{tabular}{cccc} VEX & VX & VPT & VORDER \\[2ex] {\bf v} & {\bf v} & {\bf v} & {\bf v}\\ {\bf v} & {\bf v} & {\bf v} & s\\ {\bf v} & s & s & s \\ s & {\bf v} & {\bf v} & {\bf v} \\ s & {\bf v} & {\bf v} & s\\ s & s & s & s\\ \end{tabular} \end{center} \caption{ORTHOVEC valid combination of argument types.}\label{ORTHOVEC:validexp} \end{table} Any other combinations cause error messages to be issued. Elements of VORDER must be non-negative integers, otherwise error messages are issued. If scalar VORDER is given for a vector expansion, expansions in each component are truncated at the same order, VORDER. The new version of Taylor expansion applies \index{L'H\^opital's rule} L'H\^opital's rule in evaluating coefficients, so handle cases such as $\sin(x) / (x) $ , etc. which the original version of ORTHOVEC could not. The procedure used for this is LIMIT, \ttindex{LIMIT} which can be used directly to find the limit of a scalar function {\tt ex} of variable {\tt x} at point {\tt pt}:- \begin{verbatim} ans := limit(ex,x,pt); \end{verbatim} \section{Integral Operations} Definite and indefinite vector, volume and scalar line integration procedures are included in ORTHOVEC. They are defined as follows: \ttindex{VINT} \ttindex{DVINT} \ttindex{VOLINT} \ttindex{DVOLINT} \ttindex{LINEINT} \ttindex{DLINEINT} \begin{eqnarray*} {\rm VINT} ({\bf v},x) & = & \int {\bf v}(x)dx\\ % {\rm DVINT} ({\bf v},x, a, b) & = & \int^b_a {\bf v} (x) dx\\ % {\rm VOLINT} ({\bf v}) & = & \int {\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\ % {\rm DVOLINT}({\bf v},{\bf l},{\bf u},n) & = & \int^{\bf u}_{\bf l} {\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\ % {\rm LINEINT} ({\bf v, \omega}, t) & = & \int {\bf v} \cdot {\bf dr} \equiv \int v_i h_i \frac{\partial \omega_i}{\partial t} dt\\ % {\rm DLINEINT} ({\bf v, \omega} t, a, b) & = & \int^b_a v_i h_i \frac{\partial \omega_i}{\partial t} dt\\ \end{eqnarray*} In the vector and volume integrals, ${\bf v}$ are vector or scalar, $a, b,x$ and $n$ are scalar. Vectors ${\bf l}$ and ${\bf u}$ contain expressions for lower and upper bounds to the integrals. The integer index $n$ defines the order in which the integrals over $u_1, u_2$ and $u_3$ are performed in order to allow for functional dependencies in the integral bounds: \begin{center} \begin{tabular}{ll} n & order\\ 1 & $u_1~u_2~u_3$\\ % 2 & $u_3~u_1~u_2$\\ % 3 & $u_2~u_3~u_1$\\ % 4 & $u_1~u_3~u_2$\\ % 5 & $u_2~u_1~u_3$\\ otherwise & $u_3~u_2~u_1$\\ \end{tabular} \end{center} The vector ${\bf \omega}$ in the line integral's arguments contain explicit paramterisation of the coordinates $u_1, u_2, u_3$ of the line ${\bf u}(t)$ along which the integral is taken. \begin{table} \begin{center} \begin{tabular}{|l c l|} \hline \multicolumn{1}{|c}{Procedures} & & \multicolumn{1}{c|}{Description} \\ \hline VSTART & & select coordinate system \\ & & \\ SVEC & & set up a vector \\ VOUT & & output a vector \\ VECTORCOMPONENT & \_ & extract a vector component (1-3) \\ & & \\ VECTORADD & + & add two vectors or scalars \\ VECTORPLUS & + & unary vector or scalar plus\\ VECTORMINUS & - & unary vector or scalar minus\\ VECTORDIFFERENCE & - & subtract two vectors or scalars \\ VECTORQUOTIENT & / & vector divided by scalar \\ VECTORRECIP & / & unary vector or scalar division \\ & & \ \ \ (reciprocal)\\ VECTORTIMES & * & multiply vector or scalar by \\ & & \ \ \ vector/scalar \\ VECTORCROSS & $><$ & cross product of two vectors \\ VECTOREXPT & \^{} & exponentiate vector modulus or scalar \\ VMOD & & length of vector or scalar \\ \hline \end{tabular} \end{center} \caption{Procedures names and operators used in ORTHOVEC (part 1)} \end{table} \begin{table} \begin{center} \begin{tabular}{|l l|} \hline \multicolumn{1}{|c}{Procedures} & \multicolumn{1}{c|}{Description} \\ \hline DIV & divergence of vector \\ GRAD & gradient of scalar \\ CURL & curl of vector \\ DELSQ & laplacian of scalar or vector \\ DOTGRAD & (vector).grad(scalar or vector) \\ & \\ VTAYLOR & vector or scalar Taylor series of vector or scalar \\ VPTAYLOR & vector or scalar Taylor series of scalar \\ TAYLOR & scalar Taylor series of scalar \\ LIMIT & limit of quotient using L'H\^opital's rule \\ & \\ VINT & vector integral \\ DVINT & definite vector integral \\ VOLINT & volume integral \\ DVOLINT & definite volume integral \\ LINEINT & line integral \\ DLINEINT & definite line integral \\ & \\ MAPRIN & vector extension of REDUCE MAPRIN \\ DEPEND & vector extension of REDUCE DEPEND \\ NODEPEND & vector extension of REDUCE NODEPEND \\ \hline \end{tabular} \end{center} \caption{Procedures names and operators used in ORTHOVEC (part 2)} \end{table} \section{Test Cases} To use the REDUCE source version of ORTHOVEC, initiate a REDUCE session and then IN the file {\em orthovec.red} containing ORTHOVEC. However, it is recommended that for efficiency a compiled fast loading version be made and LOADed when required (see Sec.~18 of the REDUCE manual). If coordinate dependent differential and integral operators other than cartesian are needed, then VSTART must be used to reset coordinates and scale factors. Six simple examples are given in the Test Run Output file {\em orthovectest.log} to illustrate the working of ORTHOVEC. The input lines were taken from the file {\em orthovectest.red} (the Test Run Input), but could equally well be typed in at the Terminal. \example\index{ORTHOVEC package ! example} Show that \begin{eqnarray*} ({\bf a} \times {\bf b}) \cdot ({\bf c} \times {\bf d}) - ({\bf a} \cdot {\bf c})({\bf b} \cdot {\bf d}) + ({\bf a} \cdot {\bf d})({\bf b} \cdot {\bf c}) \equiv 0 \end{eqnarray*} \example\index{ORTHOVEC package ! example}\label{ORTHOVEC:eqm} Write the equation of motion \begin{eqnarray*} \frac{\partial {\bf v}}{\partial t} + {\bf v} \cdot {\bf \nabla v} + {\bf \nabla} p - curl ({\bf B}) \times {\bf B} \end{eqnarray*} in cylindrical coordinates. \example\index{ORTHOVEC package ! example}\label{ORTHOVEC:taylor} Taylor expand \begin{itemize} \item $\sin(x) \cos(y) +e^z$ about the point $(0,0,0)$ to third order in $x$, fourth order in $y$ and fifth order in $z$. \item $\sin(x)/x$ about $x$ to fifth order. \item ${\bf v}$ about ${\bf x}=(x,y,z)$ to fifth order, where ${\bf v} = (x/ \sin(x),(e^y-1)/y,(1+z)^{10})$. \end{itemize} \example\index{ORTHOVEC package ! example} Obtain the second component of the equation of motion in example~\ref{ORTHOVEC:eqm}, and the first component of the final vector Taylor series in example~\ref{ORTHOVEC:taylor}. \example\index{ORTHOVEC package ! example} Evaluate the line integral \begin{eqnarray*} \int^{{\bf r}_2}_{{\bf r}_1} {\bf A} \cdot d{\bf r} \end{eqnarray*} from point ${\bf r}_1 = (1,1,1)$ to point ${\bf r}_2 = (2,4,8)$ along the path $(x,y,z) = (s, s^2, s^3)$ where\\ \begin{eqnarray*} {\bf A} = (3x^2 + 5y) {\bf i} - 12xy{\bf j} + 2xyz^2{\bf k} \end{eqnarray*} and $({\bf i, j, k})$ are unit vectors in the ($x,y,z$) directions. \example\index{ORTHOVEC package ! example} Find the volume $V$ common to the intersecting cylinders $x^2 + y^2 = r^2$ and $x^2 + z^2 = r^2$ i.e. evaluate \begin{eqnarray*} V = 8 \int^r_0 dx \int^{ub}_0 dy \int^{ub}_0 dz \end{eqnarray*} where $ub = \overline{\sqrt { r^2 - x^2}}$ \bibliography{orthovec} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/reduce.sty version [cde0bdb40e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The REDUCE Style option File --- LaTeX version. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % The document should start with: % \documentstyle[11pt,reduce,makeidx]{...} % % This style adds the following commands: % \COMPATNOTE{...} For compatibility notes. % \f{...} Sets function name is \tt. % \k{...} Sets BNF keyword bold. % \REDUCE REDUCE when needed as a word. % \RLISP RLISP when needed as a word. % \s{...} Sets BNF sentential form \em in <...> % \meta An alternative for BNF italics in <...> % \ttindex{...} Puts index entry in \tt font. % % % % Basic religion about REDUCE documentation. No paragraph indentation, % bigger skip between lines, ragged bottom, and not as much vertical % space. %% RmS: setup of size dependent parameters. 11pt is assumed, so let's force it. \typeout{Document style option `reduce' -- released 5 Nov 1991.} % **************************************** % * FONTS * % **************************************** % \lineskip 1pt % \lineskip is 1pt for all font sizes. \normallineskip 1pt \def\baselinestretch{1} % Each size-changing command \SIZE executes the command % \@setsize\SIZE{BASELINESKIP}\FONTSIZE\@FONTSIZE % where: % BASELINESKIP = Normal value of \baselineskip for that size. (Actual % value will be \baselinestretch * BASELINESKIP.) % % \FONTSIZE = Name of font-size command. The currently available % (preloaded) font sizes are: \vpt (5pt), \vipt (6pt), % \viipt (etc.), \viiipt, \ixpt, \xpt, \xipt, \xiipt, % \xivpt, \xviipt, \xxpt, \xxvpt. % \@FONTSIZE = The same as the font-size command except with an % '@' in front---e.g., if \FONTSIZE = \xivpt then % \@FONTSIZE = \@xivpt. % % For reasons of efficiency that needn't concern the designer, % the document style defines \@normalsize instead of \normalsize. This % is done only for \normalsize, not for any other size-changing % commands. \def\@normalsize{\@setsize\normalsize{13.6pt}\xipt\@xipt \abovedisplayskip .5\baselineskip \belowdisplayskip \abovedisplayskip \abovedisplayshortskip \z@ plus3\p@ \belowdisplayshortskip 6.5\p@ plus3.5\p@ minus3\p@ \let\@listi\@listI} % Setting of \@listi added 9 Jun 87 \def\small{\@setsize\small{12pt}\xpt\@xpt \abovedisplayskip .5\baselineskip \belowdisplayskip \abovedisplayskip \abovedisplayshortskip \z@ plus3\p@ \belowdisplayshortskip 6\p@ plus3\p@ minus3\p@ \def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87 \topsep \z@\parsep 3\p@ plus2\p@ minus\p@ \itemsep .5\baselineskip}} \def\footnotesize{\@setsize\footnotesize{11pt}\ixpt\@ixpt \abovedisplayskip .5\baselineskip \belowdisplayskip \abovedisplayskip \abovedisplayshortskip \z@ plus\p@ \belowdisplayshortskip 4\p@ plus2\p@ minus2\p@ \def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87 \topsep \z@ \parsep 2\p@ plus\p@ minus\p@ \itemsep .5\baselineskip}} \def\scriptsize{\@setsize\scriptsize{9.5pt}\viiipt\@viiipt} \def\tiny{\@setsize\tiny{7pt}\vipt\@vipt} \def\large{\@setsize\large{14pt}\xiipt\@xiipt} \def\Large{\@setsize\Large{18pt}\xivpt\@xivpt} \def\LARGE{\@setsize\LARGE{22pt}\xviipt\@xviipt} \def\huge{\@setsize\huge{25pt}\xxpt\@xxpt} \def\Huge{\@setsize\Huge{30pt}\xxvpt\@xxvpt} \normalsize % Choose the normalsize font. % **************************************** % * PAGE LAYOUT * % **************************************** % % All margin dimensions measured from a point one inch from top and side % of page. % SIDE MARGINS: \if@twoside % Values for two-sided printing: \oddsidemargin 36pt % Left margin on odd-numbered pages. \evensidemargin 74pt % Left margin on even-numbered pages. \marginparwidth 100pt % Width of marginal notes. \else % Values for one-sided printing: \oddsidemargin 54pt % Note that \oddsidemargin = \evensidemargin \evensidemargin 54pt \marginparwidth 83pt \fi \marginparsep 10pt % Horizontal space between outer margin and % marginal note % VERTICAL SPACING: % Top of page: \topmargin 27pt % Nominal distance from top of page to top % of box containing running head. \headheight 12pt % Height of box containing running head. \headsep 25pt % Space between running head and text. % \topskip = 10pt % '\baselineskip' for first line of page. % Bottom of page: \footskip 30pt % Distance from baseline of box containing % foot to baseline of last line of text. % DIMENSION OF TEXT: % 24 Jun 86: changed to explicitly compute \textheight to avoid % roundoff. The value of the multiplier was calculated as the floor of % the old \textheight minus \topskip, divided by \baselineskip for % \normalsize. The old value of \textheight was 530.4pt. % \textheight is the height of text (including footnotes and figures, % excluding running head and foot). \textheight = 38\baselineskip \advance\textheight by \topskip \textwidth 360pt % Width of text line. % For two-column mode: \columnsep 10pt % Space between columns \columnseprule 0pt % Width of rule between columns. % A \raggedbottom command causes 'ragged bottom' pages: pages set to % natural height instead of being stretched to exactly \textheight. % FOOTNOTES: \footnotesep 7.7pt % Height of strut placed at the beginning of every % footnote = height of normal \footnotesize strut, % so no extra space between footnotes. \skip\footins 10pt plus 4pt minus 2pt % Space between last line of text % and top of first footnote. % FLOATS: (a float is something like a figure or table) % % FOR FLOATS ON A TEXT PAGE: % % ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE: \floatsep 12pt plus 2pt minus 2pt % Space between adjacent floats % moved to top or bottom of % text page. \textfloatsep 20pt plus 2pt minus 4pt % Space between main text and % floats at top or bottom of % page. \intextsep 12pt plus 2pt minus 2pt % Space between in-text figures % and text. \@maxsep 20pt % The maximum of \floatsep, % \textfloatsep and \intextsep % (minus the stretch and % shrink). % TWO-COLUMN FLOATS IN TWO-COLUMN MODE: \dblfloatsep 12pt plus 2pt minus 2pt % Same as \floatsep for % double-column figures in % two-column mode. \dbltextfloatsep 20pt plus 2pt minus 4pt % \textfloatsep for % double-column floats. \@dblmaxsep 20pt % The maximum of \dblfloatsep % and \dbltexfloatsep. % FOR FLOATS ON A SEPARATE FLOAT PAGE OR COLUMN: % ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE: \@fptop 0pt plus 1fil % Stretch at top of float page/column. (Must % be 0pt plus ...) \@fpsep 8pt plus 2fil % Space between floats on float page/column. \@fpbot 0pt plus 1fil % Stretch at bottom of float page/column. (Must % be 0pt plus ... ) % DOUBLE-COLUMN FLOATS IN TWO-COLUMN MODE. \@dblfptop 0pt plus 1fil % Stretch at top of float page. (Must be 0pt % plus ...) \@dblfpsep 8pt plus 2fil % Space between floats on float page. \@dblfpbot 0pt plus 1fil % Stretch at bottom of float page. (Must be % 0pt plus ... ) % MARGINAL NOTES: % \marginparpush 5pt % Minimum vertical separation between two % marginal notes. % **************************************** % * PARAGRAPHING * % **************************************** % \parskip 6pt plus 1pt %% RmS % Extra vertical space between % paragraphs. \parindent 0pt %% RmS % Width of paragraph indentation. \topsep 0pt %% RmS % Extra vertical space, in addition % to \parskip, added above and below % list and paragraphing environments. \partopsep 0pt %% RmS % Extra vertical space, in addition % to \parskip and \topsep, added when % user leaves blank line before % environment. \itemsep \topsep %% RmS % Extra vertical space, in addition % to \parskip, added between list % items. % See \@listI for values of \topsep and \itemsep % The following page-breaking penalties are defined \@lowpenalty 51 % Produced by \nopagebreak[1] or \nolinebreak[1] \@medpenalty 151 % Produced by \nopagebreak[2] or \nolinebreak[2] \@highpenalty 301 % Produced by \nopagebreak[3] or \nolinebreak[3] \@beginparpenalty -\@lowpenalty % Before a list or paragraph % environment. \@endparpenalty -\@lowpenalty % After a list or paragraph % environment. \@itempenalty -\@lowpenalty % Between list items. % \clubpenalty % 'Club line' at bottom of page. % \widowpenalty % 'Widow line' at top of page. % \displaywidowpenalty % Math display widow line. % \predisplaypenalty % Breaking before a math display. % \postdisplaypenalty % Breaking after a math display. % \interlinepenalty % Breaking at a line within a paragraph. % \brokenpenalty % Breaking after a hyphenated line. % **************************************** % * SECTIONS * % **************************************** % % \@startsection {NAME}{LEVEL}{INDENT}{BEFORESKIP}{AFTERSKIP}{STYLE} % optional * [ALTHEADING]{HEADING} % Generic command to start a section. % NAME : e.g., 'subsection' % LEVEL : a number, denoting depth of section -- i.e., % section=1, subsection = 2, etc. A section number will % be printed if and only if LEVEL < or = the value of % the secnumdepth counter. % INDENT : Indentation of heading from left margin % BEFORESKIP : Absolute value = skip to leave above the heading. % If negative, then paragraph indent of text following % heading is suppressed. % AFTERSKIP : if positive, then skip to leave below heading, % else - skip to leave to right of run-in heading. % STYLE : commands to set style % If '*' missing, then increments the counter. If it is present, then % there should be no [ALTHEADING] argument. A sectioning command % is normally defined to \@startsection + its first six arguments. \def\section{\@startsection {section}{1}{\z@}{-3.5ex plus-1ex minus -.2ex}{2.3ex plus.2ex}{\reset@font\Large\bf}} \def\subsection{\@startsection{subsection}{2}{\z@}{-3.25ex plus-1ex minus-.2ex}{1.5ex plus.2ex}{\reset@font\large\bf}} \def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus -1ex minus-.2ex}{1.5ex plus.2ex}{\reset@font\normalsize\bf}} \def\paragraph{\@startsection {paragraph}{4}{\z@}{3.25ex plus1ex minus.2ex}{-1em}{\reset@font \normalsize\bf}} \def\subparagraph{\@startsection {subparagraph}{4}{\parindent}{3.25ex plus1ex minus .2ex}{-1em}{\reset@font\normalsize\bf}} % Default initializations of \...mark commands. (See below for their % use in defining page styles. % % \def\sectionmark#1{} % Preloaded definitions % \def\subsectionmark#1{} % \def\subsubsectionmark#1{} % \def\paragraphmark#1{} % \def\subparagraphmark#1{} % The value of the counter secnumdepth gives the depth of the % highest-level sectioning command that is to produce section numbers. % \setcounter{secnumdepth}{3} % APPENDIX % % The \appendix command must do the following: % -- reset the section and subsection counters to zero % -- redefine the section counter to produce appendix numbers % -- redefine the \section command if appendix titles and headings % are to look different from section titles and headings. \def\appendix{\par \setcounter{section}{0} \setcounter{subsection}{0} \def\thesection{\Alph{section}}} % **************************************** % * LISTS * % **************************************** % % The following commands are used to set the default values for the list % environment's parameters. See the LaTeX manual for an explanation of % the meanings of the parameters. Defaults for the list environment are % set as follows. First, \rightmargin, \listparindent and \itemindent % are set to 0pt. Then, for a Kth level list, the command \@listK is % called, where 'K' denotes 'i', 'ii', ... , 'vi'. (I.e., \@listiii is % called for a third-level list.) By convention, \@listK should set % \leftmargin to \leftmarginK. % \leftmargini 2.5em \leftmarginii 2.2em % > \labelsep + width of '(m)' \leftmarginiii 1.87em % > \labelsep + width of 'vii.' \leftmarginiv 1.7em % > \labelsep + width of 'M.' \leftmarginv 1em \leftmarginvi 1em \leftmargin\leftmargini \labelsep .5em \labelwidth\leftmargini\advance\labelwidth-\labelsep %\parsep 4.5pt plus 2pt minus 1pt %(Removed 9 Jun 87) % \@listI defines top level and \@listi values of % \leftmargin, \topsep, \parsep, and \itemsep % (Added 9 Jun 87) \def\@listI{\leftmargin\leftmargini \parsep 4.5\p@ plus2\p@ minus\p@ \topsep \z@ \itemsep \topsep} \let\@listi\@listI \@listi \def\@listii{\leftmargin\leftmarginii \labelwidth\leftmarginii\advance\labelwidth-\labelsep \topsep \z@ \itemsep \topsep \parsep 2\p@ plus\p@ minus\p@} \def\@listiii{\leftmargin\leftmarginiii \labelwidth\leftmarginiii\advance\labelwidth-\labelsep \topsep \z@ \itemsep \topsep \parsep \z@ \partopsep\z@} \def\@listiv{\leftmargin\leftmarginiv \labelwidth\leftmarginiv\advance\labelwidth-\labelsep} %% RmS: which at the same time makes the vertical space in lists (verbatim...) %% too large if not other precautions are taken. \setlength{\parindent}{0pt} \setlength{\parskip}{6pt} \raggedbottom % Various boxes. \newlength{\reduceboxwidth} \setlength{\reduceboxwidth}{4in} \newlength{\redboxwidth} \setlength{\redboxwidth}{3.5in} \newlength{\rboxwidth} \setlength{\rboxwidth}{2.6in} % These are here in case the name changes or we someday want a special % font. \newcommand{\REDUCE}{REDUCE} \newcommand{\RLISP}{RLISP} % This is useful for putting function names in \tt format in the index. \newcommand{\ttindex}[1]{\index{#1@{\tt #1}}} % Use this when you are speaking about problems across systems. \newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }} \pagestyle{headings} %% For BNF notation. % \s{...} is a sentential form in descriptions. Enclosed \em text in <...> \newcommand{\s}[1] {$<${\em #1}$>$} % \meta{...} is an alternative sentential form in descriptions using \it. \newcommand{\meta}[1]{\mbox{$\langle$\it#1\/$\rangle$}} % \k{...} is a keyword. Just do in bold for the moment. \newcommand{\k}[1] {{\bf #1}} % \f is a function name. Just do this as tt. \newcommand{\f}[1] {{\tt #1}} % An example macro for numbering and indenting examples. \newcounter{examplectr} \newcommand{\example}{\refstepcounter{examplectr} \noindent{\bf Example \theexamplectr}} % The following are currently only used in the GENTRAN document. However, % there's no objection to using them elsewhere. \begingroup \catcode `|=0 \catcode `[= 1 \catcode`]=2 \catcode `\{=12 \catcode `\}=12 \catcode`\\=12 |gdef|@xframedverbatim#1\end{framedverbatim}[#1|end[framedverbatim]] |gdef|@sxframedverbatim#1\end{framedverbatim*}[#1|end[framedverbatim*]] |endgroup \newdimen\@mcdheight \def\@sframedverbatim{\obeyspaces\@framedverbatim} \def\@mcdrule{\@mcdheight=\baselineskip\advance\@mcdheight by-2pt \setbox0=\hbox{\vrule height\@mcdheight depth 2pt width 1pt}% \ht0=\@mcdheight\dp0=0pt\wd0=1pt\box0} \def\@mcdendrule{\@mcdheight=\baselineskip% \setbox0=\hbox{\vrule height\@mcdheight depth 2pt width 1pt}% \ht0=\@mcdheight\dp0=0pt\wd0=1pt\box0} \def\@framedverbatim{\trivlist \item[] \parskip \z@ \hrule \@height \p@ \@depth \z@ \@width\textwidth \everypar{\global \@minipagefalse \global \@newlistfalse \if@inlabel \global \@inlabelfalse \hskip -\parindent \box \@labels \penalty \z@ \fi \hbox to6\p@{\rlap{\@mcdrule}\hskip\textwidth\llap{\@mcdrule}\hss}}% \if@minipage\else\vskip\parskip\fi \leftskip\@totalleftmargin\rightskip\z@ \parindent\z@\parfillskip\@flushglue\parskip\z@ \@tempswafalse \def\par{\if@tempswa\hbox{}\fi\@tempswatrue\@@par \penalty\interlinepenalty}% % fix \samepage bug \obeylines \tt \catcode``=13 \@noligs \let\do\@makeother \dospecials} \def\framedverbatim{\@framedverbatim \frenchspacing\@vobeyspaces \@xframedverbatim} \def\endframedverbatim{\nointerlineskip {\everypar{}\baselineskip 4\p@\vbox to4\p@{\par\noindent\hbox to6pt{\rlap{\@mcdendrule}\hskip\textwidth\llap{\@mcdendrule}\hss}}% \vskip\p@\hrule \@height \p@ \@depth \z@ \@width\textwidth}\endtrivlist} \@namedef{framedverbatim*}{\@framedverbatim\@sxframedverbatim} \expandafter\let\csname endframedverbatim*\endcsname =\endtrivlist % Will print out a heading in bold, and then indent the following text. \def\indented{\list{}{ \itemindent\listparindent \rightmargin\leftmargin}\item[]} \let\endindented=\endlist \newenvironment{describe}[1]{\par{\bf #1}\begin{indented}}{\end{indented}} \@ifundefined{reset@font}{\let\reset@font\@empty}{} \endinput |
Added r34.1/doc/reduce.tex version [e6e5bf492b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 | % The REDUCE User's Manual --- LaTeX version. % To create this manual, the following steps are recommended: % latex reduce % makeindex reduce % latex reduce % latex reduce --- this is probably not necessary. \documentstyle[11pt,makeidx]{book} \parindent 0pt \parskip 6pt \raggedbottom \newlength{\reduceboxwidth} \setlength{\reduceboxwidth}{4in} \newlength{\redboxwidth} \setlength{\redboxwidth}{3.5in} \newlength{\rboxwidth} \setlength{\rboxwidth}{2.6in} \newcommand{\REDUCE}{REDUCE} \newcommand{\RLISP}{RLISP} \newcommand{\ttindex}[1]{\index{#1@{\tt #1}}} \newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }} % Close up default vertical spacings: \setlength{\topsep}{0.5\baselineskip} % above and below environments \setlength{\itemsep}{\topsep} \setlength{\abovedisplayskip}{\topsep} % for "long" equations \setlength{\belowdisplayskip}{\topsep} \pagestyle{headings} \makeindex \begin{document} \pagestyle{empty} \begin{titlepage} \vspace*{\fill} \begin{center} {\Huge\bf {\REDUCE}} \\[0.2cm] {\LARGE\bf User's Manual\vspace{0.4cm} \\ Version 3.4} \vspace{0.5in}\large\bf Anthony C.\ Hearn \\ RAND \\ Santa Monica, CA 90407-2138 \vspace{0.1in} \bf Email: reduce@rand.org \vspace{0.5in} \large\bf July 1991 \vspace*{2.5in} \bf RAND Publication CP78 (Rev. 7/91) \end{center} \end{titlepage} \newpage \vspace*{3.0in} \noindent Copyright \copyright 1991 RAND. All rights reserved. \\ \noindent Registered system holders may reproduce all or any part of this publication for internal purposes, provided that the source of the material is clearly acknowledged, and the copyright notice is retained. \pagestyle{headings} \setcounter{page}{0} \tableofcontents \chapter*{Abstract} \addcontentsline{toc}{chapter}{Abstract} This document provides the user with a description of the algebraic programming system {\REDUCE}. The capabilities of this system include: \begin{enumerate} \item expansion and ordering of polynomials and rational functions, \item substitutions and pattern matching in a wide variety of forms, \item automatic and user controlled simplification of expressions, \item calculations with symbolic matrices, \item arbitrary precision integer and real arithmetic, \item facilities for defining new functions and extending program syntax, \item analytic differentiation and integration, \item factorization of polynomials, \item facilities for the solution of a variety of algebraic equations, \item facilities for the output of expressions in a variety of formats, \item facilities for generating numerical programs from symbolic input, \item Dirac matrix calculations of interest to high energy physicists. \end{enumerate} \chapter*{Acknowledgment} The production of this version of the manual has been the result of the contributions of a large number of individuals who have taken the time and effort to suggest improvements to previous versions, and to draft new sections. Particular thanks are due to Gerry Rayna, who provided a draft rewrite of most of the first half of the manual. Other people who have made significant contributions have included John Fitch, Martin Griss, Stan Kameny, Jed Marti, Herbert Melenk, Don Morrison, Arthur Norman, Eberhard Schr\"ufer and Larry Seward. Finally, Richard Hitt produced a {\TeX} version of the {\REDUCE} 3.3 manual, which has been a useful guide for the production of the {\LaTeX} version of this manual. \chapter{Introductory Information} \index{Introduction}{\REDUCE} is a system for carrying out algebraic operations accurately, no matter how complicated the expressions become. It can manipulate polynomials in a variety of forms, both expanding and factoring them, and extract various parts of them as required. {\REDUCE} can also do differentiation and integration, but we shall only show trivial examples of this in this introduction. Other topics which are not considered include the use of arrays, the definition of procedures and operators, the specific routines for high energy physics calculations, the use of files to eliminate repetitious typing and for saving results, and the editing of the input text. Also not considered in any detail in this introduction are the many options that are available for varying computational procedures, output forms, number systems used, and so on. {\REDUCE} is designed to be an interactive system, so that the user can input an algebraic expression and see its value before moving on to the next calculation. For those systems that do not support interactive use, or for those calculations, especially long ones, for which a standard script can be defined, {\REDUCE} can also be used in batch mode. In this case, a sequence of commands can be given to {\REDUCE} and results obtained without any user interaction during the computation. In this introduction, we shall limit ourselves to the interactive use of {\REDUCE}, since this illustrates most completely the capabilities of the system. When {\REDUCE} is called, it begins by printing a banner message like: \begin{verbatim} REDUCE 3.4, 15-Jul-91 ... \end{verbatim} where the version number and the system release date will change from time to time. It then prompts the user for input by: \begin{verbatim} 1: \end{verbatim} You can now type a {\REDUCE} statement, terminated by a semicolon to indicate the end of the expression, for example: \begin{verbatim} (x+y+z)^2; \end{verbatim} This expression would normally be followed by another character (a RETURN on an ASCII keyboard) to ``wake up" the system, which would then input the expression, evaluate it, and return the result: \begin{verbatim} 2 2 2 X + 2*X*Y + 2*X*Z + Y + 2*Y*Z + Z \end{verbatim} Let us review this simple example to learn a little more about the way that {\REDUCE} works. First, we note that {\REDUCE} deals with variables, and constants like other computer languages, but that in evaluating the former, a variable can stand for itself. Expression evaluation normally follows the rules of high school algebra, so the only surprise in the above example might be that the expression was expanded. {\REDUCE} normally expands expressions where possible, collecting like terms and ordering the variables in a specific manner. However, expansion, ordering of variables, format of output and so on is under control of the user, and various declarations are available to manipulate these. Another characteristic of the above example is the use of lower case on input and upper case on output. In fact, input may be in either mode, but lower case is usually converted to upper case by the system, although some versions produce output in lower case by default. This distinction is reflected in this manual in that all expressions intended for input will be shown in lower case and output in upper case. However, for stylistic reasons, we represent all single identifiers in the text in upper case. Finally, the numerical prompt can be used to reference the result in a later computation. As a further illustration of the system features, the user should try: \begin{verbatim} for i:= 1:40 product i; \end{verbatim} The result in this case is the value of 40!, \begin{verbatim} 815915283247897734345611269596115894272000000000 \end{verbatim} You can also get the same result by saying \begin{verbatim} factorial 40; \end{verbatim} Since we want exact results in algebraic calculations, it is essential that integer arithmetic be performed to arbitrary precision, as in the above example. Furthermore, the {\tt FOR} statement in the above is illustrative of a whole range of combining forms which {\REDUCE} supports for the convenience of the user. Among the many options in {\REDUCE} is the use of other number systems, such as multiple precision floating point with any specified number of digits -- of use if roundoff in, say, the $100^{th}$ digit is all that can be tolerated. In many cases, it is necessary to use the results of one calculation in succeeding calculations. One way to do this is via an assignment for a variable, such as \begin{verbatim} u := (x+y+z)^2; \end{verbatim} If we now use {\tt U} in later calculations, the value of the right-hand side of the above will be used. The results of a given calculation are also saved in the variable {\tt WS} \ttindex{WS} (for WorkSpace), so this can be used in the next calculation for further processing. For example, the expression \begin{verbatim} df(ws,x); \end{verbatim} following the previous evaluation will calculate the derivative of {\tt (x+y+z)\^{ }2} with respect to {\tt X}. Alternatively, \begin{verbatim} int(ws,y); \end{verbatim} would calculate the integral of the same expression with respect to y. {\REDUCE} is also capable of handling symbolic matrices. For example, \begin{verbatim} matrix m(2,2); \end{verbatim} declares m to be a two by two matrix, and \begin{verbatim} m := mat((a,b),(c,d)); \end{verbatim} gives its elements values. Expressions which include {\tt M} and make algebraic sense may now be evaluated, such as {\tt 1/m} to give the inverse, {\tt 2*m - u*m\^{ }2} to give us another matrix and {\tt det(m)} to give us the determinant of {\tt M}. {\REDUCE} has a wide range of substitution capabilities. The system knows about elementary functions, but does not automatically invoke many of their well-known properties. For example, products of trigonometrical functions are not converted automatically into multiple angle expressions, but if the user wants this, he can say, for example: \begin{verbatim} (sin(a+b)+cos(a+b))*(sin(a-b)-cos(a-b)) where cos(~x)*cos(~y) = (cos(x+y)+cos(x-y))/2, cos(~x)*sin(~y) = (sin(x+y)-sin(x-y))/2, sin(~x)*sin(~y) = (cos(x-y)-cos(x+y))/2; \end{verbatim} where the tilde in front of the variables {\tt X} and {\tt Y} indicates that the rules apply for all values of those variables. The result of this calculation is \begin{verbatim} -(COS(2*A) + SIN(2*B)) \end{verbatim} Another very commonly used capability of the system, and an illustration of one of the many output modes of {\REDUCE}, is the ability to output results in a FORTRAN compatible form. Such results can then be used in a FORTRAN based numerical calculation. This is particularly useful as a way of generating algebraic formulas to be used as the basis of extensive numerical calculations. For example, the statements \begin{verbatim} on fort; df(log(x)*(sin(x)+cos(x))/sqrt(x),x,2); \end{verbatim} will result in the output \begin{verbatim} ANS=(-4.*LOG(X)*COS(X)*X**2-4.*LOG(X)*COS(X)*X+3.*LOG(X)* . COS(X)-4.*LOG(X)*SIN(X)*X**2+4.*LOG(X)*SIN(X)*X+3.*LOG(X) . *SIN(X)+8.*COS(X)*X-8.*COS(X)-8.*SIN(X)*X-8.*SIN(X))/(4.* . SQRT(X)*X**2) \end{verbatim} These algebraic manipulations illustrate the algebraic mode of {\REDUCE}. {\REDUCE} is based on Standard Lisp. A symbolic mode is also available for executing Lisp statements. These statements follow the syntax of Lisp, e.g. \begin{verbatim} symbolic car '(a); \end{verbatim} Communication between the two modes is possible. With this simple introduction, you are now in a position to study the material in the full {\REDUCE} manual in order to learn just how extensive the range of facilities really is. If further tutorial material is desired, the seven {\REDUCE} Interactive Lessons by David R. Stoutemyer are recommended. These are normally distributed with the system. \chapter{Structure of Programs} A {\REDUCE} program\index{Program structure} consists of a set of functional commands which are evaluated sequentially by the computer. These commands are built up from declarations, statements and expressions. Such entities are composed of sequences of numbers, variables, operators, strings, reserved words and delimiters (such as commas and parentheses), which in turn are sequences of basic characters. \section{The {\REDUCE} Standard Character Set} \index{Character set}The basic characters which are used to build {\REDUCE} symbols are the following: \begin{enumerate} \item The 26 upper case letters {\tt A} through {\tt Z} \item The 10 decimal digits {\tt 0} through {\tt 9} \item The special characters \_\_ ! " \$ \% ' ( ) * + , - . / : ; $<$ $>$ = \{ \} $<$blank$>$ \end{enumerate} Programs composed from this standard set of characters will run in any available {\REDUCE} system. Most implementations permit lower case on input. With the exception of strings and characters preceded by an exclamation mark\index{Exclamation mark} (q.v.), such lower case characters will be converted internally into upper case. If you do not wish this conversion to occur, the command {\tt off raise;} \ttindex{RAISE} achieves this. However, now case {\em is} distinguished internally, so that {\tt df} is not the same as {\tt DF} (the derivative operator). Several implementations also allow some special characters to represent operators in the system. The operating instructions for a particular implementation should be consulted on these points. For generality, we shall limit ourselves to the standard character set in this exposition. \section{Numbers} \index{Number}There are several different types of numbers available in \REDUCE. Integers consist of a signed or unsigned sequence of decimal digits written without a decimal point, for example: \begin{verbatim} -2, 5396, +32 \end{verbatim} In principle, there is no practical limit on the number of digits permitted as exact arithmetic is used in most implementations. (You should however check the specific instructions for your particular system implementation to make sure that this is true.) For example, if you ask for the value of $2^{2000}$ you get it displayed as a number of 603 decimal digits, taking up nine lines of output on an interactive display. It should be borne in mind of course that computations with such long numbers can be quite slow. Numbers that aren't integers are usually represented as the quotient of two integers, in lowest terms: that is, as rational numbers. In essentially all versions of {\REDUCE} it is also possible (but not always desirable!) to ask {\REDUCE} to work with floating point approximations to numbers again, to any precision. Such numbers are called {\em real}. \index{Real} They can be input in two ways: \begin{enumerate} \item as a signed or unsigned sequence of any number of decimal digits with an embedded or trailing decimal point. \item as in 1. followed by a decimal exponent which is written as the letter {\tt E} followed by a signed or unsigned integer. \end{enumerate} e.g. {\tt 32. +32.0 0.32E2} and {\tt 320.E-1} are all representations of 32. {\it CAUTION:} The unsigned part of any number\index{Number} may {\em not} begin with a decimal point, as this causes confusion with the {\tt CONS} (.) operator in symbolic mode (q.v.), i.e., NOT ALLOWED: {\tt .5 -.23 +.12}; use {\tt 0.5 -0.23 +0.12} instead. \section{Identifiers} Identifiers\index{Identifier} in {\REDUCE} consist of one or more alphanumeric characters (i.e. upper case alphabetic letters or decimal digits) the first of which must be alphabetic. The maximum number of characters allowed is implementation dependent, although twenty-four is permitted in most implementations. In addition, the underscore character (\_) is considered a letter. For example, \begin{verbatim} a az p1 q23p a_very_long_variable \end{verbatim} are all identifiers. A sequence of alphanumeric characters in which the first is a digit is interpreted as a product. For example, {\tt 2ab3c} is interpreted as {\tt 2*ab3c}. There is one exception to this: If the first letter after a digit is {\tt E}, the system will try to interpret that part of the sequence as a real number\index{Real}, which may fail in some cases. For example, {\tt 2E12} is the real number $2.0*10^{12}$, {\tt 2e3c} is 2000.0*C, and {\tt 2ebc} gives an error. Special characters, such as $-$, *, and blank, may be used in identifiers too, even as the first character, but each must be preceded by an exclamation mark in input. For example: \begin{verbatim} light!-years d!*!*n good! morning !$sign !5goldrings \end{verbatim} {\it CAUTION:} Many system identifiers have such special characters in their names (especially * and =). If the user accidentally picks the name of one of them for his own purposes it may have catastrophic consequences for his {\REDUCE} run. Users are therefore advised to avoid such names. Identifiers are used as variables, labels and to name arrays, operators and procedures. \subsection*{Restrictions} The reserved words listed in another section may not be used as identifiers. No spaces may appear within an identifier, and an identifier may not extend over a line of text. (Hyphenation of an identifier, by using a reserved character as a hyphen before an end-of-line character is possible in some versions of {\REDUCE}). \section{Variables} Every variable\index{Variable} is named by an identifier, and is given a specific type. The type is of no concern to the ordinary user. Most variables are allowed to have the default type, called {\em scalar}. These can receive, as values, the representation of any ordinary algebraic expression. In the absence of such a value, they stand for themselves. \subsection*{Reserved Variables} Several variables\index{Reserved variable} in {\REDUCE} have particular properties which should not be changed by the user. These variables are as follows: \\ \begin{tabular}{l r} {\tt E} & \parbox[t]{\reduceboxwidth}{Intended to represent the base of the natural logarithms. LOG(E), if it occurs in an expression, is automatically replaced by 1. If {\tt ROUNDED} (q.v.) \ttindex{ROUNDED} is on, E is replaced by the value of E to the current degree of floating point precision\index{Numerical precision}.} \\ \\ {\tt I} & \parbox[t]{\reduceboxwidth}{Intended to represent the square root of $-1$. {\tt i\^{ }2} is replaced by -1, and appropriately for higher powers of {\tt I}. (This applies only to the symbol {\tt I} used on the top level, not as a formal parameter in a procedure, a local variable, nor in the context {\tt for i:= ...} .).} \\ \\ {\tt INFINITY} & \parbox[t]{\reduceboxwidth}{Intended to represent $\infty$ \ttindex{INFINITY} in limit and power series calculations for example. Note however that the current system does {\em not} do proper arithmetic on $\infty$. For example, {\tt infinity + infinity} is {\tt 2*infinity}.} \\ \\ {\tt NIL} & \parbox[t]{\reduceboxwidth}{In {\REDUCE} (algebraic mode only) taken as a synonym for zero. Therefore NIL cannot be used as a variable.} \\ \\ {\tt PI} & \parbox[t]{\reduceboxwidth}{Intended to represent the circular constant. With ROUNDED on, it is replaced by the value of $\pi$ to the current degree of floating point precision.} \\ \\ {\tt T} & \parbox[t]{\reduceboxwidth}{Should not be used as a formal parameter or local variable in procedures, since conflict arises with the symbolic mode meaning of T as {\em true}.} \\ \\ \end{tabular} Using these reserved variables\index{Reserved variable} inappropriately will lead to an error. There are also internal variables used by {\REDUCE} that have similar restrictions. These usually have an asterisk in their names, so it is unlikely a casual user would use one. An example of such a variable is {\tt K!*} used in the asymptotic command package. Certain words are reserved in {\REDUCE}. They may only be used in the manner intended. A list of these is given in the section ``Reserved Identifiers". There are, of course, an impossibly large number of such names to keep in mind. The reader may therefore want to make himself a copy of the list, deleting the names he doesn't think he is likely to use by mistake. \section{Strings} Strings\index{String} are used in {\tt WRITE} statements (q.v.), in other output statements (such as error messages), and to name files. A string consists of any number of characters enclosed in double quotes. For example: \begin{verbatim} "A String". \end{verbatim} Lower case characters within a string are not converted to upper case. The string {\tt ""} represents the empty string. A double quote may be included in a string by preceding it by another double quote. Thus {\tt "a""b"} is the string {\tt a"b}, and {\tt """"} is the string {\tt "}. \section{Comments} Text can be included in program\index{Program} listings for the convenience of human readers, in such a way that {\REDUCE} pays no attention to it. There are two ways to do this: \begin{enumerate} \item Everything from the word {\tt COMMENT}\ttindex{COMMENT} to the next statement terminator (q.v.), normally ; or \$, is ignored. Such comments can be placed anywhere a blank could properly appear. (Note that {\tt END} and $>>$ are {\em not} treated as {\tt COMMENT} delimiters!) \item Everything from the symbol {\tt \%}\index{Percent sign} to the end of the line on which it appears is ignored. Such comments can be placed as the last part of any line. Statement terminators have no special meaning in such comments. Remember to put a semicolon before the {\tt \%} if the earlier part of the line is intended to be so terminated. Remember also to begin each line of a multi-line {\tt \%} comment with a {\tt \%} sign. \end{enumerate} \section{Operators} Operators\index{Operator} in {\REDUCE} are specified by name and type. There are two types, infix\index{Infix operator} and prefix. \index{Prefix operator} Operators can be purely abstract, just symbols with no properties; they can have values assigned (using {\tt :=} or simple {\tt LET} declarations) for specific arguments; they can have properties declared for some collection of arguments (using more general {\tt LET} declarations); or they can be fully defined (usually by a procedure declaration). Infix operators\index{Infix operator} have a definite precedence with respect to one another, and normally occur between their arguments. For example: \begin{quote} \begin{tabbing} {\tt a + b - c} \hspace{1.5in} \= (spaces optional) \\ {\tt x<y and y=z} \> (spaces required where shown) \end{tabbing} \end{quote} Spaces can be freely inserted between operators and variables or operators and operators. They are required only where operator names are spelled out with letters (such as the {\tt AND} in the example) and must be unambiguously separated from another such or from a variable (like {\tt Y}). Wherever one space can be used, so can any larger number. Prefix operators occur to the left of their arguments, which are written as a list enclosed in parentheses and separated by commas, as with normal mathematical functions, e.g., \begin{verbatim} cos(u) df(x^2,x) q(v+w) \end{verbatim} Unmatched parentheses, incorrect groupings of infix operators \index{Infix operator} and the like, naturally lead to syntax errors. The parentheses can be omitted (replaced by a space following the operator\index{Operator} name) if the operator is unary and the argument is a single symbol or begins with a prefix operator name: \begin{quote} \begin{tabbing} {\tt cos y} \hspace{1.75in} \= means cos(y) \\ {\tt cos (-y)} \> -- parentheses necessary \\ {\tt log cos y} \> means log(cos(y)) \\ {\tt log cos (a+b)} \> means log(cos(a+b)) \end{tabbing} \end{quote} but \begin{quote} \begin{tabbing} {\tt cos a*b} \hspace{1.6in} \= means (cos a)*b \\ {\tt cos -y} \> is erroneous (treated as a variable \\ \> ``cos" minus the variable y) \end{tabbing} \end{quote} A unary prefix operator\index{Prefix operator} has a precedence \index{Operator precedence} higher than any infix operator, including unary infix operators. \index{Infix operator} In other words, {\REDUCE} will always interpret {\tt cos~y + 3} as {\tt (cos~y) + 3} rather than as {\tt cos(y + 3)}. Infix operators may also be used in a prefix format on input, e.g., {\tt +(a,b,c)}. On output, however, such expressions will always be printed in infix form (i.e., {\tt a + b + c} for this example). A number of prefix operators are built into the system with predefined properties. Users may also add new operators and define their rules for simplification. The built in operators are described in another section. \subsection*{Built-In Infix Operators} The following infix operators\index{Infix operator} are built into the system. They are all defined internally as procedures. \begin{verbatim} <infix operator>::= where|:=|or|and|not|member|memq|=|neq|eq| >=|>|<=|<|+|-|*|/|^|**|. \end{verbatim} These operators may be further divided into the following subclasses: \begin{verbatim} <assignment operator> ::= := <logical operator> ::= or|and|not|member|memq <relational operator> ::= =|neq|eq|>=|>|<=|< <substitution operator> ::= where <arithmetic operator> ::= +|-|*|/|^|** <construction operator> ::= . \end{verbatim} {\tt MEMBER}, {\tt MEMQ} and {\tt EQ} are not used in the algebraic mode of {\REDUCE}. They are explained in the section on symbolic mode (q.v.). {\tt WHERE} is described in the section on substitutions. For compatibility with the intermediate language used by {\REDUCE}, each special character infix operator\index{Infix operator} has an alternative alphanumeric identifier associated with it. These identifiers may be used interchangeably with the corresponding special character names on input. This correspondence is as follows: \begin{quote} \begin{tabbing} {\tt := setq} \hspace{0.5in} \= (the assignment operator) \\ {\tt = equal} \\ {\tt >= geq} \\ {\tt > greaterp} \\ {\tt <= leq} \\ {\tt < lessp} \\ {\tt + plus} \\ {\tt - difference} \> (if unary, {\tt minus}) \\ {\tt * times} \\ {\tt / quotient} \> (if unary, {\tt recip}) \\ {\tt \^{ } or ** expt} \> (raising to a power) \\ {\tt . cons} \end{tabbing} \end{quote} Note: {\tt NEQ} is used to mean {\em not equal}. There is no special symbol provided for it. The above operators\index{Operator} are binary, except {\tt NOT} which is unary and {\tt +} and {\tt *} which are nary (i.e., taking an arbitrary number of arguments). In addition, {\tt -} and {\tt /} may be used as unary operators, e.g., /2 means the same as 1/2. Any other operator is parsed as a binary operator using a left association rule. Thus {\tt a/b/c} is interpreted as {\tt (a/b)/c}. There are two exceptions to this rule: {\tt :=} and {\tt .} are right associative. Example: {\tt a:=b:=c} is interpreted as {\tt a:=(b:=c)}. Unlike ALGOL and PASCAL, {\tt \^{ }} is left associative. The operators\index{Operator} {\tt $<$}, {\tt $<$=}, {\tt $>$}, {\tt $>$=} can only be used for making comparisons between numbers. No meaning is currently assigned to this kind of comparison between general expressions. Parentheses may be used to specify the order of combination. If parentheses are omitted then this order is by the ordering of the precedence list\index{Operator precedence} defined by the right-hand side of the BNF definition of {\tt <infix operator>}\index{Infix operator} above, from lowest to highest. In other words, {\tt :=} has the lowest precedence, and {\tt .} (the dot operator) the highest. \chapter{Expressions} {\REDUCE} expressions\index{Expression} may be of several types and consist of sequences of numbers, variables, operators, left and right parentheses and commas. The most common types are as follows: \section{Scalar Expressions} \index{Scalar}Using the arithmetic operations {\tt + - * / \^{ }} (power) and parentheses, scalar expressions are composed from numbers, ordinary ``scalar" variables (identifiers), array names with subscripts, operator or procedure names with arguments and statement expressions. {\it Examples:} \begin{verbatim} x x^3 - 2*y/(2*z^2 - df(x,z)) (p^2 + m^2)^(1/2)*log (y/m) a(5) + b(i,q) \end{verbatim} The symbol ** may be used as an alternative to the caret symbol (\verb+^+) for forming powers. The particular system instructions should be consulted to determine if this is not supported. Statement expressions (q.v.), usually in parentheses, can also form part of a scalar\index{Scalar} expression, as in the example \begin{verbatim} w + (c:=x+y) + z . \end{verbatim} When the algebraic value of an expression is needed, {\REDUCE} determines it, starting with the algebraic values of the parts, roughly as follows: Variables and operator symbols with an argument list have the algebraic values they were last assigned, or if never assigned stand for themselves. However, array elements have the algebraic values they were last assigned, or, if never assigned, are taken to be 0. Procedures are evaluated with the values of their actual parameters. In evaluating expressions, the standard rules of algebra are applied. Unfortunately, this algebraic evaluation of an expression is not as unambiguous as is numerical evaluation. This process is generally referred to as ``simplification"\index{Simplification} in the sense that the evaluation usually but not always produces a simplified form for the expression. There are many options available to the user for carrying out such simplification\index{Simplification}. If the user doesn't specify any method, the default method is used. The default evaluation of an expression involves expansion of the expression and collection of like terms, ordering of the terms, evaluation of derivatives and other functions and substitution for any expressions which have values assigned or declared (see assignments and {\tt LET} statements). In many cases, this is all that the user needs. The declarations by which the user can exercise some control over the way in which the evaluation is performed are explained in other sections. For example, if a real (floating point) number is encountered during evaluation, the system will normally convert it into a ratio of two integers. If the user wants to use real arithmetic, he can effect this by the command {\tt on rounded;}. \ttindex{ROUNDED} Other modes for coefficient arithmetic are described elsewhere. If an illegal action occurs during evaluation (such as division by zero) or functions are called with the wrong number of arguments, and so on, an appropriate error message is generated. % A list of such error messages is given in an appendix. \section{Integer Expressions} \index{Integer}These are expressions which, because of the values of the constants and variables in them, evaluate to whole numbers. {\it Examples:} \begin{verbatim} 2, 37 * 999, (x + 3)^2 - x^2 - 6*x \end{verbatim} are obviously integer expressions. \begin{verbatim} j + k - 2 * j^2 \end{verbatim} is an integer expression when {\tt J} and {\tt K} have values that are integers, or if not integers are such that ``the variables and fractions cancel out", as in \begin{verbatim} k - 7/3 - j + 2/3 + 2*j^2. \end{verbatim} \section{Boolean Expressions} \label{sec-boolean} A boolean expression\index{Boolean} returns a truth value. In the algebraic mode of {\REDUCE}, boolean expressions have the syntactical form: \begin{verbatim} <expression> <relational operator> <expression> \end{verbatim} or \begin{verbatim} <boolean operator> (<arguments>) \end{verbatim} or \begin{verbatim} <boolean expression> <logical operator> <boolean expression>. \end{verbatim} Parentheses can also be used to control the precedence of expressions. In addition to the logical and relational operators defined earlier as infix operators, the following boolean operators are also defined: \\ \\ \ttindex{EVENP}\ttindex{FIXP}\ttindex{FREEOF}\ttindex{NUMBERP} \ttindex{ORDP}\ttindex{PRIMEP} \begin{tabular}{l r} {\tt EVENP(U)} & \parbox[t]{\redboxwidth}{determines if the number {\tt U} is even or not;} \\ \\ {\tt FIXP(U)} & \parbox[t]{\redboxwidth}{determines if the expression {\tt U} is integer or not;} \\ \\ {\tt FREEOF(U,V)} & \parbox[t]{\redboxwidth}{determines if the expression {\tt U} does not contain the kernel (q.v.) {\tt V} anywhere in its structure;} \\ \\ {\tt NUMBERP(U)} & \parbox[t]{\redboxwidth}{determines if {\tt U} is a number or not;} \\ \\ {\tt ORDP(U,V)} & \parbox[t]{\redboxwidth}{determines if {\tt U} is ordered ahead of {\tt V} by some canonical ordering (based on the expression structure and an internal ordering of identifiers);} \\ \\ {\tt PRIMEP(U)} & \parbox[t]{\redboxwidth}{true if {\tt U} is a prime object.} \\ \\ \end{tabular} {\it Examples:} \begin{verbatim} j<1 x>0 or x=-2 numberp x fixp x and evenp x numberp x and x neq 0 \end{verbatim} Boolean expressions can only appear directly within {\tt IF}, {\tt FOR}, {\tt WHILE}, and {\tt UNTIL} statements, as described in other sections. Such expression cannot be used in place of ordinary algebraic expressions, or assigned to a variable. NB: For those familiar with symbolic mode (q.v.), the meaning of some of these operators is different in that mode. For example, {\tt NUMBERP} is true only for integers and reals in symbolic mode. When two or more boolean expressions are combined with {\tt AND}, they are evaluated one by one until a {\em false} expression is found. The rest are not evaluated. Thus \begin{verbatim} numberp x and numberp y and x>y \end{verbatim} does not attempt to make the {\tt x>y} comparison unless {\tt X} and {\tt Y} are both verified to be numbers. Similarly, evaluation of a sequence of boolean expressions connected by {\tt OR} stops as soon as a {\em true} expression is found. NB: In a boolean expression, and in a place where a boolean expression is expected, the algebraic value 0 is interpreted as {\em false}, while all other algebraic values are converted to {\em true}. So in algebraic mode a procedure can be written for direct usage in boolean expressions, returning say 1 or 0 as its value as in \begin{verbatim} procedure polynomialp(u,x); if den(u)=1 and deg(u,x)>=1 then 1 else 0; \end{verbatim} One can then use this in a boolean construct, such as \begin{verbatim} if polynomialp(q,z) and not polynomialp(q,y) then ... \end{verbatim} In addition, any procedure that does not have a defined return value (for example, a block (q.v.) without a {\tt RETURN} statement in it) has the boolean value {\em false}. \section{Equations} Equations\index{Equation} are a particular type of expression with the syntax \begin{verbatim} <expression> = <expression>. \end{verbatim} In addition to their role as boolean expressions, they can also be used as arguments to several operators (e.g., {\tt SOLVE} (q.v.)), and can be returned as values. Under normal circumstances, the right-hand-side of the equation is evaluated but not the left-hand-side. If both sides are to be evaluated, the switch {\tt EVALLHSEQP} \ttindex{EVALLHSEQP} should be turned on. To facilitate the handling of equations, two selectors, {\tt LHS} \ttindex{LHS} and {\tt RHS} \ttindex{RHS}, which return the left- and right-hand sides of a equation\index{Equation} respectively, are provided. For example, \begin{verbatim} lhs(a+b=c) -> a+b and rhs(a+b=c) -> c. \end{verbatim} \section{Proper Statements as Expressions} Several kinds of proper statements\index{Proper statement} (q.v.) deliver an algebraic or numeric result of some kind, which can in turn be used as an expression or part of an expression. For example, an assignment statement itself has a value, namely the value assigned. So \begin{verbatim} 2 * (x := a+b) \end{verbatim} is equal to {\tt 2*(a+b)}, as well as having the ``side-effect"\index{Side effect} of assigning the value {\tt a+b} to {\tt X}. In context, \begin{verbatim} y := 2 * (x := a+b); \end{verbatim} sets {\tt X} to {\tt a+b} and {\tt Y} to {\tt 2*(a+b)}. The sections on the various proper statement\index{Proper statement} types indicate which of these statements are also useful as expressions. \chapter{Lists} A list\index{List} is an object consisting of a sequence of other objects (including lists themselves), separated by commas and surrounded by braces. Examples of lists are: \begin{verbatim} {a,b,c} {1,a-b,c=d} {{a},{{b,c},d},e}. \end{verbatim} \section{Operations on Lists}\index{List operation} Several operators in the system return their results as lists, and a user can create new lists using braces and commas. To facilitate the use of such lists, a number of operators are also available for manipulating them. {\tt PART(<list>,n)}\ttindex{PART} for example will return the $n^{th}$ element of a list. {\tt LENGTH}\ttindex{LENGTH} will return the length of a list. Several operators are also defined uniquely for lists. For those familiar with them, these operators in fact mirror the operations defined for Lisp lists. These operators are as follows: \subsection{FIRST} This operator\ttindex{FIRST} returns the first member of a list. An error occurs if the argument is not a list, or the list is empty. \subsection{SECOND} {\tt SECOND} \ttindex{SECOND} returns the second member of a list. An error occurs if the argument is not a list or has no second element. \subsection{THIRD} This operator\ttindex{THIRD} returns the third member of a list. An error occurs if the argument is not a list or has no third element. \subsection{REST} {\tt REST} \ttindex{REST} returns its argument with the first element removed. An error occurs if the argument is not a list, or is empty. \subsection{ $.$ (Cons) Operator} This operator\ttindex{. (CONS)} adds (``conses") an expression to the front of a list. For example: \begin{verbatim} a . {b,c} -> {a,b,c}. \end{verbatim} \subsection{APPEND} This operator\ttindex{APPEND} appends its first argument to its second to form a new list. {\it Examples:} \begin{verbatim} append({a,b},{c,d}) -> {a,b,c,d} append({{a,b}},{c,d}) -> {{a,b},c,d}. \end{verbatim} \subsection{REVERSE} The operator {\tt REVERSE}\ttindex{REVERSE} returns its argument with the elements in the reverse order. It only applies to the top level list, not any lower level lists that may occur. Examples are:\index{List operation} \begin{verbatim} reverse({a,b,c}) -> {c,b,a} reverse({{a,b,c},d}) -> {d,{a,b,c}}. \end{verbatim} \subsection{List Arguments of Other Operators} If an operator other than those specifically defined for lists is given a single argument that is a list, then the result of this operation will be a list in which that operator is applied to each element of the list. For example, the result of evaluating {\tt log\{a,b,c\}} is the expression {\tt \{LOG(A),LOG(B),LOG(C)\}}. There are two ways to inhibit this operator distribution. Firstly, the switch {\tt LISTARGS}, \ttindex{LISTARGS} if on, will globally inhibit such distribution. Secondly, one can inhibit this distribution for a specific operator by the declaration {\tt LISTARGP}.\ttindex{LISTARGP} For example, with the declaration {\tt listargp log}, {\tt log\{a,b,c\}} would evaluate to {\tt LOG(\{A,B,C\})}. If an operator has more than one argument, no such distribution occurs. \chapter{Statements} A statement\index{Statement} is any combination of reserved words and expressions, and has the syntax \index{Proper statement} \begin{verbatim} <statement> ::= <expression>|<proper statement> \end{verbatim} A {\REDUCE} program consists of a series of commands which are statements followed by a terminator:\index{Terminator}\index{Semicolon} \index{Dollar sign} \begin{verbatim} <terminator> ::= ;|$ \end{verbatim} The division of the program into lines is arbitrary. Several statements can be on one line, or one statement can be freely broken onto several lines. If the program is run interactively, statements ending with ; or \$ are not processed until an end-of-line character is encountered. This character can vary from system to system, but is normally the RETURN key on an ASCII terminal. Specific systems may also use additional keys as statement terminators. If a statement is a proper statement\index{Proper statement}, the appropriate action takes place. Depending on the nature of the proper statement some result or response may or may not be printed out, and the response may or may not depend on the terminator used. If a statement is an expression, it is evaluated. If the terminator is a semicolon, the result is printed. If the terminator is a dollar sign, the result is not printed. Because it is not usually possible to know in advance how large an expression will be, no explicit format statements are offered to the user. However, a variety of output declarations are available so that the output can be produced in different forms. These output declarations are explained in Section~\ref{sec-output}. The following sub-sections describe the types of proper statements \index{Proper statement} in {\REDUCE}. \section{Assignment Statements} These statements\index{Assignment} have the syntax \begin{verbatim} <assignment statement> ::= <expression> := <expression> \end{verbatim} The {\tt <expression>} on the left side is normally the name of a variable, an operator symbol with its list of arguments filled in, or an array name with the proper number of integer subscript values within the array bounds. For example: \begin{quote} \begin{tabbing} {\tt a1 := b + c} \\ {\tt h(l,m) := x-2*y} \hspace{1in} \= (where {\tt h} is an operator) \\ {\tt k(3,5) := x-2*y} \> (where {\tt k} is a 2-dim. array) \end{tabbing} \end{quote} More general assignments\index{Assignment} such as {\tt a+b := c} are also allowed. The effect of these is explained in the section ``Substitutions for General Expressions". An assignment statement causes the expression on the right-hand-side to be evaluated. If the left-hand-side is a variable, the value of the right-hand-side is assigned to that unevaluated variable. If the left-hand-side is an operator or array expression, the arguments of that operator or array are evaluated, but no other simplification done. The evaluated right-hand-side is then assigned to the resulting expression. For example, if {\tt A} is a single-dimensional array, {\tt a(1+1) := b} assigns the value {\tt B} to the array element {\tt a(2)}. If a semicolon is used as the terminator when an assignment \index{Assignment} is issued as a command (i.e. not as a part of a group statement or procedure or other similar construct), the left-hand side symbol of the assignment statement is printed out, followed by a ``{\tt :=}", followed by the value of the expression on the right. It is also possible to write a multiple assignment statement: \index{Multiple assignment statement} \begin{verbatim} <expression> := ... := <expression> := <expression> \end{verbatim} In this form, each {\tt <expression>} but the last is set to the value of the last {\tt <expression>}. If a semicolon is used as a terminator, each expression except the last is printed followed by a ``{\tt :=}" ending with the value of the last expression. \subsection{Set Statement} In some cases, it is desirable to perform an assignment in which {\em both} the left- and right-hand sides of an assignment\index{Assignment} are evaluated. In this case, the {\tt SET}\ttindex{SET} statement can be used with the syntax: \begin{verbatim} SET(<expression>,<expression>); \end{verbatim} For example, the statements \begin{verbatim} j := 23; set(mkid(a,j),x); \end{verbatim} assigns the value {\tt X} to {\tt A23}. \section{Group Statements} The group statement\index{Group statement} is a construct used where {\REDUCE} expects a single statement, but a series of actions needs to be performed. It is formed by enclosing one or more statements (of any kind) between the symbols {\tt $<<$} and {\tt $>>$}, separated by semicolons or dollar signs -- it doesn't matter which. The statements are executed one after another. Examples will be given in the sections on {\tt IF}\ttindex{IF} and other types of statements in which the {\tt $<<$} \ldots {\tt $>>$} construct is useful. If the last statement in the enclosed group has a value, then that is also the value of the group statement. Care must be taken not to have a semicolon or dollar sign after the last grouped statement, if the value of the group is relevant: such an extra terminator causes the group to have the value NIL or zero. \section{Conditional Statements} The conditional statement\index{Conditional statement} has the following syntax: \begin{verbatim} <conditional statement> ::= IF <boolean expression> THEN <statement> [ELSE <statement>] \end{verbatim} The boolean expression is evaluated. If the result is {\em true}, the first {\tt <statement>} is executed. If it is {\em false}, the second is. {\it Examples:} \begin{verbatim} if x=5 then a:=b+c else d:=e+f if x=5 and numberp y then <<ff:=q1; a:=b+c>> else <<ff:=q2; d:=e+f>> \end{verbatim} Note the use of the group statement\index{Group statement}. \\ Conditional statements associate to the right; i.e.,\ttindex{IF} \begin{verbatim} IF <a> THEN <b> ELSE IF <c> THEN <d> ELSE <e> \end{verbatim} is equivalent to: \begin{verbatim} IF <a> THEN <b> ELSE (IF <c> THEN <d> ELSE <e>) \end{verbatim} In addition, the construction \begin{verbatim} IF <a> THEN IF <b> THEN <c> ELSE <d> \end{verbatim} parses as \begin{verbatim} IF <a> THEN (IF <b> THEN <c> ELSE <d>). \end{verbatim} If the value of the conditional statement\index{Conditional statement} is of primary interest, it is often called a conditional expression instead. Its value is the value of whichever statement was executed. (If the executed statement has no value, the conditional expression has no value or the value 0, depending on how it is used.) {\it Examples:} \begin{verbatim} a:=if x<5 then 123 else 456; b:=u + v^(if numberp z then 10*z else 1) + w; \end{verbatim} If the value is of no concern, the {\tt ELSE} clause may be omitted if no action is required in the {\em false} case. \begin{verbatim} if x=5 then a:=b+c; \end{verbatim} Note: As explained in Section~\ref{sec-boolean},a if a scalar or numeric expression is used in place of the boolean expression -- for example, a variable is written there -- the {\em true} alternative is followed unless the expression has the value 0. \section{FOR Statements} The {\tt FOR} statement is used to define a variety of program loops\index{Loop}. Its general syntax is as follows:\ttindex{UNTIL} \ttindex{DO} \ttindex{PRODUCT} \ttindex{SUM} \ttindex{COLLECT} \ttindex{JOIN} \begin{verbatim} {STEP <number> UNTIL} {<var>:=<number>{ }<number>} FOR { { : } }<action><exprn> { } { EACH <var> IN <list> } \end{verbatim} where \begin{verbatim} <action> ::= do|product|sum|collect|join. \end{verbatim} The assignment\index{Assignment} form of the {\tt FOR} statement defines an iteration over the indicated numerical range. If expressions that do not evaluate to numbers are used in the designated places, an error will result. The {\tt FOR EACH} \ttindex{FOR EACH} form of the {\tt FOR} statement is designed to iterate down a list. Again, an error will occur if a list is not used. The action {\tt DO} \ttindex{DO} means that {\tt <exprn>} is simply evaluated and no value kept; the statement returning 0 in this case (or no value at the top level). {\tt COLLECT} means that the results of evaluating {\tt <exprn>} each time are linked together to make a list, and {\tt JOIN} means that the values of {\tt <exprn>} are themselves lists that are joined to make one list (similar to {\tt CONC} in Lisp). Finally, {\tt PRODUCT} \ttindex{PRODUCT} and {\tt SUM} \ttindex{SUM} form the respective combined value out of the values of {\tt <exprn>}. In all cases, {\tt <exprn>} is evaluated algebraically within the scope of the current value of {\tt <var>}. If {\tt <action>} is {\tt DO}\ttindex{DO}, then nothing else happens. In other cases, {\tt <action>} is a binary operator that causes a result to be built up and returned by {\tt FOR}. In those cases, the loop\index{Loop} is initialized to a default value ({\tt 0} for {\tt SUM}, \ttindex{SUM} {\tt 1} for {\tt PRODUCT}, \ttindex{PRODUCT} and an empty list for the other actions). The test for the end condition is made before any action is taken. As in Pascal, if the variable is out of range in the assignment case, or the {\tt <list>} is empty in the {\tt FOR EACH}\ttindex{FOR EACH} case, {\tt <exprn>} is not evaluated at all. {\it Examples:} \begin{enumerate} \item If {\tt A}, {\tt B} have been declared to be arrays, the following stores $5^{2}$ through $10^{2}$ in {\tt A(5)} through {\tt A(10)}, and at the same time stores the cubes in the {\tt B} array: \begin{verbatim} for i := 5 step 1 until 10 do <<a(i):=i^2; b(i):=i^3>> \end{verbatim} \item As a convenience, the common construction \begin{verbatim} STEP 1 UNTIL \end{verbatim} may be abbreviated to a colon. Thus, instead of the above we could write: \begin{verbatim} for i := 5:10 do <<a(i):=i^2; b(i):=i^3>> \end{verbatim} \item The following sets {\tt C} to the sum of the squares of 1,3,5,7,9; and {\tt D} to the expression {\tt x*(x+1)*(x+2)*(x+3)*(x+4):} \begin{verbatim} c := for j:=1 step 2 until 9 sum j^2; d := for k:=0 step 1 until 4 product (x+k); \end{verbatim} \item The following forms a list of the squares of the elements of the list {\tt \{a,b,c\}:}\ttindex{FOR EACH} \begin{verbatim} for each x in {a,b,c} collect x^2; \end{verbatim} \item The following forms a list of the listed squares of the elements of the list {\tt \{a,b,c\}} (i.e., {\tt \{\{A\^{ }2\},\{B\^{ }2\},\{C\^{ }2\}\}):} \begin{verbatim} for each x in {a,b,c} collect {x^2}; \end{verbatim} \item The following also forms a list of the squares of the elements of the list {\tt \{a,b,c\},} since the {\tt JOIN} operation joins the individual lists into one list:\ttindex{FOR EACH} \begin{verbatim} for each x in {a,b,c} join {x^2}; \end{verbatim} \end{enumerate} The control variable used in the {\tt FOR} statement is actually a new variable, not related to the variable of the same name outside the {\tt FOR} statement. In other words, executing a statement {\tt for i:=} \ldots doesn't change the system's assumption that $i^{2} = -1$. Furthermore, in algebraic mode, the value of the control variable is substituted in {\tt <exprn>} only if it occurs explicitly in that expression. It will not replace a variable of the same name in the value of that expression. For example: \begin{verbatim} b := a; for a := 1:2 do write b; \end{verbatim} prints {\tt A} twice, not 1 followed by 2. \section{WHILE \ldots DO} The\ttindex{WHILE} {\tt FOR \ldots DO} \ttindex{DO} feature allows easy coding of a repeated operation in which the number of repetitions is known in advance. If the criterion for repetition is more complicated, {\tt WHILE \ldots DO} can often be used. Its syntax is: \begin{verbatim} WHILE <boolean expression> DO <statement> \end{verbatim} The {\tt WHILE \ldots DO} controls the single statement following {\tt DO}. If several statements are to be repeated, as is almost always the case, they must be grouped using the $<<$ \ldots $>>$ or {\tt BEGIN \ldots END} as in the example below. The {\tt WHILE} condition is tested each time {\em before} the action following the {\tt DO} is attempted. If the condition is false to begin with, the action is not performed at all. Make sure that what is to be tested has an appropriate value initially. {\it Example:} Suppose we want to add up a series of terms, generated one by one, until we reach a term which is less than 1/1000 in value. For our simple example, let us suppose the first term equals 1 and each term is obtained from the one before by taking one third of it and adding one third its square. We would write: \begin{verbatim} ex:=0; term:=1; while num(term - 1/1000) >= 0 do <<ex := ex+term; term:=(term + term^2)/3>>; ex; \end{verbatim} As long as {\tt TERM} is greater than or equal to ({\tt >=}) 1/1000 it will be added to {\tt EX} and the next {\tt TERM} calculated. As soo\ as {\tt TERM} becomes less than 1/1000 the {\tt WHILE} test fails and the {\tt TERM} will not be added. \section{REPEAT \ldots UNTIL} \ttindex{REPEAT} {\tt REPEAT \ldots UNTIL} is very similar in purpose to {\tt WHILE \ldots DO}. Its syntax is: \begin{verbatim} REPEAT <statement> UNTIL <boolean expression> \end{verbatim} (PASCAL users note: Only a single statement -- usually a group statement -- is allowed between the {\tt REPEAT} and the {\tt UNTIL.)} \\ There are two essential differences: \begin{enumerate} \item The test is performed {\em after} the controlled statement (or group of statements) is executed, so the controlled statement is always executed at least once. \item The test is a test for when to stop rather than when to continue, so its ``polarity" is the opposite of that in {\tt WHILE \ldots DO.} \end{enumerate} As an example, we rewrite the example from the {\tt WHILE \ldots DO} section: \begin{verbatim} ex:=0; term:=1; repeat <<ex := ex+term; term := (term + term^2)/3>> until num(term - 1/1000) < 0; ex; \end{verbatim} In this case, the answer will be the same as before, because in neither case is a term added to {\tt EX} which is less than 1/1000. \section{Compound Statements} \index{Compound statement}Often the desired process can best (or only) be described as a series of steps to be carried out one after the other. In many cases, this can be achieved by use of the group statement\index{Group statement} (q.v.). However, each step often provides some intermediate result, until at the end we have the final result wanted. Alternatively, iterations on the steps are needed that are not possible with constructs such as {\tt WHILE} \ttindex{WHILE} or {\tt REPEAT} \ttindex{REPEAT} statements (q.v.). In such cases the steps of the process must be enclosed between the words {\tt BEGIN} and {\tt END}\ttindex{BEGIN \ldots END} forming what is technically called a {\em block}\index{Block} or {\em compound} statement. Such a compound statement can in fact be used wherever a group statement appears. The converse is not true: {\tt BEGIN \ldots END} can be used in ways that {\tt $<<$} \ldots {\tt $>>$} cannot. If intermediate results must be formed, local variables must be provided in which to store them. {\em Local} means that their values are deleted as soon as the block's operations are complete, and there is no conflict with variables outside the block that happen to have the same name. Local variables are created by a {\tt SCALAR}\ttindex{SCALAR} declaration immediately after the {\tt BEGIN}: \begin{verbatim} scalar a,b,c,z; \end{verbatim} If more convenient, several {\tt SCALAR} declarations can be given one after another: \begin{verbatim} scalar a,b,c; scalar z; \end{verbatim} In place of {\tt SCALAR} one can also use the declarations {\tt INTEGER}\ttindex{INTEGER} or {\tt REAL}\ttindex{REAL}. In the present version of {\REDUCE} variables declared {\tt INTEGER} are expected to have only integer values, and are initialized to 0. {\tt REAL} variables on the other hand are currently treated as algebraic mode {\tt SCALAR}s. {\it CAUTION:} {\tt INTEGER}, {\tt REAL} and {\tt SCALAR} declarations can only be given immediately after a {\tt BEGIN}. An error will result if they are used after other statements in a block (including {\tt ARRAY} and {\tt OPERATOR} declarations, which are global in scope), or outside the top-most block (e.g., at the top level). All variables declared {\tt SCALAR} are automatically initialized to zero in algebraic mode ({\tt NIL} in symbolic mode). Any symbols not declared as local variables in a block refer to the variables of the same name in the current calling environment. In particular, if they are not so declared at a higher level (e.g., in a surrounding block or as parameters in a calling procedure), their values can be permanently changed. Following the {\tt SCALAR}\ttindex{SCALAR} declaration(s), if any, write the statements to be executed, one after the other, separated by delimiters (e.g., {\tt ;} or {\tt \$}) (it doesn't matter which). However, from a stylistic point of view, {\tt ;} is preferred. The last statement in the body, just before {\tt END}, need not have a terminator (since the {\tt BEGIN \ldots END} are in a sense brackets confining the block statements). The last statement must also be the command {\tt RETURN} \ttindex{RETURN} followed by the variable or expression whose value is to be the value returned by the procedure. If the {\tt RETURN} is omitted (or nothing is written after the word {\tt RETURN}) the procedure will have no value or the value zero, depending on how it is used (and {\tt NIL} in symbolic mode). Remember to put a terminator after the {\tt END}. {\it Example:} Given a previously assigned integer value for {\tt N}, the following block will compute the Legendre polynomial of degree {\tt N} in the variable {\tt X}: \begin{verbatim} begin scalar seed,deriv,top,fact; seed:=1/(y^2 - 2*x*y +1)^(1/2); deriv:=df(seed,y,n); top:=sub(y=0,deriv); fact:=for i:=1:n product i; return top/fact end; \end{verbatim} \subsection{Compound Statements with GO TO} It is possible to have more complicated structures inside the {\tt BEGIN \ldots END} \ttindex{BEGIN \ldots END} brackets than indicated in the previous example. That the individual lines of the program need not be assignment \index{Assignment} statements, but could be almost any other kind of statement or command, needs no explanation. For example, conditional statements, and {\tt WHILE} \ttindex{WHILE} and {\tt REPEAT} \ttindex{REPEAT} constructions, have an obvious role in defining more intricate blocks. If these structured constructs don't suffice, it is possible to use labels \index{Label} and {\tt GO} {\tt TO}s\ttindex{GO TO} within a compound statement \index{Compound statement}, and also to use {\tt RETURN} \ttindex{RETURN} in places within the block other than just before the {\tt END}. The following subsections discuss these matters in detail. For many readers the following example, presenting one possible definition of a process to calculate the factorial of {\tt N} for preassigned {\tt N} will suffice: {\it Example:} \begin{verbatim} begin scalar m; m:=1; l: if n=0 then return m; m:=m*n; n:=n-1; go to l end; \end{verbatim} \subsection{Labels and GO TO Statements} \index{Label} \ttindex{GO TO}Within a {\tt BEGIN \ldots END} compound statement it is possible to label statements, and transfer to them out of sequence using {\tt GO} {\tt TO} statements. Only statements on the top level inside compound statements can be labeled, not ones inside subsidiary constructions like {\tt $<<$} \ldots {\tt $>>$}, {\tt IF} \ldots {\tt THEN} \ldots , {\tt WHILE} \ldots {\tt DO} \ldots , etc. Labels and {\tt GO TO} statements have the syntax: \begin{verbatim} <go to statement> ::= GO TO <label> | GOTO <label> <label> ::= <identifier> <labeled statement> ::= <label>:<statement> \end{verbatim} Note that statement names cannot be used as labels. While {\tt GO TO} is an unconditional transfer, it is frequently used in conditional statements such as \begin{verbatim} if x>5 then go to abcd; \end{verbatim} giving the effect of a conditional transfer. Transfers using {\tt GO TO}s can only occur within the block in which the {\tt GO TO} is used. In other words, you cannot transfer from an inner block to an outer block using a {\tt GO TO}. However, if a group statement occurs within a compound statement, it is possible to jump out of that group statement to a point within the compound statement using a {\tt GO TO}. \subsection{RETURN Statements} The value corresponding to a {\tt BEGIN \ldots END} compound statement, \ttindex{BEGIN \ldots END} such as a procedure body, is normally 0 ({\tt NIL} in symbolic mode). By executing a {\tt RETURN}\ttindex{RETURN} statement in the compound statement a different value can be returned. After a {\tt RETURN} statement is executed no further statements within the compound statement are. {\tt Examples:} \begin{verbatim} return x+y; return m; return; \end{verbatim} Note that parentheses are not required around the {\tt x+y}, although they are permitted. The last example is equivalent to {\tt return 0} or {\tt return nil}, depending on whether the block is used as part of an expression or not. Since {\tt RETURN} \ttindex{RETURN} actually moves up only one block\index{Block} level, in a sense the casual user is not expected to understand, we tabulate some cautions concerning its use. \begin{enumerate} \item {\tt RETURN} can be used on the top level inside the compound statement, i.e. as one of the statements bracketed together by the {\tt BEGIN \ldots END}\ttindex{BEGIN \ldots END} \item {\tt RETURN} can be used within a top level {\tt $<<$} \ldots {\tt $>>$} construction within the compound statement. In this case, the {\tt RETURN} transfers control out of both the group statement and the compound statement. \item {\tt RETURN} can be used within an {\tt IF} \ldots {\tt THEN} \ldots {\tt ELSE} \ldots on the top level within the compound statement. \end{enumerate} NOTE: At present, there is no construct provided to permit early termination of a {\tt FOR} \ttindex{FOR}, {\tt WHILE} \ttindex{WHILE}, or {\tt REPEAT} \ttindex{REPEAT} statement. In particular, the use of {\tt RETURN} in such cases results in a syntax error. For example, \begin{verbatim} begin scalar y; y := for i:=0:99 do if a(i)=x then return b(i); ... \end{verbatim} will lead to an error. \chapter{Commands and Declarations} A command\index{Command} is an order to the system to do something. Some commands cause visible results (such as calling for input or output); others, usually called declarations\index{Declaration}, set options, define properties of variables, or define procedures. Commands are formally defined as a statement followed by a terminator \begin{verbatim} <command> ::= <statement> <terminator> <terminator> ::= ;|$ \end{verbatim} Some {\REDUCE} commands and declarations are described in the following sub-sections. \section{Array Declarations} Array\ttindex{ARRAY} declarations in {\REDUCE} are similar to FORTRAN dimension statements. For example: \begin{verbatim} array a(10),b(2,3,4); \end{verbatim} Array indices each range from 0 to the value declared. An element of an array is referred to in standard FORTRAN notation, e.g. {\tt A(2)}. We can also use an expression for defining an array bound, provided the value of the expression is a positive integer. For example, if {\tt X} has the value 10 and {\tt Y} the value 7 then {\tt array c(5*x+y)} is the same as {\tt array c(57)}. If an array is referenced by an index outside its range, an error occurs. If the array is to be one-dimensional, and the bound a number or a variable (not a more general expression) the parentheses may be omitted: \begin{verbatim} array a 10, c 57; \end{verbatim} The operator {\tt LENGTH} \ttindex{LENGTH} (q.v.) applied to an array name returns a list of its dimensions. All array elements are initialized to 0 at declaration time. In other words, an array element has an {\em instant evaluation}\index{Instant evaluation} property and cannot stand for itself. If this is required, then an operator (q.v.) should be used instead. Array declarations can appear anywhere in a program. Once a symbol is declared to name an array, it can not also be used as a variable, or to name an operator or a procedure. It can however be re-declared to be an array, and its size may be changed at that time. An array name can also continue to be used as a parameter in a procedure, or a local variable in a compound statement, although this use is not recommended, since it can lead to user confusion over the type of the variable. Arrays once declared are global in scope, and so can then be referenced anywhere in the program. In other words, unlike arrays in most other languages, a declaration within a block (or a procedure) does not limit the scope of the array to that block, nor does the array go away on exiting the block (use {\tt CLEAR} instead for this purpose). \section{Mode Handling Declarations}\index{Mode} The {\tt ON} \ttindex{ON} and {\tt OFF} \ttindex{OFF} declarations are available to the user for controlling various system options. Each option is represented by a ``switch"\index{Switch} name. {\tt ON} and {\tt OFF} take a list of switch names as argument and turn them on and off respectively, e.g., \begin{verbatim} on time; \end{verbatim} causes the system to print a message after each command giving the elapsed CPU time since the last command, or since {\tt TIME} \ttindex{TIME} was last turned off, or the session began. Another useful switch with interactive use is {\tt DEMO}, which causes the system to pause after each command in a file until a RETURN is typed on the terminal. This enables a user to set up a demonstration file and step through it command by command. As with most declarations, arguments to {\tt ON} and {\tt OFF} may be strung together separated by commas. For example, \begin{verbatim} off time,demo; \end{verbatim} will turn off both the time messages and the demonstration switch. We note here that while most {\tt ON} and {\tt OFF} commands are obeyed almost instantaneously, some trigger time-consuming actions such as reading in necessary modules from secondary storage. A diagnostic message is printed if {\tt ON} \ttindex{ON} or {\tt OFF} \ttindex{OFF} are used with a switch that is not known to the system. For example, if you misspell {\tt DEMO} and type \begin{verbatim} on demq; \end{verbatim} you will get the message\index{Switch} \begin{verbatim} ***** DEMQ not defined as switch. \end{verbatim} \section{END} The identifier {\tt END} \ttindex{END} has three separate uses. 1) Its use in a {\tt BEGIN \ldots END} bracket has been discussed in connection with compound statements (q.v.). 2) Files to be read using {\tt IN} should end with an extra {\tt END}; command. The reason for this is explained in the section on the {\tt IN} command (q.v.). This use of {\tt END} does not allow an immediately preceding {\tt END} (such as the {\tt END} of a procedure definition), so we advise using {\tt ;END;} there. 3) A command {\tt END}; entered at the top level transfers control to the Lisp system\index{Lisp} which is the host of the {\REDUCE} system. All files opened by {\tt IN} or {\tt OUT} statements are closed in the process. {\tt END;} does not stop {\REDUCE}. Those familiar with Lisp can experiment with typing identifiers and ({\tt <function name> <argument list>}) lists to see the value returned by Lisp. (No terminators, other than the RETURN key, should be used.) The data structures created during the {\REDUCE} run are accessible. You remain in this Lisp mode until you explicitly re-enter {\REDUCE} by saying {\tt (BEGIN)} at the Lisp top level. In most systems, a Lisp error also returns you to {\REDUCE} (exceptions are noted in the operating instructions for your particular {\REDUCE} implementation). In either case, you will return to {\REDUCE} in the same mode, algebraic or symbolic, that you were in before the {\tt END};. If you are in Lisp mode\index{Lisp mode} by mistake -- which is usually the case, the result of typing more {\tt END}s\ttindex{END} than {\tt BEGIN}s -- type {\tt (BEGIN)} in parentheses and hit the RETURN key. \section{BYE Command}\ttindex{BYE} The command {\tt BYE}; stops the execution of {\REDUCE}, closes all open output files, and returns you to the computer system monitor program. Where the implementation permits it, your {\REDUCE} session is destroyed. If you wish to return later to that session, use {\tt QUIT}; instead. \section{QUIT Command}\ttindex{QUIT} The command {\tt QUIT}; stops the execution of {\REDUCE} and returns you to the computer system monitor program. Where the implementation permits it, your {\REDUCE} session is retained so that you can use it again later. Please refer to the system-specific user guide to see if this option is available in your system. If you do not wish to reenter the {\REDUCE} session, use {\tt BYE}; instead. \section{SHOWTIME Command}\ttindex{SHOWTIME} {\tt SHOWTIME}; prints the elapsed time since the last call of this command or, on its first call, since the current {\REDUCE} session began. The time is normally given in milliseconds and gives the time as measured by a system clock. The operations covered by this measure are system dependent. \section{DEFINE Command} The command {\tt DEFINE} \ttindex{DEFINE} allows a user to supply a new name for any identifier or replace it by any well-formed expression. Its argument is a list of expressions of the form \begin{verbatim} <identifier> = <number>|<identifier>|<operator>| <reserved word>|<expression> \end{verbatim} {\it Example:} \begin{verbatim} define be==,x=y+z; \end{verbatim} means that {\tt BE} will be interpreted as an equal sign, and {\tt X} as the expression {\tt y+z} from then on. This renaming is done at parse time, and therefore takes precedence over any other replacement declared for the same identifier. It stays in effect until the end of the {\REDUCE} run. The identifiers {\tt ALGEBRAIC} and {\tt SYMBOLIC} have properties which prevent {\tt DEFINE} \ttindex{DEFINE} from being used on them. To define {\tt ALG} to be a synonym for {\tt ALGEBRAIC}, the more complicated construction \begin{verbatim} put('alg,'newnam,'algebraic); \end{verbatim} must be used. \chapter{Built-in Prefix Operators} In the following subsections are descriptions of the most useful prefix \index{Prefix} operators built into {\REDUCE} that are not defined in other sections (such as substitution operators). Some are fully defined internally as procedures; others are more nearly abstract operators, with only some of their properties known to the system. In many cases, an operator is described by a prototypical header line as follows. Each formal parameter is given a name and followed by its allowed type. The names of classes referred to in the definition are printed in lower case, and parameter names in upper case. If a parameter type is not commonly used, it may be a specific set enclosed in brackets {\tt \{} \ldots {\tt \}}. Operators which accept formal parameter lists of arbitrary length have the parameter and type class enclosed in square brackets indicating that zero or more occurrences of that argument are permitted. Optional parameters and their type classes are enclosed in angle brackets. \section{Numerical Operators}\index{Numerical operator} {\REDUCE} includes a number of functions that are analogs of those found in most numerical systems. With numerical arguments, such functions return the expected result. However, they may also be called with non-numeric arguments. In such cases, except where noted, the system attempts to simplify the expression as far as it can. In such cases, a residual expression involving the original operator usually remains. These operators are as follows: \subsection{ABS} {\tt ABS} \ttindex{ABS} returns the absolute value of its single argument, if that argument has a numerical value. A non-numeric argument is returned as an absolute value, with an overall numeric coefficient taken outside the absolute value operator. For example: \begin{verbatim} abs(-3/4) -> 3/4 abs(2a) -> 2*ABS(A) abs(i) -> 1 abs(-x) -> ABS(X) \end{verbatim} \subsection{CEILING} \ttindex{CEILING} This operator returns the ceiling (i.e., the least integer greater than the given argument) if its single argument has a numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} ceiling(-5/4) -> -1 ceiling(-a) -> CEILING(-A) \end{verbatim} \subsection{CONJ} \ttindex{CONJ} This returns the complex conjugate of an expression, if that argument has an numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} conj(1+i) -> 1-I conj(a+i*b) -> REPART(A) - REPART(B)*I - IMPART(A)*I - IMPART(B) \end{verbatim} \subsection{FACTORIAL} \ttindex{FACTORIAL} If the single argument of {\tt FACTORIAL} evaluates to a non-negative integer, its factorial is returned. Otherwise an expression involving {\tt FACTORIAL} is returned. For example: \begin{verbatim} factorial(5) -> 120 factorial(a) -> FACTORIAL(A) \end{verbatim} \subsection{FIX} \ttindex{FIX} This operator returns the fixed value (i.e., the integer part of the given argument) if its single argument has a numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} fix(-5/4) -> -1 fix(a) -> FIX(A) \end{verbatim} \subsection{FLOOR} \ttindex{FLOOR} This operator returns the floor (i.e., the greatest integer less than the given argument) if its single argument has a numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} floor(-5/4) -> -2 floor(a) -> FLOOR(A) \end{verbatim} \subsection{IMPART} \ttindex{IMPART} This operator returns the imaginary part of an expression, if that argument has an numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} impart(1+i) -> 1 impart(a+i*b) -> REPART(B) + IMPART(A) \end{verbatim} \subsection{MAX/MIN} {\tt MAX} and {\tt MIN} \ttindex{MAX} \ttindex{MIN} can take an arbitrary number of expressions as their arguments. If all arguments evaluate to numerical values, the maximum or minimum of the argument list is returned. If any argument is non-numeric, an appropriately reduced expression is returned. For example: \begin{verbatim} max(2,-3,4,5) -> 5 min(2,-2) -> -2. max(a,2,3) -> MAX(A,3) min(x) -> X \end{verbatim} {\tt MAX} or {\tt MIN} of an empty list returns 0. \subsection{NEXTPRIME} \ttindex{NEXTPRIME} {\tt NEXTPRIME} returns the next prime greater than its integer argument. A type error occurs in this case if the value of the argument is not an integer. For example: \begin{verbatim} nextprime(5) -> 7 nextprime(-2) -> 2 nextprime(-7) -> -5 \end{verbatim} whereas {\tt nextprime(a)} gives a type error. \subsection{REPART} \ttindex{REPART} This returns the real part of an expression, if that argument has an numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} repart(1+i) -> 1 repart(a+i*b) -> REPART(A) - IMPART(B) \end{verbatim} \subsection{ROUND} \ttindex{ROUND} This operator returns the rounded value (i.e, the nearest integer) of its single argument if that argument has a numerical value. A non-numeric argument is returned as an expression in the original operator. For example: \begin{verbatim} round(-5/4) -> -1 round(a) -> ROUND(A) \end{verbatim} \section{Mathematical Functions} {\REDUCE} knows that the following represent mathematical functions \index{Mathematical function} that can take arbitrary scalar expressions as their single argument: \begin{verbatim} ACOS ACOSD ACOSH ACOT ACOTD ACOTH ACSC ACSCD ACSCH ASEC ASECD ASECH ASIN ASIND ASINH ATAN ATAND ATANH ATAN2 ATAN2D CBRT COS COSD COSH COT COTD COTH CSC CSCD CSCH DILOG EXP EXPINT HYPOT LN LOG LOGB LOG10 SEC SECD SECH SIN SIND SINH SQRT TAN TAND TANH \end{verbatim} \ttindex{ACOS} \ttindex{ACOSD} \ttindex{ACOSH} \ttindex{ACOT} \ttindex{ACOTD} \ttindex{ACOTH} \ttindex{ACSC} \ttindex{ACSCD} \ttindex{ACSCH} \ttindex{ASEC} \ttindex{ASECD} \ttindex{ASECH} \ttindex{ASIN} \ttindex{ASIND} \ttindex{ASINH} \ttindex{ATAN} \ttindex{ATAND} \ttindex{ATANH} \ttindex{ATAN2} \ttindex{ATAN2D} \ttindex{CBRT} \ttindex{COS} \ttindex{COSD} \ttindex{COSH} \ttindex{COT} \ttindex{COTD} \ttindex{COTH} \ttindex{CSC} \ttindex{CSCD} \ttindex{CSCH} \ttindex{DILOG} \ttindex{EXP} \ttindex{EXPINT} \ttindex{HYPOT} \ttindex{LN} \ttindex{LOG} \ttindex{LOGB} \ttindex{LOG10} \ttindex{SEC} \ttindex{SECD} \ttindex{SECH} \ttindex{SIN} \ttindex{SIND} \ttindex{SINH} \ttindex{SQRT} \ttindex{TAN} \ttindex{TAND} \ttindex{TANH} where {\tt LOG} is the natural logarithm (and equivalent to {\tt LN}), and {\tt LOGB} has two arguments of which the second is the logarithmic base. However, {\REDUCE} only knows the most elementary identities and properties of these functions (except in {\tt on rounded} mode (q.v.)). For example: \begin{verbatim} cos(-x) = cos(x) sin(-x) = - sin (x) cos(n*pi) = (-1)^n sin(n*pi) = 0 log(e) = 1 e^(i*pi/2) = i log(1) = 0 e^(i*pi) = -1 log(e^x) = x e^(3*i*pi/2) = -i \end{verbatim} The derivatives of these functions are also known to the system. % With the default system switch settings, the argument of a square root is % first simplified, and any divisors of the expression that are perfect % squares taken outside the square root argument. The remaining expression % is left under the square root. However, if the switch {\tt REDUCED} % \ttindex{REDUCED} is on, % multiplicative factors in the argument of the square root are also % separated, becoming individual square roots. Thus with {\tt REDUCED} off, % the expression % \begin{verbatim} % sqrt(-8*a^2*b) % \end{verbatim} % would become % \begin{verbatim} % 2*a*sqrt(-2*b) , % \end{verbatim} % whereas with {\tt REDUCED} on, it would become % \begin{verbatim} % 2*a*i*sqrt(2)*sqrt(b) . % \end{verbatim} % The switch {\tt REDUCED} \ttindex{REDUCED} also applies to other rational % powers in addition to square roots. % Note that such simplifications can cause trouble if {\tt A} is eventually % given a value which is a negative number. If it is important that the % positive property of the square root always be preserved, the switch % {\tt PRECISE} \ttindex{PRECISE} can be set on. This causes any % non-numerical factors taken out of surds to be represented by their % absolute value form. % With both {\tt REDUCED} and {\tt PRECISE} on then, the above example would % become % \begin{verbatim} % 2*i*abs(a)*sqrt(2)*sqrt(b) . % \end{verbatim} The user can add further rules for the reduction of expressions involving these operators by using the {\tt LET} \ttindex{LET} command (q.v.). The square root function can be input using the name {\tt SQRT}, or the power operation {\tt \^{ }(1/2)}. On output, unsimplified square roots are normally represented by the operator {\tt SQRT} rather than a fractional power. The statement that {\REDUCE} knows very little about these functions applies only in the mathematically exact {\tt off rounded} mode. If {\tt ROUNDED} \ttindex{ROUNDED} is on, any of the functions \begin{verbatim} ACOS ACOSD ACOSH ACOT ACOTD ACOTH ACSC ACSCD ACSCH ASEC ASECD ASECH ASIN ASIND ASINH ATAN ATAND ATANH ATAN2 ATAN2D CBRT COS COSD COSH COT COTD COTH CSC CSCD CSCH EXP HYPOT LN LOG LOGB LOG10 SEC SECD SECH SIN SIND SINH SQRT TAN TAND TANH \end{verbatim} \ttindex{ACOS} \ttindex{ACOSD} \ttindex{ACOSH} \ttindex{ACOT} \ttindex{ACOTD} \ttindex{ACOTH} \ttindex{ACSC} \ttindex{ACSCD} \ttindex{ACSCH} \ttindex{ASEC} \ttindex{ASECD} \ttindex{ASECH} \ttindex{ASIN} \ttindex{ASIND} \ttindex{ASINH} \ttindex{ATAN} \ttindex{ATAND} \ttindex{ATANH} \ttindex{ATAN2} \ttindex{ATAN2D} \ttindex{CBRT} \ttindex{COS} \ttindex{COSD} \ttindex{COSH} \ttindex{COT} \ttindex{COTD} \ttindex{COTH} \ttindex{CSC} \ttindex{CSCD} \ttindex{CSCH} \ttindex{EXP} \ttindex{HYPOT} \ttindex{LN} \ttindex{LOG} \ttindex{LOGB} \ttindex{LOG10} \ttindex{SEC} \ttindex{SECD} \ttindex{SECH} \ttindex{SIN} \ttindex{SIND} \ttindex{SINH} \ttindex{SQRT} \ttindex{TAN} \ttindex{TAND} \ttindex{TANH} when given a numeric argument has its value calculated to the current degree of floating point precision. In addition, real (non-integer valued) powers of numbers will also be evaluated. If the {\tt COMPLEX} switch is turned on in addition to {\tt ROUNDED}, these functions will also calculate a real or complex result, again to the current degree of floating point precision, if given complex arguments. For example, with {\tt on rounded,complex;} \begin{verbatim} 2.3^(5.6i) -> -0.0480793490914 - 0.998843519372*I cos(2+3i) -> -4.18962569097 - 9.10922789376*I \end{verbatim} \section{DF Operator} The operator {\tt DF} \ttindex{DF} is used to represent partial differentiation \index{Differentiation} with respect to one or more variables. It is used with the syntax: \begin{verbatim} DF(EXPRN:algebraic[,VAR:kernel<,NUM:integer>]):algebraic. \end{verbatim} The first argument is the expression to be differentiated. The remaining arguments specify the differentiation variables and the number of times they are applied. The number {\tt NUM} may be omitted if it is 1. For example, \begin{quote} \begin{tabbing} {\tt df(y,x)} \hspace{1in} \= = $\partial y/\partial x$ \\ {\tt df(y,x,2)} \> = $\partial^{2}y/\partial x^{2}$ \\ {\tt df(y,x1,2,x2,x3,2)} \> = $\partial^{5}y/\partial x_{1}^{2} \ \partial x_{2}\partial x_{3}^{2}.$ \end{tabbing} \end{quote} The evaluation of {\tt df(y,x)} proceeds as follows: first, the values of {\tt Y} and {\tt X} are found. Let us assume that {\tt X} has no assigned value, so its value is {\tt X}. Each term or other part of the value of {\tt Y} which contains the variable {\tt X} is differentiated by the standard rules. If {\tt Z} is another variable, not {\tt X} itself, then its derivative with respect to {\tt X} is taken to be 0, unless {\tt Z} has previously been declared to {\tt DEPEND} (q.v.) on {\tt X}, in which case the derivative is reported as the symbol {\tt df(z,x)}. \subsection{Adding Differentiation Rules} The {\tt LET} \ttindex{LET} statement (q.v.) can be used to introduce rules for differentiation of user-defined operators. Its general form is \begin{verbatim} FOR ALL <var1>,...,<varn> LET DF(<operator><varlist>,<vari>)=<expression> \end{verbatim} where {\tt <varlist>} ::= ({\tt <var1>},\dots,{\tt <varn>}), and {\tt <var1>},...,{\tt <varn>} are the dummy variable arguments of {\tt <operator>}. An analogous form applies to infix operators. {\it Examples:} \begin{verbatim} for all x let df(tan x,x)= 1 + tan(x)^2; \end{verbatim} (This is how the tan differentiation rule appears in the {\REDUCE} source.) \begin{verbatim} for all x,y let df(f(x,y),x)=2*f(x,y), df(f(x,y),y)=x*f(x,y); \end{verbatim} Notice that all dummy arguments of the relevant operator must be declared arbitrary by the {\tt FOR ALL} command, and that rules may be supplied for operators with any number of arguments. If no differentiation rule appears for an argument in an operator, the differentiation routines will return as result an expression in terms of {\tt DF} \ttindex{DF}. For example, if the rule for the differentiation with respect to the second argument of {\tt F} is not supplied, the evaluation of {\tt df(f(x,z),z)} would leave this expression unchanged. (No {\tt DEPEND} declaration (q.v.) is needed here, since {\tt f(x,z)} obviously ``depends on" {\tt Z}.) Once such a rule has been defined for a given operator, any future differentiation\index{Differentiation} rules for that operator must be defined with the same number of arguments for that operator, otherwise we get the error message \begin{verbatim} Incompatible DF rule argument length for <operator> \end{verbatim} \section{INT Operator} {\tt INT} \ttindex{INT} is an operator in {\REDUCE} for indefinite integration \index{Integration} \index{Indefinite integration} using a combination of the Risch-Norman algorithm and pattern matching. It is used with the syntax: \begin{verbatim} INT(EXPRN:algebraic,VAR:kernel):algebraic. \end{verbatim} This will return correctly the indefinite integral for expressions comprising polynomials, log functions, exponential functions and tan and atan. The arbitrary constant is not represented. If the integral cannot be done in closed terms, it returns a formal integral for the answer in one of two ways: \begin{enumerate} \item It returns the input, {\tt INT(\ldots,\ldots)} unchanged. \item It returns an expression involving {\tt INT}s of some other functions (sometimes more complicated than the original one, unfortunately). \end{enumerate} Rational functions can be integrated when the denominator is factorizable by the program. In addition it will attempt to integrate expressions involving error functions, dilogarithms and other trigonometric expressions. In these cases it might not always succeed in finding the solution, even if one exists. {\it Examples:} \begin{verbatim} int(log(x),x) -> X*(LOG(X) - 1), int(e^x,x) -> E**X. \end{verbatim} The program checks that the variable supplied is a variable and gives an error if it is not. \subsection{Options} The switch {\tt TRINT} when on will trace the operation of the algorithm. It produces a great deal of output in a somewhat illegible form, and is not of much interest to the general user. It is normally off. If the switch {\tt FAILHARD} is on the algorithm will terminate with an error if the integral cannot be done in closed terms, rather than return a formal integration form. {\tt FAILHARD} is normally off. The switch {\tt NOLNR} suppresses the use of the linear properties of integration in cases when the integral cannot be found in closed terms. It is normally off. \subsection{Advanced Use} If a function appears in the integrand which is not one of the functions {\tt EXP, ERF, TAN, ATAN, LOG, DILOG} then the algorithm will make an attempt to integrate the argument if it can, differentiate it and reach a known function. However the answer cannot be guaranteed in this case. If a function is known to be algebraically independent of this set it can be flagged transcendental by \begin{verbatim} flag('(trilog),'transcendental); \end{verbatim} in which case this function will be added to the permitted field descriptors for a genuine decision procedure. If this is done the user is responsible for the mathematical correctness of his actions. The standard version does not deal with algebraic extensions. Thus integration of expressions involving square roots and other like things can lead to trouble. A contributed package that supports integration of functions involving square roots is available, however. This is distributed with most versions of {\REDUCE}. \subsection{References} A. C. Norman \& P. M. A. Moore, ``Implementing the New Risch Algorithm", Proc. 4th International Symposium on Advanced Comp. Methods in Theor. Phys., CNRS, Marseilles, 1977. S. J. Harrington, ``A New Symbolic Integration System in Reduce", Comp. Journ. 22 (1979) 2. A. C. Norman \& J. H. Davenport, ``Symbolic Integration --- The Dust Settles?", Proc. EUROSAM 79, Lecture Notes in Computer Science 72, Springer-Verlag, Berlin Heidelberg New York (1979) 398-407. %\subsection{Definite Integration} \index{Definite integration} % %If {\tt INT} is used with the syntax % %\begin{verbatim} % INT(EXPRN:algebraic,VAR:kernel,LOWER:algebraic,UPPER:algebraic):algebraic. %\end{verbatim} % %The definite integral of {\tt EXPRN} with respect to {\tt VAR} is %calculated between the limits {\tt LOWER} and {\tt UPPER}. In the present %system, this is calculated either by pattern matching, or by first finding %the indefinite integral, and then substituting the limits into this. \section{LENGTH Operator} {\tt LENGTH} \ttindex{LENGTH} is a generic operator for finding the length of various objects in the system. The meaning depends on the type of the object. In particular, the length of an algebraic expression is the number of additive top-level terms its expanded representation. {\it Examples:} \begin{verbatim} length(a+b) -> 2 length(2) -> 1. \end{verbatim} Other objects that support a length operator include arrays, lists and matrices. The explicit meaning in these cases is included in the description of these objects. \section{MKID Operator}\ttindex{MKID} In many applications, it is useful to create a set of identifiers for naming objects in a consistent manner. In most cases, it is sufficient to create such names from two components. The operator {\tt MKID} is provided for this purpose. Its syntax is: \begin{verbatim} MKID(U:id,V:id|non-negative integer):id \end{verbatim} for example \begin{verbatim} mkid(a,3) -> A3 mkid(apple,s) -> APPLES \end{verbatim} while {\tt mkid(a+b,2)} gives an error. \section{PF Operator} \ttindex{PF} {\tt PF(<exp>,<var>)} transforms the expression {\tt <exp>} into a list of partial fractions with respect to the main variable, {\tt <var>}. {\tt PF} does a complete partial fraction decomposition, and as the algorithms used are fairly unsophisticated (factorization and the extended Euclidean algorithm), the code may be unacceptably slow in complicated cases. {\it Example:} Given {\tt 2/((x+1)\^{ }2*(x+2))} in the workspace, {\tt pf(ws,x);} gives the result \begin{verbatim} 2 - 2 2 {-------,-------,--------------} . X + 2 X + 1 2 X + 2*X + 1 \end{verbatim} If you want the denominators in factored form, use {\tt off exp;}. Thus, with {\tt 2/((x+1)\^{ }2*(x+2))} in the workspace, the commands {\tt off exp; pf(ws,x);} give the result \begin{verbatim} 2 - 2 2 {-------,-------,----------} . X + 2 X + 1 2 (X + 1) \end{verbatim} To recombine the terms, {\tt FOR EACH \ldots SUM} can be used. So with the above list in the workspace, {\tt for each j in ws sum j;} returns the result \begin{verbatim} 2 ------------------ 2 (X + 2)*(X + 1) \end{verbatim} Alternatively, one can use the operations on lists to extract any desired term. \section{SOLVE Operator}\ttindex{SOLVE} SOLVE is an operator for solving one or more simultaneous algebraic equations. It is used with the syntax: \begin{verbatim} SOLVE(EXPRN:algebraic[,VAR:kernel|,VARLIST:list of kernels]) :integer. \end{verbatim} {\tt EXPRN} is of the form {\tt <expression>} or \{ {\tt <expression1>},{\tt <expression2>}, \dots \}. Each expression is an algebraic equation, or is the difference of the two sides of the equation. The second argument is either a kernel or a list of kernels representing the unknowns in the system. This argument may be omitted if the number of distinct top-level kernels equals the number of unknowns, in which case these kernels are presumed to be the unknowns. Non-linear equations are solved using the Groebner basis package (q.v.). \index{Groebner} Users should note that this can be quite a time consuming process. {\it Examples:} \begin{verbatim} solve(log(sin(x+3))^5 = 8,x); solve(a*log(sin(x+3))^5 - b, sin(x+3)); solve({a*x+y=3,y=-2},{x,y}); \end{verbatim} {\tt SOLVE} returns a list of solutions. If there is one unknown, each solution is an equation for the unknown. If a complete solution was found, the unknown will appear by itself on the left-hand side of the equation. On the other hand, if the solve package could not find a solution, the ``solution" will be an equation for the unknown. If there are several unknowns, each solution will be a list of equations for the unknowns. For example, \begin{verbatim} solve(x^2=1,x); -> {X=-1,X=1} solve(x^7-x^6+x^2=1,x) -> {X**6+X+1=0,X=1} solve({x+3y=7,y-x=1},{x,y}) -> {{X=1,Y=2}}. \end{verbatim} Solution multiplicities are stored in the global variable {\tt MULTIPLICITIES!*} rather than the solution list. The value of this variable is a list of the multiplicities of the solutions for the last call of {\tt SOLVE}. \ttindex{SOLVE} For example, \begin{verbatim} solve(x^2=2x-1,x); multiplicities!*; \end{verbatim} gives the results \begin{verbatim} {X=1} {2} \end{verbatim} If you want the multiplicities explicitly displayed, the switch {\tt MULTIPLICITIES} \ttindex{MULTIPLICITIES} can be turned on. For example \begin{verbatim} on multiplicities; solve(x^2=2x-1,x); \end{verbatim} yields the result \begin{verbatim} {X=1,X=1} \end{verbatim} For one equation, {\tt SOLVE} \ttindex{SOLVE} recursively uses factorization and decomposition, together with the known inverses of {\tt LOG}, {\tt SIN}, {\tt COS}, {\tt \^{ }}, {\tt ACOS}, {\tt ASIN}, and linear, quadratic, cubic, quartic, or binomial factors. For simultaneous linear equations, the built-in matrix equation solvers are used, {\tt SOLVE} merely providing a convenient form of input for small or sparse systems. \subsection{Options} If {\tt SOLVESINGULAR} \ttindex{SOLVESINGULAR} is on (the default setting), degenerate systems such as {\tt x+y=0,2x+2y=0} will be solved by introducing appropriate arbitrary constants. The consistent singular equation 0=0 or equations involving functions with multiple inverses may introduce unique new indeterminant kernels {\tt ARBCOMPLEX(j)}, {\tt ARBREAL(j)}, or {\tt ARBINT(j)}, ($j$=1,2,...), representing arbitrary complex, real or integer numbers respectively. To automatically select the principal branches, do {\tt off allbranch;} . \ttindex{ALLBRANCH} To suppress solutions of consistent singular equations do {\tt OFF SOLVESINGULAR}. To incorporate additional inverse functions do, for example: \begin{verbatim} put('sinh,'inverse,'asinh); put('asinh,'inverse,'sinh); \end{verbatim} together with any desired simplification rules such as \begin{verbatim} for all x let sinh(asinh(x))=x, asinh(sinh(x))=x; \end{verbatim} For completeness, functions with non-unique inverses should be treated as {\tt \^{ }}, {\tt SIN}, and {\tt COS} are in the {\tt SOLVE} \ttindex{SOLVE} module source. Arguments of {\tt ASIN} and {\tt ACOS} are not checked to insure that the absolute value of the real part does not exceed 1; and arguments of {\tt LOG} are not checked to insure that the absolute value of the imaginary part does not exceed $\pi$; but checks (perhaps involving user response for non-numerical arguments) could be introduced using {\tt LET} \ttindex{LET} statements for these operators. Users should also note that even though the solve package can find exact solutions for cubics and quartics, the results in most cases are so intractable that it is better to look for another method of solution. \section{Linear Operators}\index{Linear operator} An operator can be declared to be linear in its first argument over powers of its second argument. If an operator {\tt F} is so declared, {\tt F} of any sum is broken up into sums of {\tt F}s, and any factors which are not powers of the variable are taken outside. This means that {\tt F} must have (at least) two arguments. In addition, the second argument must be an identifier (or more generally a kernel), not an expression. {\it Example:} If {\tt F} were declared linear, then \begin{verbatim} 5 f(a*x^5+b*x+c,x) -> F(X ,X)*A + F(X,X)*B + F(1,X)*C \end{verbatim} More precisely, not only will the variable and its powers remain within the scope of the {\tt F} operator, but so will any variable and its powers which had been declared to {\tt DEPEND} (q.v.) on the prescribed variable; and so would any expression which contains that variable or a dependent variable on any level, e.g. {\tt cos(sin(x))}. To declare operators {\tt F} and {\tt G} to be linear operators, use:\ttindex{LINEAR} \begin{verbatim} linear f,g; \end{verbatim} The analysis is done of the first argument with respect to the second; any other arguments are ignored. It uses the following rules of evaluation: \begin{quote} \begin{tabbing} {\tt f(0) -> 0} \\ {\tt f(-y,x) -> -F(Y,X)} \\ {\tt f(y+z,x) -> F(Y,X)+F(Z,X)} \\ {\tt f(y*z,x) -> Z*F(Y,X)} \hspace{0.5in}\= if Z does not depend on X \\ {\tt f(y/z,x) -> F(Y,X)/Z} \> if Z does not depend on X \end{tabbing} \end{quote} To summarize, {\tt Y} ``depends" on the indeterminate {\tt X} in the above if either of the following hold: \begin{enumerate} \item {\tt Y} is an expression which contains {\tt X} at any level as a variable, e.g.: {\tt cos(sin(x))} \item Any variable in the expression {\tt Y} has been declared dependent on {\tt X} by use of the declaration {\tt DEPEND} (q.v.). \end{enumerate} The use of such linear operators\index{Linear operator} can be seen in the paper Fox, J.A. and A. C. Hearn, ``Analytic Computation of Some Integrals in Fourth Order Quantum Electrodynamics" Journ. Comp. Phys. 14 (1974) 301-317, which contains a complete listing of a program for definite integration\index{Integration} of some expressions which arise in fourth order quantum electrodynamics. \section{Non-Commuting Operators}\index{Non-commuting operator} An operator can be declared to be non-commutative under multiplication by the declaration {\tt NONCOM} \ttindex{NONCOM}. {\it Example:} After the declaration {\tt noncom u,v;}, the expressions {\tt u(x)*u(y)-u(y)*u(x)} and {\tt u(x)*v(y)-v(y)*u(x)} will remain unchanged on simplification, and in particular will not simplify to zero. Note that it is the operator ({\tt U} and {\tt V} in the above example) and not the variable that has the non-commutative property. The {\tt LET} \ttindex{LET} statement may be used to introduce rules of evaluation for such operators. In particular, the boolean operator {\tt ORDP}\ttindex{ORDP} is useful for introducing an ordering on such expressions. {\it Example:} The rule \begin{verbatim} for all x,y such that x neq y and ordp(x,y) let u(x)*u(y)= u(y)*u(x)+comm(x,y); \end{verbatim} would introduce the commutator of {\tt u(x)} and {\tt u(y)} for all {\tt X} and {\tt Y}. Note that since {\tt ordp(x,x)} is {\em true}, the equality check is necessary in the degenerate case to avoid a circular loop in the rule. \section{Symmetric and Antisymmetric Operators} An operator can be declared to be symmetric with respect to its arguments by the declaration {\tt SYMMETRIC}. \ttindex{SYMMETRIC} For example \begin{verbatim} symmetric u,v; \end{verbatim} means that any expression involving the top level operators {\tt U} or {\tt V} will have its arguments reordered to conform to the internal order used by {\REDUCE}. The user can change this order for kernels by the command {\tt KORDER} (q.v.). For example, {\tt u(x,v(1,2))} would become {\tt u(v(2,1),x)}, since numbers are ordered in decreasing order, and expressions are ordered in decreasing order of complexity. An operator can similarly be declared antisymmetric by the declaration {\tt ANTISYMMETRIC}. \ttindex{ANTISYMMETRIC} For example, \begin{verbatim} antisymmetric l,m; \end{verbatim} means that any expression involving the top level operators {\tt L} or {\tt M} will have its arguments reordered to conform to the internal order of the system, and the sign of the expression changed if there are an odd number of argument interchanges necessary to bring about the new order. For example, {\tt l(x,m(1,2))} would become {\tt -l(-m(2,1),x)} since one interchange occurs with each operator. An expression like {\tt l(x,x)} would also be replaced by 0. \section{Declaring New Prefix Operators} The user may add new prefix\index{Prefix} operators to the system by using the declaration {\tt OPERATOR}. For example: \begin{verbatim} operator h,g1,arctan; \end{verbatim} adds the prefix operators {\tt H}, {\tt G1} and {\tt ARCTAN} to the system. This allows symbols like {\tt h(w), h(x,y,z), g1(p+q), arctan(u/v)} to be used in expressions, but no meaning or properties of the operator are implied. The same operator symbol can be used equally well as a 1-, 2-, 3-, etc.-place operator. To give a meaning to an operator symbol, or express some of its properties, {\tt LET} \ttindex{LET} statements can be used, or the operator can be given a definition as a procedure (q.v.). If the user forgets to declare an identifier as an operator, the system will prompt the user to do so in interactive mode, or do it automatically in non-interactive mode. A diagnostic message will also be printed if an identifier is declared {\tt OPERATOR} more than once. Operators once declared are global in scope, and so can then be referenced anywhere in the program. In other words, a declaration within a block (or a procedure) does not limit the scope of the operator to that block, nor does the operator go away on exiting the block (use {\tt CLEAR} instead for this purpose). \section{Declaring New Infix Operators} Users can add new infix operators by using the declarations {\tt INFIX} \ttindex{INFIX} and {\tt PRECEDENCE}. \ttindex{PRECEDENCE} For example, \begin{verbatim} infix mm; precedence mm,-; \end{verbatim} The declaration {\tt infix mm;} would allow one to use the symbol {\tt MM} as an infix operator: \begin{quote} \hspace{0.2in} {\tt a mm b} \hspace{0.3in} instead of \hspace{0.3in} {\tt mm(a,b)}. \end{quote} The declaration {\tt precedence mm,-;} says that {\tt MM} should be inserted into the infix operator precedence list (q.v.) just {\em after} the - operator. This gives it higher precedence than - and lower precedence than * . Thus \begin{quote} \hspace{0.2in}{\tt a - b mm c - d}\hspace{.3in} means \hspace{.3in} {\tt a - (b mm c) - d}, \end{quote} while \begin{quote} \hspace{0.2in}{\tt a * b mm c * d}\hspace{.3in} means \hspace{.3in} {\tt (a * b) mm (c * d)}. \end{quote} Both infix and prefix\index{Prefix} operators have no transformation properties unless {\tt LET} \ttindex{LET} statements or procedure declarations are used to assign a meaning. We should note here that infix operators so defined are always binary: \begin{quote} \hspace{0.2in}{\tt a mm b mm c}\hspace{.3in} means \hspace{.3in} {\tt (a mm b) mm c}. \end{quote} \section{Creating or Removing Variable Dependency} There are several facilities in {\REDUCE}, such as the differentiation \index{Differentiation} operator and the linear operator\index{Linear operator} facility, which can utilize knowledge of the dependency between various variables, or kernels (q.v.). Such dependency may be expressed by the command {\tt DEPEND}. \ttindex{DEPEND} This takes an arbitrary number of arguments and sets up a dependency of the first argument on the remaining arguments. For example, \begin{verbatim} depend x,y,z; \end{verbatim} says that {\tt X} is dependent on both {\tt Y} and {\tt Z}. \begin{verbatim} depend z,cos(x),y; \end{verbatim} says that {\tt Z} is dependent on {\tt COS(X)} and {\tt Y}. Dependencies introduced by {\tt DEPEND} can be removed by {\tt NODEPEND}. \ttindex{NODEPEND} The arguments of this are the same as for {\tt DEPEND}. For example, given the above dependencies, \begin{verbatim} nodepend z,cos(x); \end{verbatim} says that {\tt Z} is no longer dependent on {\tt COS(X)}, although it remains dependent on {\tt Y}. \chapter{Display and Structuring of Expressions}\index{Display} \index{Structuring} In this section, we consider a variety of commands and operators which permit the user to obtain various parts of algebraic expressions and also display their structure in a variety of forms. Also presented are some additional concepts in the {\REDUCE} design that help the user gain a better understanding of the structure of the system. \section{Kernels}\index{Kernel} {\REDUCE} is designed so that each operator in the system has an evaluation (or simplification)\index{Simplification} function associated with it which transforms the expression into an internal canonical form. \index{Canonical form} This form, which bears little resemblance to the original expression, is described in detail in Hearn, A. C., ``{\REDUCE} 2: A System and Language for Algebraic Manipulation," Proc. of the Second Symposium on Symbolic and Algebraic Manipulation, ACM, New York (1971) 128-133. The evaluation function may transform its arguments in one of two alternative ways. First, it may convert the expression into other operators in the system, leaving no functions of the original operator for further manipulation. This is in a sense true of the evaluation functions associated with the operators {\tt +}, {\tt *} and {\tt /} , for example, because the canonical form\index{Canonical form} does not include these operators explicitly. It is also true of an operator such as the determinant operator {\tt DET} \ttindex{DET} (q.v.) because the relevant evaluation function calculates the appropriate determinant, and the operator {\tt DET} no longer appears. On the other hand, the evaluation process may leave some residual functions of the relevant operator. For example, with the operator {\tt COS}, a residual expression like {\tt COS(X)} may remain after evaluation unless a rule for the reduction of cosines into exponentials, for example, were introduced. These residual functions of an operator are termed {\em kernels}\index{Kernel} and are stored uniquely like variables. Subsequently, the kernel is carried through the calculation as a variable unless transformations are introduced for the operator at a later stage. In those cases where the evaluation process leaves an operator expression with non-trivial arguments, the form of the argument can vary depending on the state of the system at the point of evaluation. Such arguments are normally produced in expanded form with no terms factored or grouped in any way. For example, the expression {\tt cos(2*x+2*y)} will normally be returned in the same form. If the argument {\tt 2*x+2*y} were evaluated at the top level, however, it would be printed as {\tt 2*(X+Y)}. If it is desirable to have the arguments themselves in a similar form, the switch {\tt INTSTR} \ttindex{INTSTR} (for ``internal structure"), if on, will cause this to happen. In cases where the arguments of the kernel operators may be reordered, the system puts them in a canonical order, based on an internal intrinsic ordering of the variables. However, some commands allow arguments in the form of kernels, and the user has no way of telling what internal order the system will assign to these arguments. To resolve this difficulty, we introduce the notion of a kernel form as an expression which transforms to a kernel on evaluation. Examples of kernel forms are: \begin{verbatim} a cos(x*y) log(sin(x)) \end{verbatim} whereas \begin{verbatim} a*b (a+b)^4 \end{verbatim} are not. We see that kernel forms can usually be used as generalized variables, and most algebraic properties associated with variables may also be associated with kernels. \section{The Expression Workspace}\index{Workspace} Several mechanisms are available for saving and retrieving previously evaluated expressions. The simplest of these refers to the last algebraic expression simplified. When an assignment of an algebraic expression is made, or an expression is evaluated at the top level, (i.e., not inside a compound statement or procedure) the results of the evaluation are automatically saved in a variable {\tt WS} which we shall refer to as the workspace. (More precisely, the expression is assigned to the variable {\tt WS} which is then available for further manipulation.) {\it Example:} If we evaluate the expression {\tt (x+y)\^{ }2} at the top level and next wish to differentiate it with respect to {\tt Y}, we can simply say \begin{verbatim} df(ws,y); \end{verbatim} to get the desired answer. If the user wishes to assign the workspace to a variable or expression for later use, the {\tt SAVEAS} \ttindex{SAVEAS} statement can be used. It has the syntax \begin{verbatim} SAVEAS <expression> \end{verbatim} For example, after the differentiation in the last example, the workspace holds the expression {\tt 2*x+2*y}. If we wish to assign this to the variable {\tt Z} we can now say \begin{verbatim} saveas z; \end{verbatim} If the user wishes to save the expression in a form that allows him to use some of its variables as arbitrary parameters, the {\tt FOR ALL} (q.v.) command can be used. {\it Example:} \begin{verbatim} for all x saveas h(x); \end{verbatim} with the above expression would mean that {\tt h(z)} evaluates to {\tt 2*Y+2*Z}. A further method for referencing more than the last expression is described in the section on interactive use of {\REDUCE}. \section{Output of Expressions} A considerable degree of flexibility is available in {\REDUCE} in the printing of expressions generated during calculations. No explicit format statements are supplied, as these are in most cases of little use in algebraic calculations, where the size of output or its composition is not generally known in advance. Instead, {\REDUCE} provides a series of mode options to the user which should enable him to produce his output in a comprehensible and possibly pleasing form. The most extreme option offered is to suppress the output entirely from any top level evaluation. This is accomplished by turning off the switch {\tt OUTPUT} \ttindex{OUTPUT} which is normally on. It is useful for limiting output when loading large files or producing ``clean" output from the prettyprint programs (q.v.). In most circumstances, however, we wish to view the output, so we need to know how to format it appropriately. As we mentioned earlier, an algebraic expression is normally printed in an expanded form, filling the whole output line with terms. Certain output declarations, \index{Output declaration} however, can be used to affect this format. To begin with, we look at an operator for changing the length of the output line. \subsection{LINELENGTH Operator}\ttindex{LINELENGTH} This operator is used with the syntax \begin{verbatim} LINELENGTH(NUM:integer):integer \end{verbatim} and sets the output line length to the integer {\tt NUM}. It returns the previous output line length (so that it can be stored for later resetting of the output line if needed). \subsection{Output Declarations} We now describe a number of switches and declarations which are available for controlling output formats. It should be noted, however, that the transformation of large expressions to produce these varied output formats can take a lot of computing time and space. If a user wishes to speed up the printing of the output in such cases, he can turn off the switch {\tt PRI}. \ttindex{PRI} If this is done, then output is produced in one fixed format, which basically reflects the internal form of the expression, and none of the options below apply. {\tt PRI} is normally on. With {\tt PRI} on, the output declarations\index{Output declaration} and switches available are as follows: \subsubsection{ORDER Declaration} The declaration {\tt ORDER} \ttindex{ORDER} may be used to order variables on output. The syntax is: \begin{verbatim} order v1,...vn; \end{verbatim} where the {\tt vi} are kernels (q.v.). Thus, \begin{verbatim} order x,y,z; \end{verbatim} orders {\tt X} ahead of {\tt Y}, {\tt Y} ahead of {\tt Z} and all three ahead of other variables not given an order. {\tt order nil;} resets the output order to the system default. The order of variables may be changed by further calls of {\tt ORDER}, but then the reordered variables would have an order lower than those in earlier {\tt ORDER} \ttindex{ORDER} calls. Thus, \begin{verbatim} order x,y,z; order y,x; \end{verbatim} would order {\tt Z} ahead of {\tt Y} and {\tt X}. The default ordering is implementation dependent, but is usually alphabetic. \subsubsection{FACTOR Declaration} This declaration takes a list of identifiers or kernels\index{Kernel} (q.v.) as argument. {\tt FACTOR} is not a factoring command (use {\tt FACTORIZE} or the {\tt FACTOR} switch (q.v.) for this purpose); rather it is a separation command. All terms involving fixed powers of the declared expressions are printed as a product of the fixed powers and a sum of the rest of the terms. All expressions involving a given prefix operator may also be factored by putting the operator name in the list of factored identifiers. For example: \begin{verbatim} factor x,cos,sin(x); \end{verbatim} causes all powers of {\tt X} and {\tt SIN(X)} and all functions of {\tt COS} to be factored. The declaration {\tt remfac v1,...,vn;} \ttindex{REMFAC} removes the factoring flag from the expressions {\tt v1} through {\tt vn}. \subsection{Output Control Switches} \label{sec-output} In addition to these declarations, the form of the output can be modified by switching various output control switches using the declarations {\tt ON} and {\tt OFF}. We shall illustrate the use of these switches by an example, namely the printing of the expression \begin{verbatim} x^2*(y^2+2*y)+x*(y^2+z)/(2*a) . \end{verbatim} The relevant switches are as follows: \subsubsection{ALLFAC Switch} This switch will cause the system to search the whole expression, or any sub-expression enclosed in parentheses, for simple multiplicative factors and print them outside the parentheses. Thus our expression with {\tt ALLFAC} \ttindex{ALLFAC} off will print as \begin{verbatim} 2 2 2 2 (2*X *Y *A + 4*X *Y*A + X*Y + X*Z)/(2*A) \end{verbatim} and with {\tt ALLFAC} on as \begin{verbatim} 2 2 X*(2*X*Y *A + 4*X*Y*A + Y + Z)/(2*A) . \end{verbatim} {\tt ALLFAC} is normally on, and is on in the following examples, except where otherwise stated. \subsubsection{DIV Switch}\ttindex{DIV} This switch makes the system search the denominator of an expression for simple factors which it divides into the numerator, so that rational fractions and negative powers appear in the output. With {\tt DIV} on, our expression would print as \begin{verbatim} 2 2 (-1) (-1) X*(X*Y + 2*X*Y + 1/2*Y *A + 1/2*A *Z) . \end{verbatim} {\tt DIV} is normally off. \subsubsection{LIST Switch}\ttindex{LIST} This switch causes the system to print each term in any sum on a separate line. With {\tt LIST} on, our expression prints as \begin{verbatim} 2 X*(2*X*Y *A + 4*X*Y*A 2 + Y + Z)/(2*A) . \end{verbatim} {\tt LIST} is normally off. \subsubsection{NOSPLIT Switch}\ttindex{NOSPLIT} Under normal circumstances, the printing routines try to break an expression across lines at a natural point. This is a fairly expensive process. If you are not overly concerned about where the end-of-line breaks come, you can speed up the printing of expressions by turning off the switch {\tt NOSPLIT}. This switch is normally on. \subsubsection{RAT Switch}\ttindex{RAT} This switch is only useful with expressions in which variables are factored with {\tt FACTOR}. With this mode, the overall denominator of the expression is printed with each factored sub-expression. We assume a prior declaration {\tt factor x;} in the following output. We first print the expression with {\tt RAT off}: \begin{verbatim} 2 2 (2*X *Y*A*(Y + 2) + X*(Y + Z))/(2*A) . \end{verbatim} With {\tt RAT} on the output becomes: \begin{verbatim} 2 2 X *Y*(Y + 2) + X*(Y + Z)/(2*A) . \end{verbatim} {\tt RAT} is normally off. Next, if we leave {\tt X} factored, and turn on both {\tt DIV} and {\tt RAT}, the result becomes \begin{verbatim} 2 (-1) 2 X *Y*(Y + 2) + 1/2*X*A *(Y + Z) . \end{verbatim} Finally, with {\tt X} factored, {\tt RAT} on and {\tt ALLFAC} \ttindex{ALLFAC} off we retrieve the original structure \begin{verbatim} 2 2 2 X *(Y + 2*Y) + X*(Y + Z)/(2*A) . \end{verbatim} \subsubsection{RATPRI Switch}\ttindex{RATPRI} If the numerator and denominator of an expression can each be printed in one line, the output routines will print them in a two dimensional notation, with numerator and denominator on separate lines and a line of dashes in between. For example, {\tt (a+b)/2} will print as \begin{verbatim} A + B ----- 2 \end{verbatim} Turning this switch off causes such expressions to be output in a linear form. \subsubsection{REVPRI Switch}\ttindex{REVPRI} The normal ordering of terms in output is from highest to lowest power. In some situations (e.g., when a power series is output), the opposite ordering is more convenient. The switch {\tt REVPRI} if on causes such a reverse ordering of terms. For example, the expression {\tt y*(x+1)\^{ }2+(y+3)\^{ }2} will normally print as \begin{verbatim} 2 2 X *Y + 2*X*Y + Y + 7*Y + 9 \end{verbatim} whereas with {\tt REVPRI} on, it will print as \begin{verbatim} 2 2 9 + 7*Y + Y + 2*X*Y + X *Y. \end{verbatim} \subsection{WRITE Command} \ttindex{WRITE} In simple cases no explicit output\index{Output} command is necessary in {\REDUCE}, since the value of any expression is automatically printed if a semicolon is used as a delimiter. There are, however, several situations in which such a command is useful. In a {\tt FOR}, {\tt WHILE}, or {\tt REPEAT} statement it may be desired to output something each time the statement within the loop construct is repeated. It may be desired for a procedure to output intermediate results or other information while it is running. It may be desired to have results labeled in special ways, especially if the output is directed to a file or device other than the terminal. The {\tt WRITE} command consists of the word {\tt WRITE} followed by one or more items separated by commas, and followed by a terminator. There are three kinds of items which can be used: \begin{enumerate} \item Expressions (including variables and constants). The expression is evaluated, and the result is printed out. \item Assignments. The expression on the right side of the {\tt :=} operator is evaluated, and is assigned to the variable on the left; then the symbol on the left is printed, followed by a ``{\tt :=}", followed by the value of the expression on the right -- almost exactly the way an assignment followed by a semicolon prints out normally. (The difference is that if the {\tt WRITE} is in a {\tt FOR} statement and the left-hand side of the assignment is an array position or something similar containing the variable of the {\tt FOR} iteration, then the value of that variable is inserted in the printout.) \item Arbitrary strings of characters, preceded and followed by double-quote marks (e.g., {\tt "string"}). \end{enumerate} The items specified by a single {\tt WRITE} statement print side by side on one line. (The line is broken automatically if it is too long.) Strings print exactly as quoted. The {\tt WRITE} command itself however does not return a value. The print line is closed at the end of a {\tt WRITE} command evaluation. Therefore the command {\tt WRITE "";} (specifying nothing to be printed except the empty string) causes a line to be skipped. {\it Examples:} \begin{enumerate} \item If {\tt A} is {\tt X+5}, {\tt B} is itself, {\tt C} is 123, {\tt M} is an array, and {\tt Q}=3, then \begin{verbatim} write m(q):=a," ",b/c," THANK YOU"; \end{verbatim} will set {\tt M(3)} to {\tt x+5} and print \begin{verbatim} M(Q) := X + 5 B/123 THANK YOU \end{verbatim} The blanks between the {\tt 5} and {\tt B}, and the {\tt 3} and {\tt T}, come from the blanks in the quoted strings. \item To print a table of the squares of the integers from 1 to 20: \begin{verbatim} for i:=1:20 do write i," ",i^2; \end{verbatim} \item To print a table of the squares of the integers from 1 to 20, and at the same time store them in positions 1 to 20 of an array {\tt A:} \begin{verbatim} for i:=1:20 do <<a(i):=i^2; write i," ",a(i)>>; \end{verbatim} This will give us two columns of numbers. If we had used \begin{verbatim} for i:=1:20 do write i," ",a(i):=i^2; \end{verbatim} we would also get {\tt A(}i{\tt ) := } repeated on each line. \item The following more complete example calculates the famous f and g series, first reported in Sconzo, P., LeSchack, A. R., and Tobey, R., ``Symbolic Computation of f and g Series by Computer", Astronomical Journal 70 (May 1965). \begin{verbatim} x1:= -sig*(mu+2*eps)$ x2:= eps-2*sig^2$ x3:= -3*mu*sig$ f:= 1$ g:= 0$ for i:= 1 step 1 until 10 do begin f1:= -mu*g + x1*df(f,eps) + x2*df(f,sig) + x3*df(f,mu); write "f(",i,") := ",f1; g1:= f + x1*df(g,eps) + x2*df(g,sig) + x3*df(g,mu); write "g(",i,") := ",g1; f:=f1$ g:=g1$ end; \end{verbatim} A portion of the output, to illustrate the printout from the {\tt WRITE} command, is as follows: \begin{verbatim} ... <prior output> ... 2 F(4) := MU*(3*EPS - 15*SIG + MU) G(4) := 6*SIG*MU 2 F(5) := 15*SIG*MU*( - 3*EPS + 7*SIG - MU) 2 G(5) := MU*(9*EPS - 45*SIG + MU) ... <more output> ... \end{verbatim} \end{enumerate} \subsection{Suppression of Zeros} It is sometimes annoying to have zero assignments (i.e. assignments of the form {\tt <expression> := 0}) printed, especially in printing large arrays with many zero elements. The output from such assignments can be suppressed by turning on the switch {\tt NERO}. \ttindex{NERO} \subsection{{FORTRAN} Style Output Of Expressions} It is naturally possible to evaluate expressions numerically in {\REDUCE} by giving all variables and sub-expressions numerical values. However, as we pointed out elsewhere the user must declare real arithmetical operation by turning on the switch {\tt ROUNDED}\ttindex{ROUNDED}. However, it should be remembered that arithmetic in {\REDUCE} is not particularly fast, since results are interpreted rather than evaluated in a compiled form. The user with a large amount of numerical computation after all necessary algebraic manipulations have been performed is therefore well advised to perform these calculations in a FORTRAN\index{FORTRAN} or similar system. For this purpose, {\REDUCE} offers facilities for users to produce FORTRAN compatible files for numerical processing. First, when the switch {\tt FORT} \ttindex{FORT} is on, the system will print expressions in a FORTRAN notation. Expressions begin in column seven. If an expression extends over one line, a continuation mark (.) followed by a blank appears on subsequent cards. After a certain number of lines have been produced (according to the value of the variable {\tt *CARDNO} (q.v.)), a new expression is started. If the expression printed arises from an assignment to a variable, the variable is printed as the name of the expression. Otherwise the expression is given the default name {\tt ANS}. An error occurs if identifiers or numbers are outside the bounds permitted by FORTRAN. A second option is to use the {\tt WRITE} command to produce other programs. {\it Example:} The following {\REDUCE} statements \begin{verbatim} on fort; out "forfil"; write "C THIS IS A FORTRAN PROGRAM"; write " 1 FORMAT(E13.5)"; write " U=1.23"; write " V=2.17"; write " W=5.2"; x:=(u+v+w)^11; write "C IT WAS FOOLISH TO EXPAND THIS EXPRESSION"; write " PRINT 1,X"; write " END"; shut "forfil"; off fort; \end{verbatim} will generate a file {\tt forfil} which contains: \begin{verbatim} C THIS IS A FORTRAN PROGRAM 1 FORMAT(E13.5) U=1.23 V=2.17 W=5.2 ANS1=1320.*U**3*V*W**7+165.*U**3*W**8+55.*U**2*V**9+495.*U . **2*V**8*W+1980.*U**2*V**7*W**2+4620.*U**2*V**6*W**3+ . 6930.*U**2*V**5*W**4+6930.*U**2*V**4*W**5+4620.*U**2*V**3* . W**6+1980.*U**2*V**2*W**7+495.*U**2*V*W**8+55.*U**2*W**9+ . 11.*U*V**10+110.*U*V**9*W+495.*U*V**8*W**2+1320.*U*V**7*W . **3+2310.*U*V**6*W**4+2772.*U*V**5*W**5+2310.*U*V**4*W**6 . +1320.*U*V**3*W**7+495.*U*V**2*W**8+110.*U*V*W**9+11.*U*W . **10+V**11+11.*V**10*W+55.*V**9*W**2+165.*V**8*W**3+330.* . V**7*W**4+462.*V**6*W**5+462.*V**5*W**6+330.*V**4*W**7+ . 165.*V**3*W**8+55.*V**2*W**9+11.*V*W**10+W**11 X=U**11+11.*U**10*V+11.*U**10*W+55.*U**9*V**2+110.*U**9*V* . W+55.*U**9*W**2+165.*U**8*V**3+495.*U**8*V**2*W+495.*U**8 . *V*W**2+165.*U**8*W**3+330.*U**7*V**4+1320.*U**7*V**3*W+ . 1980.*U**7*V**2*W**2+1320.*U**7*V*W**3+330.*U**7*W**4+462. . *U**6*V**5+2310.*U**6*V**4*W+4620.*U**6*V**3*W**2+4620.*U . **6*V**2*W**3+2310.*U**6*V*W**4+462.*U**6*W**5+462.*U**5* . V**6+2772.*U**5*V**5*W+6930.*U**5*V**4*W**2+9240.*U**5*V . **3*W**3+6930.*U**5*V**2*W**4+2772.*U**5*V*W**5+462.*U**5 . *W**6+330.*U**4*V**7+2310.*U**4*V**6*W+6930.*U**4*V**5*W . **2+11550.*U**4*V**4*W**3+11550.*U**4*V**3*W**4+6930.*U** . 4*V**2*W**5+2310.*U**4*V*W**6+330.*U**4*W**7+165.*U**3*V . **8+1320.*U**3*V**7*W+4620.*U**3*V**6*W**2+9240.*U**3*V** . 5*W**3+11550.*U**3*V**4*W**4+9240.*U**3*V**3*W**5+4620.*U . **3*V**2*W**6+ANS1 C IT WAS FOOLISH TO EXPAND THIS EXPRESSION PRINT 1,X END \end{verbatim} If the arguments of a {\tt WRITE} statement include an expression that requires continuation records, the output will need editing, since the output routine prints the arguments of {\tt WRITE} sequentially, and the continuation mechanism therefore generates its auxiliary variables after the preceding expression has been printed. Finally, since there is no direct analog of {\em list} in FORTRAN, a comment line of the form \begin{verbatim} C ***** INVALID FORTRAN CONSTRUCT (LIST) NOT PRINTED \end{verbatim} will be printed if you try to print a list with {\tt FORT} on. \subsubsection{{FORTRAN} Output Options}\index{Output}\index{FORTRAN} There are a number of methods available to change the default format of the FORTRAN output. The breakup of the expression into subparts is such that the number of continuation lines produced is less than a given number. This number can be modified by the assignment \begin{verbatim} cardno!* := <number>; \end{verbatim} where {\tt <number>} is the {\em total} number of cards allowed in a statement. {\tt CARDNO!*} is initially set to 20. The width of the output expression is also adjustable by the assignment \begin{verbatim} fortwidth!* := <integer>; \end{verbatim} which sets the total width of a given line to {\tt <integer>}. The initial FORTRAN output width is 70. {\REDUCE} automatically inserts a decimal point after each isolated integer coefficient in a FORTRAN expression (so that, for example, 4 becomes {\tt 4.} ). To prevent this, set the {\tt PERIOD} \ttindex{PERIOD} mode switch to {\tt OFF}. Finally, the default name {\tt ANS} assigned to an unnamed expression and its subparts can be changed by the operator {\tt VARNAME}. \ttindex{VARNAME} This takes a single identifier as argument, which then replaces {\tt ANS} as the expression name. The value of {\tt VARNAME} is its argument. Further facilities for the production of FORTRAN and other language output are provided by the SCOPE and GENTRAN packages described in the chapter on user contributed packages. \subsection{Saving Expressions for Later Use as Input} \index{Saving an expression} It is often useful to save an expression on an external file for use later as input in further calculations. The commands for opening and closing output files are explained elsewhere. However, we see in the examples on output of expressions that the standard ``natural" method of printing expressions is not compatible with the input syntax. So to print the expression in an input compatible form we must inhibit this natural style by turning off the switch {\tt NAT}. \ttindex{NAT} If this is done, a dollar sign will also be printed at the end of the expression. {\it Example:} The following sequence of commands \begin{verbatim} off nat; out "out"; x := (y+z)^2; write "end"; shut "out"; on nat; \end{verbatim} will generate a file {\tt out} which contains \begin{verbatim} X := Y**2 + 2*Y*Z + Z**2$ END$ \end{verbatim} \subsection{Displaying Expression Structure}\index{Displaying structure} In those cases where the final result has a complicated form, it is often convenient to display the skeletal structure of the answer. The operator {\tt STRUCTR},\ttindex{STRUCTR} which takes a single expression as argument, will do this for you. Its syntax is: \begin{verbatim} STRUCTR(EXPRN:algebraic[,ID1:identifier[,ID2:identifier]]); \end{verbatim} The structure is printed effectively as a tree, in which the subparts are laid out with auxiliary names. If the optional {\tt ID1} is absent, the auxiliary names are prefixed by the root {\tt ANS}. This root may be changed by the operator {\tt VARNAME} \ttindex{VARNAME} (q.v.). If the optional {\tt ID1} is present, and is an array name, the subparts are named as elements of that array, otherwise {\tt ID1} is used as the root prefix. (The second optional argument {\tt ID2} is explained later.) The {\tt EXPRN} can be either a scalar or a matrix expression. Use of any other will result in an error. {\it Example:} Let us suppose that the workspace contains {\tt ((A+B)\^{ }2+C)\^{ }3+D}. Then the input {\tt STRUCTR WS;} will (with {\tt EXP} off) result in the output: \begin{verbatim} ANS3 where 3 ANS3 := ANS2 + D 2 ANS2 := ANS1 + C ANS1 := A + B \end{verbatim} The workspace remains unchanged after this operation, since {\tt STRUCTR} \ttindex{STRUCTR} in the default situation returns no value (if {\tt STRUCTR} is used as a sub-expression, its value is taken to be 0). In addition, the sub-expressions are normally only displayed and not retained. If you wish to access the sub-expressions with their displayed names, the switch {\tt SAVESTRUCTR} \ttindex{SAVESTRUCTR} should be turned on. In this case, {\tt STRUCTR} returns a list whose first element is a representation for the expression, and subsequent elements are the sub-expression relations. Thus, with {\tt SAVESTRUCTR} on, {\tt STRUCTR WS} in the above example would return \begin{verbatim} 3 2 {ANS3,ANS3=ANS2 + D,ANS2=ANS1 + C,ANS1=A + B} \end{verbatim} Alternatively the {\tt PART} \ttindex{PART} operator (q.v.) can be used to retrieve the required parts of the expression. For example, to get the term corresponding to {\tt ANS2} in the above, one could say: \begin{verbatim} part(ws,1,1); \end{verbatim} If {\tt FORT} is on, then the results are printed in the reverse order; the algorithm in fact guaranteeing that no sub-expression will be referenced before it is defined. The second optional argument {\tt ID2} may also be used in this case to name the actual expression (or expressions in the case of a matrix argument). {\it Example:} Let us suppose that {\tt M}, a 2 by 1 matrix, contains the elements {\tt ((a+b)\^{ }2 + c)\^{ }3 + d} and {\tt (a + b)*(c + d)} respectively, and that {\tt V} has been declared to be an array. With {\tt EXP} off and {\tt FORT} on, the statement {\tt structr(2*m,v,k);} will result in the output \begin{verbatim} V(1)=A+B V(2)=V(1)**2+C V(3)=V(2)**3+D V(4)=C+D K(1,1)=2.*V(3) K(2,1)=2.*V(1)*V(4) \end{verbatim} \section{Changing the Internal Order of Variables} The internal ordering of variables (more specifically kernels) can have a significant effect on the space and time associated with a calculation. In its default state, {\REDUCE} uses a specific order for this which may vary between sessions. However, it is possible for the user to change this internal order by means of the declaration {\tt KORDER} \ttindex{KORDER}. The syntax for this is: \begin{verbatim} korder v1,...,vn; \end{verbatim} where the {\tt Vi} are kernels\index{Kernel}. With this declaration, the {\tt Vi} are ordered internally ahead of any other kernels in the system. {\tt V1} has the highest order, {\tt V2} the next highest, and so on. A further call of {\tt KORDER} replaces a previous one. {\tt KORDER NIL;} resets the internal order to the system default. Unlike the {\tt ORDER} \ttindex{ORDER} declaration (q.v.), which has a purely cosmetic effect on the way results are printed, the use of {\tt KORDER} can have a significant effect on computation time. In critical cases then, the user can experiment with the ordering of the variables used to determine the optimum set for a given problem. \section{Obtaining Parts of Algebraic Expressions} There are many occasions where it is desirable to obtain a specific part of an expression, or even change such a part to another expression. A number of operators are available in {\REDUCE} for this purpose, and will be described in this section. In addition, operators for obtaining specific parts of polynomials and rational functions (such as a denominator) are described in another section. \subsection{COEFF Operator}\ttindex{COEFF} Syntax: \begin{verbatim} COEFF(EXPRN:polynomial,VAR:kernel) \end{verbatim} {\tt COEFF} is an operator which partitions {\tt EXPRN} into its various coefficients with respect to {\tt VAR} and returns them as a list, with the coefficient independent of {\tt VAR} first. Under normal circumstances, an error results if {\tt EXPRN} is not a polynomial in {\tt VAR}, although the coefficients themselves can be rational as long as they do not depend on {\tt VAR}. However, if the switch {\tt RATARG} \ttindex{RATARG} is on, denominators are not checked for dependence on {\tt VAR}, and are taken to be part of the coefficients. {\it Example:} \begin{verbatim} coeff((y^2+z)^3/z,y); \end{verbatim} returns the result \begin{verbatim} 2 {Z ,0,3*Z,0,3,0,1/Z}. \end{verbatim} whereas \begin{verbatim} coeff((y^2+z)**3/z,y); \end{verbatim} gives an error if {\tt RATARG} is off, and the result \begin{verbatim} 3 2 {Z /Y,0,3*Z /Y,0,3*Z/Y,0,1/Y} \end{verbatim} if {\tt RATARG} is on. The length of the result of {\tt COEFF} is the highest power of {\tt VAR} encountered plus 1. In the above examples it is 7. In addition, the variable {\tt HIPOW!*}\ttindex{HIPOW"!*} is set to the highest non-zero power found in {\tt EXPRN} during the evaluation, and {\tt LOWPOW!*} \ttindex{LOPOW"!*} to the lowest non-zero power, or zero if there is a constant term. If {\tt EXPRN} is a constant, then {\tt HIPOW!*} and {\tt LOWPOW!*} are both set to zero. \subsection{COEFFN Operator}\ttindex{COEFFN} The {\tt COEFFN} operator is designed to give the user a particular coefficient of a variable in a polynomial, as opposed to {\tt COEFF} which returns all coefficients. {\tt COEFFN} is used with the syntax \begin{verbatim} COEFFN(EXPRN:polynomial,VAR:kernel,N:integer) \end{verbatim} It returns the $n^{th}$ coefficient of {\tt VAR} in the polynomial {\tt EXPRN}. \subsection{PART Operator}\ttindex{PART} Syntax: \begin{verbatim} PART(EXPRN:algebraic[,INTEXP:integer]) \end{verbatim} This operator works on the form of the expression as printed {\em or as it would have been printed at that point in the calculation} bearing in mind all the relevant switch settings at that point. The reader therefore needs some familiarity with the way that expressions are represented in prefix form in {\REDUCE} to use these operators effectively. Furthermore, it is assumed that {\tt PRI} is {\tt ON} at that point in the calculation. The reason for this is that with {\tt PRI} off, an expression is printed by walking the tree representing the expression internally. To save space, it is never actually transformed into the equivalent prefix expression as occurs when {\tt PRI} is on. However, the operations on polynomials described elsewhere can be equally well used in this case to obtain the relevant parts. The evaluation proceeds recursively down the integer expression list. In other words, \begin{verbatim} PART(<expression>,<integer1>,<integer2>) -> PART(PART(<expression>,<integer1>),<integer2>) \end{verbatim} and so on, and \begin{verbatim} PART(<expression>) -> <expression>. \end{verbatim} {\tt INTEXP} can be any expression that evaluates to an integer. If the integer is positive, then that term of the expression is found. If the integer is 0, the operator is returned. Finally, if the integer is negative, the counting is from the tail of the expression rather than the head. For example, if the expression {\tt a+b} is printed as {\tt A+B} (i.e., the ordering of the variables is alphabetical), then \begin{verbatim} part(a+b,2) -> B part(a+b,-1) -> B and part(a+b,0) -> PLUS \end{verbatim} An operator {\tt ARGLENGTH} \ttindex{ARGLENGTH} is available to determine the number of arguments of the top level operator in an expression. If the expression does not contain a top level operator, then -1 is returned. For example, \begin{verbatim} arglength(a+b+c) -> 3 arglength(f()) -> 0 arglength(a) -> -1 \end{verbatim} \subsection{Changing Parts of Expressions} {\tt PART} may also be used to change a given part of an expression. In this case, the {\tt PART} construct appears on the left-hand side of an assignment statement, and the expression to replace the given part on the right-hand side. For example, with the normal settings of {\REDUCE's} switches: \begin{verbatim} part(a+b,2) := c; -> A+C part(a+b,0) := -; -> A-B \end{verbatim} \chapter{Polynomials and Rationals} Many operations in computer algebra are concerned with polynomials \index{Polynomial} and rational functions\index{Rational function}. In this section, we review some of the switches and operators available for this purpose. These are in addition to those that work on general expressions (such as {\tt DF} and {\tt INT}) described elsewhere. In the case of operators, the arguments are first simplified before the operations are applied. In addition, they operate only on arguments of prescribed types, and produce a type mismatch error if given arguments which cannot be interpreted in the required mode with the current switch settings. For example, if an argument is required to be a kernel and {\tt a/2} is used (with no other rules for {\tt A}), an error \begin{verbatim} A/2 invalid as kernel \end{verbatim} will result. With the exception of those that select various parts of a polynomial or rational function, these operations have potentially significant effects on the space and time associated with a given calculation. The user should therefore experiment with their use in a given calculation in order to determine the optimum set for a given problem. One such operation provided by the system is an operator {\tt LENGTH} \ttindex{LENGTH} which returns the number of top level terms in the numerator of its argument. For example, \begin{verbatim} length ((a+b+c)^3/(c+d)); \end{verbatim} has the value 10. To get the number of terms in the denominator, one would first select the denominator by the operator {\tt DEN} \ttindex{DEN} (q.v.) and then call {\tt LENGTH}, as in \begin{verbatim} length den ((a+b+c)^3/(c+d)); \end{verbatim} Other operations currently supported, the relevant switches and operators, and the required argument and value modes of the latter, follow. \section{Controlling the Expansion of Expressions} The switch {\tt EXP} \ttindex{EXP} controls the expansion of expressions. If it is off, no expansion of powers or products of expressions occurs. Users should note however that in this case results come out in a normal but not necessarily canonical form. This means that zero expressions simplify to zero, but that two equivalent expressions need not necessarily simplify to the same form. {\it Example:} With {\tt EXP} on, the two expressions \begin{verbatim} (a+b)*(a+2*b) \end{verbatim} and \begin{verbatim} a^2+3*a*b+2*b^2 \end{verbatim} will both simplify to the latter form. With {\tt EXP} off, they would remain unchanged, unless the complete factoring {\tt (ALLFAC)} option were in force. {\tt EXP} is normally on. Several operators that expect a polynomial as an argument behave differently when {\tt EXP} is off, since there is often only one term at the top level. For example, with {\tt EXP} off \begin{verbatim} length((a+b+c)^3/(c+d)); \end{verbatim} returns the value 1. \section{Factorization of Polynomials}\index{Factorization} {\REDUCE} is capable of factorizing univariate and multivariate polynomials that have integer coefficients, finding all factors that also have integer coefficients. The package for doing this was written by Dr. Arthur C. Norman and Ms. P. Mary Ann Moore at The University of Cambridge. It is described in P. M. A. Moore and A. C. Norman, ``Implementing a Polynomial Factorization and GCD Package", Proc. SYMSAC '81, ACM (New York) (1981), 109-116. The easiest way to use this facility is to turn on the switch {\tt FACTOR}, which causes all expressions to be output in a factored form. For example, with {\tt FACTOR} on, the expression {\tt A\^{ }2-B\^{ }2} is returned as {\tt (A+B)*(A-B)}. It is also possible to factorize a given expression explicitly. The operator {\tt FACTORIZE} \ttindex{FACTORIZE} that invokes this facility is used with the syntax \begin{verbatim} FACTORIZE(EXPRN:polynomial[,INTEXP:prime integer]):list, \end{verbatim} the optional argument of which will be described later. Thus to find and display all factors of the cyclotomic polynomial $x^{105}-1$, one could write: \begin{verbatim} factorize(x^105-1); \end{verbatim} In the above example, there is no overall numerical factor in the result, so the results will consist only of polynomials in x. The number of such polynomials can be found by using the operator {\tt LENGTH} \ttindex{LENGTH} (q.v.). If there is a numerical factor, as in factorizing $(12*x^{2}-12)$, that factor will appear as the first member of the result. It will however not be factored further. Prime factors of such numbers can be found using the switch {\tt IFACTOR} \ttindex{IFACTOR}. For example, \begin{verbatim} on ifactor; factorize(12x^2-12); \end{verbatim} would result in the output \begin{verbatim} {2,2,3,X - 1,X + 1}. \end{verbatim} Note that the {\tt IFACTOR} switch only affects the result of {\tt FACTORIZE}. It has no effect if the {\tt FACTOR} \ttindex{FACTOR} switch is also on. The order in which the factors occur in the result (with the exception of a possible overall numerical coefficient which comes first) is system dependent and should not be relied on. Similarly it should be noted that any pair of individual factors can be negated without altering their product, and that {\REDUCE} may sometimes do that. The factorizer works by first reducing multivariate problems to univariate ones and then solving the univariate ones modulo small primes. It normally selects both evaluation points and primes using a random number generator that should lead to different detailed behavior each time any particular problem is tackled. If, for some reason, it is known that a certain (probably univariate) factorization can be performed effectively with a known prime, {\tt P} say, this value of {\tt P} can be handed to {\tt FACTORIZE} \ttindex{FACTORIZE} as a second argument. An error will occur if a non-prime is provided to {\tt FACTORIZE} in this manner. It is also an error to specify a prime that divides the discriminant of the polynomial being factored, but users should note that this condition is not checked by the program, so this capability should be used with care. Factorization can be performed over a number of polynomial coefficient domains in addition to integers. The particular description of the relevant domain should be consulted to see if factorization is supported. For example, the following statements will factorize $x^{4}+1$ modulo 7: \begin{verbatim} setmod 7; on modular; factorize(x^4+1); \end{verbatim} The factorization module is provided with a trace facility that may be useful as a way of monitoring progress on large problems, and of satisfying curiosity about the internal workings of the package. The most simple use of this is enabled by issuing the {\REDUCE} command \ttindex{TRFAC} {\tt on trfac;} . Following this, all calls to the factorizer will generate informative messages reporting on such things as the reduction of multivariate to univariate cases, the choice of a prime and the reconstruction of full factors from their images. Further levels of detail in the trace are intended mainly for system tuners and for the investigation of suspected bugs. For example, {\tt TRALLFAC} gives tracing information at all levels of detail. The switch that can be set by {\tt on timings;} makes it possible for one who is familiar with the algorithms used to determine what part of the factorization code is consuming the most resources. {\tt on overview}; reduces the amount of detail presented in other forms of trace. Other forms of trace output are enabled by directives of the form \begin{verbatim} symbolic set!-trace!-factor(<number>,<filename>); \end{verbatim} where useful numbers are 1,2,3 and 100,101,... . This facility is intended to make it possible to discover in fairly great detail what just some small part of the code has been doing - the numbers refer mainly to depths of recursion when the factorizer calls itself, and to the split between its work forming and factorizing images and reconstructing full factors from these. If {\tt NIL} is used in place of a filename the trace output requested is directed to the standard output stream. After use of this trace facility the generated trace files should be closed by calling \begin{verbatim} symbolic close!-trace!-files(); \end{verbatim} {\it CAUTION:} The factorization code is very large, and therefore takes considerable time to load. As a result, there is some delay when the factorizer is first used. In addition, using the factorizer with {\tt MCD} \ttindex{MCD} off will result in an error. \section{Cancellation of Common Factors} Facilities are available in {\REDUCE} for cancelling common factors in the numerators and denominators of expressions, at the option of the user. The system will perform this greatest common divisor computation if the switch {\tt GCD} \ttindex{GCD} is on. ({\tt GCD} is normally off.) A check is automatically made, however, for common variable and numerical products in the numerators and denominators of expressions, and the appropriate cancellations made. When {\tt GCD} is on, and {\tt EXP} is off, a check is made for square free factors in an expression. This includes separating out and independently checking the content of a given polynomial where appropriate. (For an explanation of these terms, see Anthony C. Hearn, ``Non-Modular Computation of Polynomial GCDs Using Trial Division", Proc. EUROSAM 79, published as Lecture Notes on Comp. Science, Springer-Verlag, Berlin, No 72 (1979) 227-239.) {\it Example:} With {\tt EXP} \ttindex{EXP} off and {\tt GCD} \ttindex{GCD} on, the polynomial {\tt a*c+a*d+b*c+b*d} would be returned as {\tt (A+B)*(C+D)}. Under normal circumstances, GCDs are computed using an algorithm described in the above paper. It is also possible in {\REDUCE} to compute gcd's using an alternative algorithm, called the EZGCD Algorithm, which uses modular arithmetic. The switch {\tt EZGCD} \ttindex{EZGCD}, if on in addition to {\tt GCD}, makes this happen. In non-trivial cases, the EZGCD algorithm is almost always better than the basic algorithm, often by orders of magnitude. We therefore {\em strongly} advise users to use the {\tt EZGCD} switch where they have the resources available for supporting the package. For a description of the EZGCD algorithm, see J. Moses and D.Y.Y. Yun, ``The EZ GCD Algorithm", Proc. ACM 1973, ACM, New York (1973) 159-166. {\it CAUTION:} The code for the EZGCD package is quite large. Consequently, there is usually a delay when it is first used while that module is loaded. Note also that this package shares code with the factorizer, so a certain amount of trace information can be produced using the factorizer trace switches. \subsection{Determining the GCD of Two Polynomials} This operator, used with the syntax \begin{verbatim} GCD(EXPRN1:polynomial,EXPRN2:polynomial):polynomial, \end{verbatim} returns the greatest common divisor of the two polynomials {\tt EXPRN1} and {\tt EXPRN2}. {\it Examples:} \begin{verbatim} gcd(x^2+2*x+1,x^2+3*x+2) -> X+1 gcd(2*x^2-2*y^2,4*x+4*y) -> 2*X+2*Y gcd(x^2+y^2,x-y) -> 1. \end{verbatim} \section{Working with Least Common Multiples} Greatest common divisor calculations can often become expensive if extensive work with large rational expressions is required. However, in many cases, the only significant cancellations arise from the fact that there are often common factors in the various denominators which are combined when two rationals are added. Since these denominators tend to be smaller and more regular in structure than the numerators, considerable savings in both time and space can occur if a full GCD check is made when the denominators are combined and only a partial check when numerators are constructed. In other words, the true least common multiple of the denominators is computed at each step. The switch {\tt LCM} \ttindex{LCM} is available for this purpose, and is normally on. In addition, the operator {\tt LCM}, \ttindex{LCM} used with the syntax \begin{verbatim} LCM(EXPRN1:polynomial,EXPRN2:polynomial):polynomial, \end{verbatim} returns the least common multiple of the two polynomials {\tt EXPRN1} and {\tt EXPRN2}. {\it Examples:} \begin{verbatim} lcm(x^2+2*x+1,x^2+3*x+2) -> X**3 + 4*X**2 + 5*X + 2 lcm(2*x^2-2*y^2,4*x+4*y) -> 4*(X**2 - Y**2) \end{verbatim} \section{Controlling Use of Common Denominators} When two rational functions are added, {\REDUCE} normally produces an expression over a common denominator. However, if the user does not want denominators combined, he or she can turn off the switch {\tt MCD} \ttindex{MCD} which controls this process. The latter switch is particularly useful if no greatest common divisor calculations are desired, or excessive differentiation of rational functions is required. {\it CAUTION:} With {\tt MCD} off, results are not guaranteed to come out in either normal or canonical form. In other words, an expression equivalent to zero may in fact not be simplified to zero. This option is therefore most useful for avoiding expression swell during intermediate parts of a calculation. {\tt MCD}\ttindex{MCD} is normally on. \section{REMAINDER Operator}\ttindex{REMAINDER} This operator is used with the syntax \begin{verbatim} REMAINDER(EXPRN1:polynomial,EXPRN2:polynomial):polynomial. \end{verbatim} It returns the remainder when {\tt EXPRN1} is divided by {\tt EXPRN2}. This is the true remainder based on the internal ordering of the variables, and not the pseudo-remainder. {\it Examples:} \begin{verbatim} remainder((x+y)*(x+2*y),x+3*y) -> 2*Y**2 remainder(2*x+y,2) -> Y. \end{verbatim} \section{RESULTANT Operator}\ttindex{RESULTANT} This is used with the syntax \begin{verbatim} RESULTANT(EXPRN1:polynomial,EXPRN2:polynomial,VAR:kernel): polynomial. \end{verbatim} It computes the resultant of the two given polynomials with respect to the given variable. The result can be identified as the determinant of a Sylvester matrix, but can often also be thought of informally as the result obtained when the given variable is eliminated between the two input polynomials. If the two input polynomials have a non-trivial GCD their resultant vanishes. The sign conventions used by the resultant function follow those in R. Loos, ``Computing in Algebraic Extensions" in ``Computer Algebra --- Symbolic and Algebraic Computation", Second Ed., Edited by B. Buchberger, G.E. Collins and R. Loos, Springer-Verlag, 1983. Namely, with {\tt A} and {\tt B} not dependent on {\tt X}: \newpage \begin{verbatim} deg(p)*deg(q) resultant(p(x),q(x),x)= (-1) *resultant(q,p,x) deg(p) resultant(a,p(x),x) = a resultant(a,b,x) = 1 \end{verbatim} \section{DECOMPOSE Operator}\ttindex{DECOMPOSE} The {\tt DECOMPOSE} operator takes a multivariate polynomial as argument, and returns an expression and a list of equations from which the original polynomial can be found by composition. Its syntax is: \begin{verbatim} DECOMPOSE(EXPRN:polynomial):list. \end{verbatim} For example: \begin{verbatim} decompose(x^8-88*x^7+2924*x^6-43912*x^5+263431*x^4- 218900*x^3+65690*x^2-7700*x+234) 2 2 2 -> {U + 35*U + 234, U=V + 10*V, V=X - 22*X} 2 decompose(u^2+v^2+2u*v+1) -> {W + 1, W=U + V} \end{verbatim} Users should note however than, unlike factorization, this decomposition is not unique. \section{INTERPOL operator}\ttindex{INTERPOL} Syntax: \begin{verbatim} INTERPOL(<values>,<variable>,<points>); \end{verbatim} where {\tt <values>} and {\tt <points>} are lists of equal length and {\tt <variable>} is an algebraic expression (preferably a kernel). {\tt INTERPOL} generates an interpolation polynomial {\em f} in the given variable of degree length({\tt <values>})-1. The unique polynomial {\em f} is defined by the property that for corresponding elements {\em v} of {\tt <values>} and {\em p} of {\tt <points>} the relation $f(p)=v$ holds. The Aitken-Neville interpolation algorithm is used which guarantees a stable result even with rounded numbers and an ill-conditioned problem. \section{Obtaining Parts of Polynomials And Rationals} These operators select various parts of a polynomial or rational function structure. Except for the cost of rearrangement of the structure, these operations take very little time to perform. For those operators in this section that take a kernel {\tt VAR} as their second argument, an error results if the first expression is not a polynomial in {\tt VAR}, although the coefficients themselves can be rational as long as they do not depend on {\tt VAR}. However, if the switch {\tt RATARG} \ttindex{RATARG} is on, denominators are not checked for dependence on {\tt VAR}, and are taken to be part of the coefficients. \subsection{DEG Operator}\ttindex{DEG} This operator is used with the syntax \begin{verbatim} DEG(EXPRN:polynomial,VAR:kernel):integer. \end{verbatim} It returns the leading degree\index{Degree} of the polynomial {\tt EXPRN} in the variable {\tt VAR}. If {\tt VAR} does not occur as a variable in {\tt EXPRN}, 0 is returned. {\it Examples:} \begin{verbatim} deg((a+b)*(c+2*d)^2,a) -> 1 deg((a+b)*(c+2*d)^2,d) -> 2 deg((a+b)*(c+2*d)^2,e) -> 0. \end{verbatim} Note also that if {\tt RATARG} is on, \begin{verbatim} deg((a+b)^3/a,a) -> 3 \end{verbatim} since in this case, the denominator {\tt A} is considered part of the coefficients of the numerator in {\tt A}. With {\tt RATARG} off, however, an error would result in this case. \subsection{DEN Operator}\ttindex{DEN} This is used with the syntax: \begin{verbatim} DEN(EXPRN:rational):polynomial. \end{verbatim} It returns the denominator of the rational expression {\tt EXPRN}. If {\tt EXPRN} is a polynomial, 1 is returned. {\it Examples:} \begin{verbatim} den(x/y^2) -> Y**2 den(100/6) -> 3 [since 100/6 is first simplified to 50/3] den(a/4+b/6) -> 12 den(a+b) -> 1 \end{verbatim} \subsection{LCOF Operator}\ttindex{LCOF} LCOF is used with the syntax \begin{verbatim} LCOF(EXPRN:polynomial,VAR:kernel):polynomial. \end{verbatim} It returns the leading coefficient\index{Leading coefficient} of the polynomial {\tt EXPRN} in the variable {\tt VAR}. If {\tt VAR} does not occur as a variable in {\tt EXPRN}, {\tt EXPRN} is returned unchanged. {\it Examples:} \begin{verbatim} lcof((a+b)*(c+2*d)^2,a) -> C**2+4*C*D+4*D**2 lcof((a+b)*(c+2*d)^2,d) -> 4*(A+B) lcof((a+b)*(c+2*d),e) -> A*C+2*A*D+B*C+2*B*D \end{verbatim} \subsection{LTERM Operator}\ttindex{LTERM} Syntax: \begin{verbatim} LTERM(EXPRN:polynomial,VAR:kernel):polynomial. \end{verbatim} LTERM returns the leading term of {\tt EXPRN} with respect to {\tt VAR}. If {\tt EXPRN} does not depend on {\tt VAR}, 0 is returned. {\it Examples:} \begin{verbatim} lterm((a+b)*(c+2*d)^2,a) -> A*(C**2+4*C*D+4*D**2) lterm((a+b)*(c+2*d)^2,d) -> 4*D**2*(A+B) lterm((a+b)*(c+2*d)^2,e) -> 0 \end{verbatim} \subsection{MAINVAR Operator}\ttindex{MAINVAR} Syntax: \begin{verbatim} MAINVAR(EXPRN:polynomial):expression. \end{verbatim} Returns the main variable (based on the internal polynomial representation) of {\tt EXPRN}. If {\tt EXPRN} is a domain element, 0 is returned. {\it Examples:} Assuming {\tt A} has higher kernel order than {\tt B}, {\tt C}, or {\tt D}: \begin{verbatim} mainvar((a+b)*(c+2*d)^2) -> A mainvar(2) -> 0 \end{verbatim} \subsection{NUM Operator}\ttindex{NUM} Syntax: \begin{verbatim} NUM(EXPRN:rational):polynomial. \end{verbatim} Returns the numerator of the rational expression {\tt EXPRN}. If {\tt EXPRN} is a polynomial, that polynomial is returned. {\it Examples:} \begin{verbatim} num(x/y^2) -> X num(100/6) -> 50 num(a/4+b/6) -> 3*A+2*B num(a+b) -> A+B \end{verbatim} \subsection{REDUCT Operator}\ttindex{REDUCT} Syntax: \begin{verbatim} REDUCT(EXPRN:polynomial,VAR:kernel):polynomial. \end{verbatim} Returns the reductum of {\tt EXPRN} with respect to {\tt VAR} (i.e., the part of {\tt EXPRN} left after the leading term is removed). If {\tt EXPRN} does not depend on the variable {\tt VAR}, {\tt EXPRN} is returned. {\it Examples:} \begin{verbatim} reduct((a+b)*(c+2*d),a) -> B*(C + D) reduct((a+b)*(c+2*d),d) -> C*(A + B) reduct((a+b)*(c+2*d),e) -> A*C + A*D + B*C + B*D \end{verbatim} {\COMPATNOTE} In previous versions of REDUCE, {\tt REDUCT} returned zero if {\tt EXPRN} did not depend on {\tt VAR}. In the present version, {\tt EXPRN} is always equal to {\tt LTERM(EXPRN,VAR)} $+$ {\tt REDUCT(EXPRN,VAR)}. \section{Polynomial Coefficient Arithmetic}\index{Coefficient} {\REDUCE} allows for a variety of numerical domains for the numerical coefficients of polynomials used in calculations. The default mode is integer arithmetic, although the possibility of using real coefficients \index{Real coefficient} has been discussed elsewhere. Rational coefficients have also been available by using integer coefficients in both the numerator and denominator of an expression, using the {\tt ON DIV} \ttindex{DIV} option (q.v.) to print the coefficients as rationals. However, {\REDUCE} includes several other coefficient options in its basic version which we shall describe in this section. All such coefficient modes are supported in a table-driven manner so that it is straightforward to extend the range of possibilities. A description of how to do this is given in R.J. Bradford, A.C. Hearn, J.A. Padget and E. Schr\"ufer, ``Enlarging the {\REDUCE} Domain of Computation," Proc. of SYMSAC '86, ACM, New York (1986), 100-106. \subsection{Rational Coefficients in Polynomials}\index{Coefficient} \index{Rational coefficient} Instead of treating rational numbers as the numerator and denominator of a rational expression, it is also possible to use them as polynomial coefficients directly. This is accomplished by turning on the switch {\tt RATIONAL}.\ttindex{RATIONAL} {\it Example:} With {\tt RATIONAL} off, the input expression {\tt a/2} would be converted into a rational expression, whose numerator was {\tt A} and denominator 2. With {\tt RATIONAL} on, the same input would become a rational expression with numerator {\tt 1/2*A} and denominator {\tt 1}. Thus the latter can be used in operations that require polynomial input whereas the former could not. \subsection{Real Coefficients in Polynomials}\index{Coefficient} \index{Real coefficient} The switch {\tt ROUNDED}\ttindex{ROUNDED} permits the use of arbitrary sized real coefficients in polynomial expressions. The actual precision of these coefficients can be set by the operator {\tt PRECISION}. \ttindex{PRECISION} For example, {\tt precision 50;} sets the precision to fifty decimal digits. The default precision is system dependent and can be found by {\tt precision 0;}. In this mode, denominators are automatically made monic, and an appropriate adjustment is made to the numerator. {\it Example:} With {\tt ROUNDED} on, the input expression {\tt a/2} would be converted into a rational expression whose numerator is {\tt 0.5*A} and denominator {\tt 1}. Internally, {\REDUCE} uses floating point numbers up to the precision supported by the underlying machine hardware, and so-called {\em bigfloats} for higher precision or whenever necessary to represent numbers whose value cannot be represented in floating point. The internal precision is two decimal digits greater than the external precision to guard against roundoff inaccuracies. Bigfloats represent the fraction and exponent parts of a floating-point number by means of (arbitrary precision) integers, which is a more precise representation in many cases than the machine floating point arithmetic, but not as efficient. If a case arises where use of the machine arithmetic leads to problems, a user can force {\REDUCE} to use the bigfloat representation at all precisions by turning on the switch {\tt ROUNDBF}. \ttindex{ROUNDBF} In rare cases, this switch is turned on by the system, and the user informed by the message \begin{verbatim} ROUNDBF turned on to increase accuracy \end{verbatim} Rounded numbers are normally printed to the specified precision. However, if the user wishes to print such numbers with less precision, the printing precision can be set by the command {\tt PRINT\_PRECISION}. \index{Print precision} For example, {\tt print\_precision 5;} will cause such numbers to be printed with five digits maximum. Numbers that are stored internally as bigfloats are normally printed with a space between every five digits to improve readability. If this feature is not required, it can be suppressed by turning off the switch {\tt BFSPACE}. \ttindex{BFSPACE} Further information on the bigfloat arithmetic may be found in T. Sasaki, ``Manual for Arbitrary Precision Real Arithmetic System in {\REDUCE}", Department of Computer Science, University of Utah, Technical Note No. TR-8 (1979). When a real number is input, it is normally truncated to the precision in effect at the time the number is read. If it is desired to keep the full precision of all numbers input, the switch {\tt ADJPREC} \ttindex{ADJPREC} (for {\em adjust precision}) can be turned on. While on, {\tt ADJPREC} will automatically increase the precision, when necessary, to match that of any integer or real input, and a message printed to inform the user of the precision increase. When {\tt ROUNDED} is on, rational numbers are normally converted to rounded representation. However, if a user wishes to keep such numbers in a rational form until used in an operation that returns a real number, the switch {\tt ROUNDALL} \ttindex{ROUNDALL} can be turned off. This switch is normally on. Results from rounded calculations are returned in rounded form with two exceptions: if the result is recognized as {\tt 0} or {\tt 1} to the current precision, the integer result is returned. \COMPATNOTE In previous versions of {\REDUCE}, there were two switches to control the use of floating point arithmetic, namely {\tt FLOAT} \ttindex{FLOAT} and {\tt BIGFLOAT}. \ttindex{BIGFLOAT} This reflected the fact that there was a distinction at the {\em user} level between single and multiple precision real arithmetic. This distinction has been removed in the present version, as described above, by the introduction of the {\tt ROUNDED} switch, with the actual precision controlled by the {\tt PRECISION} command. For compatibility, the {\tt FLOAT} and {\tt BIGFLOAT} switches are still supported. However, they default to the use of {\tt ROUNDED} mode, and so results may be different from previous versions, since the algorithms used have changed. \subsection{Modular Number Coefficients in Polynomials}\index{Coefficient} \index{Modular coefficient} {\REDUCE} includes facilities for manipulating polynomials whose coefficients are computed modulo a given base. To use this option, two commands must be used; {\tt SETMOD} {\tt <integer>},\ttindex{SETMOD} to set the prime modulus, and {\tt ON MODULAR}\ttindex{MODULAR} to cause the actual modular calculations to occur. For example, with {\tt setmod 3;} and {\tt on modular;}, the polynomial {\tt (a+2*b)$^{ }$3} would become {\tt A\^{ }3+2*B\^{ }3}. The argument of {\tt SETMOD} is evaluated algebraically, except that non-modular (integer) arithmetic is used. Thus the sequence \begin{verbatim} setmod 3; on modular; setmod 7; \end{verbatim} will correctly set the modulus to 7. Users should note that the modular calculations are on the polynomial coefficients only. It is not currently possible to reduce the exponents since no check for a prime modulus is made (which would allow $x^{p-1}$ to be reduced to 1 mod p). Note also that any division by a number not co-prime with the modulus will result in the error ``Invalid modular division". \subsection{Complex Number Coefficients in Polynomials}\index{Coefficient} \index{Complex coefficient} Although {\REDUCE} routinely treats the square of the variable {\em i} as equivalent to $-1$, this is not sufficient to reduce expressions involving {\em i} to lowest terms, or to factor such expressions over the complex numbers. For example, in the default case, \begin{verbatim} factorize(a^2+1); \end{verbatim} gives the result \begin{verbatim} {A**2+1} \end{verbatim} and \begin{verbatim} (a^2+b^2)/(a+i*b) \end{verbatim} is not reduced further. However, if the switch {\tt COMPLEX} \ttindex{COMPLEX} is turned on, full complex arithmetic is then carried out. In other words, the above factorization will give the result \begin{verbatim} {A - I,A + I} \end{verbatim} and the quotient will be reduced to {\tt A-I*B}. The switch {\tt COMPLEX} may be combined with {\tt ROUNDED} to give complex real numbers; the appropriate arithmetic is performed in this case. Complex conjugation is used to remove complex numbers from denominators of expressions. To do this if {\tt COMPLEX} is off, you must turn the switch {\tt RATIONALIZE} \ttindex{RATIONALIZE} on. \chapter{Substitution Commands} \index{Substitution} An important class of commands in {\REDUCE} is that which defines substitutions for variables and expressions to be made during the evaluation of expressions. Such substitutions use the prefix operator {\tt SUB}, various forms of the command {\tt LET}, and rule sets. \section{SUB Operator} \ttindex{SUB} Syntax: \begin{verbatim} SUB(<substitution_list>,EXPRN1:algebraic):algebraic \end{verbatim} where {\tt <substitution\_list>} is a list of one or more equations of the form \begin{verbatim} VAR:kernel=EXPRN:algebraic \end{verbatim} or a kernel that evaluates to such a list. The {\tt SUB} operator gives the algebraic result of replacing every occurrence of the variable {\tt VAR} in the expression {\tt EXPRN1} by the expression {\tt EXPRN}. Specifically, {\tt EXPRN1} is first evaluated using all available rules. Next the substitutions are made, and finally the substituted expression is reevaluated. When more than one variable occurs in the substitution list, the substitution is performed by recursively walking down the tree representing {\tt EXPRN1}, and replacing every {\tt VAR} found by the appropriate {\tt EXPRN}. The {\tt EXPRN} are not themselves searched for any occurrences of the various {\tt VAR}s. The trivial case {\tt SUB(EXPRN1)} returns the algebraic value of {\tt EXPRN1}. {\it Examples:} \begin{verbatim} 2 2 sub({x=a+y,y=y+1},x^2+y^2) -> A + 2*A*Y + 2*Y + 2*Y + 1 \end{verbatim} and with {\tt s := {x=a+y,y=y+1}}, \begin{verbatim} 2 2 sub(s,x^2+y^2) -> A + 2*A*Y + 2*Y + 2*Y + 1 \end{verbatim} Note that the global assignments {\tt x:=a+y}, etc., do not take place. {\tt EXPRN1} can be any valid algebraic expression whose type is such that a substitution process is defined for it (e.g., scalar expressions, lists and matrices). An error will occur if an expression of an invalid type for substitution occurs either in {\tt EXPRN} or {\tt EXPRN1}. The braces around the substitution list may also be omitted, as in: \begin{verbatim} 2 2 sub(x=a+y,y=y+1,x^2+y^2) -> A + 2*A*Y + 2*Y + 2*Y + 1 \end{verbatim} \section{LET Rules} \ttindex{LET} Unlike substitutions introduced via {\tt SUB} {\tt LET} rules are global in scope and stay in effect until replaced or {\tt CLEAR}ed. The simplest use of the {\tt LET} statement is in the form \begin{verbatim} LET <substitution list> \end{verbatim} where {\tt <substitution list>} is a list of rules separated by commas, each of the form: \begin{verbatim} <variable> = <expression> \end{verbatim} or \begin{verbatim} <prefix operator>(<argument>,...,<argument>) = <expression> \end{verbatim} or \begin{verbatim} <argument> <infix operator>,..., <argument> = <expression> \end{verbatim} For example, \begin{verbatim} let {x = y^2, h(u,v) = u - v, cos(pi/3) = 1/2, a*b = c, l+m = n, w^3 = 2*z - 3, z^10 = 0} \end{verbatim} The list brackets can be left out if preferred. The above rules could also have been entered as seven separate {\tt LET} statements. After such {\tt LET} rules have been input, {\tt X} will always be evaluated as the square of {\tt Y}, and so on. This is so even if at the time the {\tt LET} rule was input, the variable {\tt Y} had a value other than {\tt Y}. (In contrast, the assignment {\tt x:=y\^{ }2} will set {\tt X} equal to the square of the current value of {\tt Y}, which could be quite different.) The rule {\tt let a*b=c} means that whenever {\tt A} and {\tt B} are both factors in an expression their product will be replaced by {\tt C}. For example, {\tt a\^{ }5 *} {\tt b\^{ }*w} would be replaced by {\tt c\^{ }*b\^{ }2*w}. The rule for {\tt l+m} will not only replace all occurrences of {\tt l+m} by {\tt N}, but will also normally replace {\tt L} by {\tt n-m}, but not {\tt M} by {\tt n-l}. A more complete description of this case is given in Section~\ref{sec-gensubs}. The rule pertaining to {\tt w\^{ }3} will apply to any power of {\tt W} greater than or equal to the third. Note especially the last example, {\tt let z\^{ }10=0}. This declaration means, in effect: ignore the tenth or any higher power of {\tt Z}. Such declarations, when appropriate, often speed up a computation to a considerable degree. (See \index{Asymptotic command} Asymptotic Commands for more details.) Any new operators occurring in such {\tt LET} rules will be automatically declared {\tt OPERATOR} by the system, if the rules are being read from a file. If they are being entered interactively, the system will ask {\tt DECLARE} ... {\tt OPERATOR?} . Answer {\tt Y} or {\tt N} and hit RETURN. In each of these examples, substitutions are only made for the explicit expressions given; i.e., none of the variables may be considered arbitrary in any sense. For example, the command \begin{verbatim} let h(u,v) = u - v; \end{verbatim} will cause {\tt h(u,v)} to evaluate to {\tt U - V}, but will not affect {\tt h(u,z)} or {\tt H} with any arguments other than precisely the symbols {\tt U,V}. These simple {\tt LET} rules are on the same logical level as assignments made with the := operator. An assignment {\tt x := p+q} cancels a rule {\tt let x = y\^{ }2} made earlier, and vice versa. {\it CAUTION:} A recursive rule such as \begin{verbatim} let x = x + 1; \end{verbatim} is erroneous, since any subsequent evaluation of {\tt X} would lead to a non-terminating chain of substitutions: \begin{verbatim} x -> x + 1 -> (x + 1) + 1 -> ((x + 1) + 1) + 1 -> ... \end{verbatim} Similarly, coupled substitutions such as \begin{verbatim} let l = m + n, n = l + r; \end{verbatim} would lead to the same error. As a result, if you try to evaluate an {\tt X}, {\tt L} or {\tt N} defined as above, you will get an error such as \begin{verbatim} X improperly defined in terms of itself \end{verbatim} Array and matrix elements can appear on the left-hand side of a {\tt LET} statement. However, because of their ``instant evaluation'' property, it is the value of the element that is substituted for, rather than the element itself. E.g., \begin{verbatim} array a(5); a(2) := b; let a(2) = c; \end{verbatim} results in {\tt B} being substituted by {\tt C}; the assignment for {\tt a(2)} does not change. Finally, if an error occurs in any equation in a {\tt LET} statement (including generalized statements involving {\tt FOR ALL} and {\tt SUCH THAT)}, the remaining rules are not evaluated. \subsection{FOR ALL \ldots LET} \ttindex{FOR ALL} If a substitution for all possible values of a given argument of an operator is required, the declaration {\tt FOR ALL} may be used. The syntax of such a command is \begin{verbatim} FOR ALL <variable>,...,<variable> <LET statement> <terminator> \end{verbatim} e.g., \begin{verbatim} for all x,y let h(x,y) = x-y; for all x let k(x,y) = x^y; \end{verbatim} The first of these declarations would cause {\tt h(a,b)} to be evaluated as {\tt A-B}, {\tt h(u+v,u+w)} to be {\tt V-W}, etc. If the operator symbol {\tt H} is used with more or fewer argument places, not two, the {\tt LET} would have no effect, and no error would result. The second declaration would cause {\tt k(a,y)} to be evaluated as {\tt a\^{ }y}, but would have no effect on {\tt k(a,z)} since the rule didn't say {\tt FOR ALL Y} ... . Where we used {\tt X} and {\tt Y} in the examples, any variables could have been used. This use of a variable doesn't affect the value it may have outside the {\tt LET} statement. However, you should remember what variables you actually used. If you want to delete the rule subsequently, you must use the same variables in the {\tt CLEAR} command (q.v.). It is possible to use more complicated expressions as a template for a {\tt LET} statement, as explained in the section on substitutions for general expressions. In nearly all cases, the rule will be accepted, and a consistent application made by the system. However, if there is a sole constant or a sole free variable on the left-hand side of a rule (e.g., {\tt let 2=3} or {\tt for all x let x=2)}, then the system is unable to handle the rule, and the error message \begin{verbatim} Substitution for ... not allowed \end{verbatim} will be issued. Any variable listed in the {\tt FOR ALL} part will have its symbol preceded by an equal sign: {\tt X} in the above example will appear as {\tt =X}. An error will also occur if a variable in the {\tt FOR ALL} part is not properly matched on both sides of the {\tt LET} equation. \subsection{FOR ALL \ldots SUCH THAT \ldots LET} \ttindex{FOR ALL} \ttindex{SUCH THAT} If a substitution is desired for more than a single value of a variable in an operator or other expression, but not all values, a conditional form of the {\tt FOR ALL \ldots LET} declaration can be used. {\it Example:} \begin{verbatim} for all x such that numberp x and x<0 let h(x)=0; \end{verbatim} will cause {\tt h(-5)} to be evaluated as 0, but {\tt H} of a positive integer, or of an argument which is not an integer at all, would not be affected. Any boolean expression can follow the {\tt SUCH THAT} keywords. \subsection{Removing Assignments and Substitution Rules} \ttindex{CLEAR} The user may remove all assignments and substitution rules from any expression by the command {\tt CLEAR}, in the form \begin{verbatim} CLEAR <expression>,...,<expression><terminator> \end{verbatim} e.g. \begin{verbatim} clear x, h(x,y); \end{verbatim} Because of their ``instant evaluation" property, array and matrix elements cannot be cleared with {\tt CLEAR}. For example, if {\tt A} is an array, you must say \begin{verbatim} a(3) := 0; \end{verbatim} rather than \begin{verbatim} clear a(3); \end{verbatim} to ``clear" element {\tt a(3)}. On the other hand, a whole array (or matrix) {\tt A} can be cleared by the command {\tt clear a}; This means much more than resetting to 0 all the elements of {\tt A}. The fact that {\tt A} is an array, and what its dimensions are, are forgotten, so {\tt A} can be redefined as another type of object, for example an operator. The more general types of {\tt LET} declarations can also be deleted by using {\tt CLEAR}. Simply repeat the {\tt LET} rule to be deleted, using {\tt CLEAR} in place of {\tt LET}, and omitting the equal sign and right-hand part. The same dummy variables must be used in the {\tt FOR ALL} part, and the boolean expression in the {\tt SUCH THAT} part must be written the same way. (The placing of blanks doesn't have to be identical.) {\it Example:} The {\tt LET} rule \begin{verbatim} for all x such that numberp x and x<0 let h(x)=0; \end{verbatim} can be erased by the command \begin{verbatim} for all x such that numberp x and x<0 clear h(x); \end{verbatim} \subsection{Overlapping LET Rules} {\tt CLEAR} is not the only way to delete a {\tt LET} rule. A new {\tt LET} rule identical to the first, but with a different expression after the equal sign, replaces the first. Replacements are also made in other cases where the existing rule would be in conflict with the new rule. For example, a rule for {\tt x\^{ }4} would replace a rule for {\tt x\^{ }5}. The user should however be cautioned against having several {\tt LET} rules in effect which relate to the same expression. No guarantee can be given as to which rules will be applied by {\REDUCE} or in what order. It is best to {\tt CLEAR} an old rule before entering a new related {\tt LET} rule. \subsection{Substitutions for General Expressions} \label{sec-gensubs} The examples of substitutions discussed in other sections have involved very simple rules. However, the substitution mechanism used in {\REDUCE} is very general, and can handle arbitrarily complicated rules without difficulty. The general substitution mechanism used in {\REDUCE} is discussed in Hearn, A. C., ``{\REDUCE}, A User-Oriented Interactive System for Algebraic Simplification,'' Interactive Systems for Experimental Applied Mathematics, (edited by M. Klerer and J. Reinfelds), Academic Press, New York (1968), 79-90, and Hearn. A. C., ``The Problem of Substitution,'' Proc. 1968 Summer Institute on Symbolic Mathematical Computation, IBM Programming Laboratory Report FSC 69-0312 (1969). For the reasons given in these references, {\REDUCE} does not attempt to implement a general pattern matching algorithm. However, the present system uses far more sophisticated techniques than those discussed in the above papers. It is now possible for the rules appearing in arguments of {\tt LET} to have the form \begin{verbatim} <substitution expression> = <expression> \end{verbatim} where any rule to which a sensible meaning can be assigned is permitted. However, this meaning can vary according to the form of {\tt <substitution expression>}. The semantic rules associated with the application of the substitution are completely consistent, but somewhat complicated by the pragmatic need to perform such substitutions as efficiently as possible. The following rules explain how the majority of the cases are handled. To begin with, the {\tt <substitution expression>} is first partly simplified by collecting like terms and putting identifiers (and kernels) in the system order. However, no substitutions are performed on any part of the expression with the exception of expressions with the ``instant evaluation" property, such as array and matrix elements, whose actual values are used. It should also be noted that the system order used is not changeable by the user, even with the {\tt KORDER} command. Specific cases are then handled as follows: \begin{enumerate} \item If the resulting simplified rule has a left-hand side which is an identifier, an expression with a top-level algebraic operator or a power, then the rule is added without further change to the appropriate table. \item If the operator * appears at the top level of the simplified left-hand side, then any constant arguments in that expression are moved to the right-hand side of the rule. The remaining left-hand side is then added to the appropriate table. For example, \begin{verbatim} let 2*x*y=3 \end{verbatim} becomes \begin{verbatim} let x*y=3/2 \end{verbatim} so that {\tt x*y} is added to the product substitution table, and when this rule is applied, the expression {\tt x*y} becomes 3/2, but {\tt X} or {\tt Y} by themselves are not replaced. \item If the operators {\tt +}, {\tt -} or {\tt /} appear at the top level of the simplified left-hand side, all but the first term is moved to the right-hand side of the rule. Thus the rules \begin{verbatim} let l+m=n, x/2=y, a-b=c \end{verbatim} become \begin{verbatim} let l=n-m, x=2*y, a=c+b. \end{verbatim} \end{enumerate} One problem that can occur in this case is that if a quantified expression is moved to the right-hand side, a given free variable might no longer appear on the left-hand side, resulting in an error because of the unmatched free variable. E.g., \begin{verbatim} for all x,y let f(x)+f(y)=x*y \end{verbatim} would become \begin{verbatim} for all x,y let f(x)=x*y-f(y) \end{verbatim} which no longer has {\tt Y} on both sides. The fact that array and matrix elements are evaluated in the left-hand side of rules can lead to confusion at times. Consider for example the statements \begin{verbatim} array a(5); let x+a(2)=3; let a(3)=4; \end{verbatim} The left-hand side of the first rule will become {\tt X}, and the second 0. Thus the first rule will be instantiated as a substitution for {\tt X}, and the second will result in an error. The order in which a set of rules is applied is not easily understandable without a detailed knowledge of the system simplification protocol. It is also possible for this order to change from release to release, as improved substitution techniques are implemented. Users should therefore assume that the order of application of rules is arbitrary, and program accordingly. After a substitution has been made, the expression being evaluated is reexamined in case a new allowed substitution has been generated. This process is continued until no more substitutions can be made. As mentioned elsewhere, when a substitution expression appears in a product, the substitution is made if that expression divides the product. For example, the rule \begin{verbatim} let a^c = 3*z; \end{verbatim} would cause {\tt a\^{ }2*c*x} to be replaced by {\tt 3*Z*X} and {\tt a\^{ }2*c\^{ }2} by {\tt 3*Z*C}. If the substitution is desired only when the substitution expression appears in a product with the explicit powers supplied in the rule, the command {\tt MATCH} should be used instead. \ttindex{MATCH} For example, \begin{verbatim} match a^2*c = 3*z; \end{verbatim} would cause {\tt a\^{ }2*c*x} to be replaced by {\tt 3*Z*X}, but {\tt a\^{ }2*c\^{ }2} would not be replaced. {\tt MATCH} can also be used with the {\tt FOR ALL} constructions described above. To remove substitution rules of the type discussed in this section, the {\tt CLEAR} \ttindex{CLEAR} command can be used, combined, if necessary, with the same {\tt FOR ALL} clause with which the rule was defined, for example: \begin{verbatim} for all x clear log(e^x),e^log(x),cos(w*t+theta(x)); \end{verbatim} Note, however, that the arbitrary variable names in this case {\em must} be the same as those used in defining the substitution. \section{Rule Lists} \index{Rule Lists} Rule lists offer an alternative approach to defining substitutions that is different from either {\tt SUB} or {\tt LET}. In fact, they provide the best features of both, since they have all the capabilities of {\tt LET}, but the rules can also be applied locally as is possible with {\tt SUB}. In time, they will be used more and more in {\REDUCE}. However, since they are relatively new, most {\REDUCE} code you see uses the older constructs. A rule list is a list of {\em rules} that have the syntax \begin{verbatim} <expression> => <expression> (WHEN <boolean expression>) \end{verbatim} For example, \begin{verbatim} {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2, cos(~n*pi) => (-1)^n when remainder(n,2)=0} \end{verbatim} The tilde preceding a variable marks that variable as {\em free} for that rule, much as a variable in a {\tt FOR ALL} clause in a {\tt LET} statement. The first occurrence of that variable in each relevant rule must be so marked on input, otherwise inconsistent results can occur. For example, the rule list \begin{verbatim} {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2, cos(x)^2 => (1+cos(2x))/2} \end{verbatim} designed to replace products of cosines, would not be correct, since the second rule would only apply to the explicit argument {\tt X}. Later occurrences in the same rule may also be marked, but this is optional (internally, all such rules are stored with each relevant variable explicitly marked). The optional {\tt WHEN} \ttindex{WHEN} clause allows constraints to be placed on the application of the rule, much as the {\tt SUCH THAT} clause in a {\tt LET} statement. A rule set may be named, for example \begin{verbatim} trig1 := {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2, cos(~x)*sin(~y) => (sin(x+y)-sin(x-y))/2, sin(~x)*sin(~y) => (cos(x-y)-cos(x+y))/2, cos(~x)^2 => (1+cos(2*x))/2, sin(~x)^2 => (1-cos(2*x))/2}; \end{verbatim} Such named rule lists may be inspected as needed. E.g., the command {\tt trig1;} would cause the above list to be printed. Rule lists may be used in two ways. They can be globally instantiated by means of the command {\tt LET}.\ttindex{LET} For example, \begin{verbatim} let trig1; \end{verbatim} would cause the above set of rules to be globally active from then on until cancelled by the command {\tt CLEARRULES}, \ttindex{CLEARRULES} as in \begin{verbatim} clearrules trig1; \end{verbatim} {\tt CLEARRULES} has the syntax \begin{verbatim} CLEARRULES <rule list>|<name of rule list>(,...) . \end{verbatim} The second way to use rule lists is to invoke them locally by means of a {\tt WHERE} \ttindex{WHERE} clause. For example \begin{verbatim} cos(a)*cos(b+c) where {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2}; \end{verbatim} or \begin{verbatim} cos(a)*sin(b) where trigrules; \end{verbatim} The syntax of an expression with a {\tt WHERE} clause is: \begin{verbatim} <expression> WHERE <rule>|<rule list>(,<rule>|<rule list> ...) \end{verbatim} so the first example above could also be written \begin{verbatim} cos(a)*cos(b+c) where cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2; \end{verbatim} The effect of this construct is that the rule set(s) in the {\tt WHERE} clause only apply to the expression on the left of {\tt WHERE}. They have no effect outside the expression. In particular, they do not affect previously defined {\tt WHERE} clauses or {\tt LET} statements. For example, the sequence \begin{verbatim} let a=2; a where a=>4; a; \end{verbatim} would result in the output \begin{verbatim} 4 2 \end{verbatim} Although {\tt WHERE} has a precedence less than any other infix operator, it still binds higher than keywords such as {\tt ELSE}, {\tt THEN}, {\tt DO}, {\tt REPEAT} and so on. Thus the expression \begin{verbatim} if a=2 then 3 else a+2 where a=3 \end{verbatim} will parse as \begin{verbatim} if a=2 then 3 else (a+2 where a=3) \end{verbatim} {\tt WHERE} may be used to introduce auxiliary variables in symbolic mode expressions, as described in Section~\ref{sec-lambda}. However, the symbolic mode use has different semantics, so expressions do not carry from one mode to the other. \COMPATNOTE In order to provide compatibility with older versions of rule sets released through the Network Library, it is currently possible to use an equal sign interchangably with the replacement sign {\tt =>} in rules and {\tt LET} statements. However, since this may change in future versions, the replacement sign is preferable in rules and the equal sign in nonrule-based {\tt LET} statements. \subsection*{Order of Application of Rules} If rules have overlapping domains, their order of application is important. In general, it is very difficult to specify this order precisely, so that it is best to assume that the order is arbitrary. However, if only one operator is involved, the order of application of the rules for this operator can be determined from the following: \begin{enumerate} \item Rules containing at least one free variable apply before all rules without free variables. \item Rules activated in the most recent {\tt LET} command are applied first. \item {\tt LET} with several entries generate the same order of application as a corresponding sequence of commands with one rule or rule set each. \item Within a rule set, the rules containing at least one free variable are applied in their given order. In other words, the first member of the list is applied first. \item Consistent with the first item, any rule in a rule list that contains no free variables is applied after all rules containing free variables. \end{enumerate} {\it Example:} The following rule set enables the computation of exact values of the Gamma function: \begin{verbatim} operator gamma,gamma_error; gamma_rules := {gamma(~x)=>sqrt(pi)/2 when x=1/2, gamma(~n)=>factorial(n-1) when fixp n and n>0, gamma(~n)=>gamma_error(n) when fixp n, gamma(~x)=>(x-1)*gamma(x-1) when fixp(2*x) and x>1, gamma(~x)=>gamma(x+1)/x when fixp(2*x)}; \end{verbatim} Here, rule by rule, cases of known or definitely uncomputable values are sorted out; e.g. the rule leading to the error expression will be applied for negative integers only, since the positive integers are caught by the preceding rule, and the last rule will apply for negative odd multiples of $1/2$ only. Alternatively the first rule could have been written as \begin{verbatim} gamma(1/2) => sqrt(pi)/2, \end{verbatim} but then the case $x=1/2$ should be excluded in the {\tt WHEN} part of the last rule explicitly because a rule without free variables cannot take precedence over the other rules. \section{Asymptotic Commands} \index{Asymptotic command} In expansions of polynomials involving variables which are known to be small, it is often desirable to throw away all powers of these variables beyond a certain point to avoid unnecessary computation. The command {\tt LET} may be used to do this. For example, if only powers of {\tt X} up to {\tt x\^{ }7} are needed, the command \begin{verbatim} let x^8 = 0; \end{verbatim} will cause the system to delete all powers of {\tt X} higher than 7. {\it CAUTION:} This particular simplification works differently from most substitution mechanisms in {\REDUCE} in that it is applied during polynomial manipulation rather than to the whole evaluated expression. Thus, with the above rule in effect, {\tt x\^{ }10/x\^{ }5} would give the result zero, since the numerator would simplify to zero. Similarly {\tt x\^{ }20/x\^{ }10} would give a {\tt Zero divisor} error message, since both numerator and denominator would first simplify to zero. The method just described is not adequate when expressions involve several variables having different degrees of smallness. In this case, it is necessary to supply an asymptotic weight to each variable and count up the total weight of each product in an expanded expression before deciding whether to keep the term or not. There are two associated commands in the system to permit this type of asymptotic constraint. The command {\tt WEIGHT} \ttindex{WEIGHT} takes a list of equations of the form \begin{verbatim} <kernel form> = <number> \end{verbatim} where {\tt <number>} must be a positive integer (not just evaluate to a positive integer). This command assigns the weight {\tt <number>} to the relevant kernel form. A check is then made in all algebraic evaluations to see if the total weight of the term is greater than the weight level assigned to the calculation. If it is, the term is deleted. To compute the total weight of a product, the individual weights of each kernel form are multiplied by their corresponding powers and then added. The weight level of the system is initially set to 2. The user may change this setting by the command \ttindex{WTLEVEL} \begin{verbatim} wtlevel <number>; \end{verbatim} which sets {\tt <number>} as the new weight level of the system. Again, {\tt <number>} must be a positive integer. \chapter{File Handling Commands} \index{File handling} In many applications, it is desirable to load previously prepared {\REDUCE} files into the system, or to write output on other files. {\REDUCE} offers four commands for this purpose, namely, {\tt IN}, {\tt OUT}, {\tt SHUT}, {\tt LOAD}, and {\tt LOAD\_PACKAGE}. The first \ttindex{IN} \ttindex{OUT} \ttindex{SHUT} three operators are described here; {\tt LOAD} and {\tt LOAD\_PACKAGE} are discussed in Section~\ref{sec-load}. \section{IN Command} \ttindex{IN} This command takes a list of file names as argument and directs the system to input \index{Input} each file (which should contain {\REDUCE} statements and commands) into the system. File names can either be an identifier or a string. The explicit format of these will be system dependent and, in many cases, site dependent. The explicit instructions for the implementation being used should therefore be consulted for further details. For example: \begin{verbatim} in f1,"ggg.rr.s"; \end{verbatim} will first load file {\tt F1}, then {\tt ggg.rr.s}. When a semicolon is used as the terminator of the IN statement, the statements in the file are echoed on the terminal or written on the current output file. If \$ \index{Command terminator} is used as the terminator, the input is not shown. Echoing of all or part of the input file can be prevented, even if a semicolon was used, by placing an {\tt off echo;} \ttindex{ECHO} command in the input file. Files to be read using {\tt IN} should end with {\tt ;END;}. Note the two semicolons! First of all, this is protection against obscure difficulties the user will have if there are, by mistake, more {\tt BEGIN}s than {\tt END}s on the file. Secondly, it triggers some file control book-keeping which may improve system efficiency. If {\tt END} is omitted, an error message {\tt "End-of-file read"} will occur. \section{OUT Command} \ttindex{OUT} This command takes a single file name as argument, and directs output to that file from then on, until another {\tt OUT} changes the output file, or {\tt SHUT} closes it. Output can go to only one file at a time, although many can be open. If the file has previously been used for output during the current job, and not {\tt SHUT}, \ttindex{SHUT} the new output is appended to the end of the file. Any existing file is erased before its first use for output in a job, or if it had been {\tt SHUT} before the new {\tt OUT}. To output on the terminal without closing the output file, the reserved file name T (for terminal) may be used. For example, {\tt out ofile;} will direct output to the file {\tt OFILE} and {\tt out t;} will direct output to the user's terminal. The output sent to the file will be in the same form that it would have on the terminal. In particular {\tt x\^{ }2} would appear on two lines, an {\tt X} on the lower line and a 2 on the line above. If the purpose of the output file is to save results to be read in later, this is not an appropriate form. We first must turn off the {\tt NAT} switch which specifies that output should be in standard mathematical notation. {\it Example:} To create a file {\tt ABCD} from which it will be possible to read -- using {\tt IN} -- the value of the expression {\tt XYZ}: \begin{verbatim} off echo$ % needed if your input is from a file. off nat$ % output in IN-readable form. Each expression % printed will end with a $ . out abcd$ % output to new file linelength 72$ % for systems with fixed input line length. xyz:=xyz; % will output "XYZ := " followed by the value % of XYZ write ";end"$ % standard for ending files for IN shut abcd$ % save ABCD, return to terminal output on nat$ % restore usual output form \end{verbatim} \section{SHUT Command} \ttindex{SHUT} This command takes a list of names of files which have been previously opened via an {\tt OUT} statement and closes them. Most systems require this action by the user before he ends the {\REDUCE} job (if not sooner), otherwise the output may be lost. If a file is shut and a further {\tt OUT} command issued for the same file, the file is erased before the new output is written. If it is the current output file which is shut, output will switch to the terminal. Attempts to shut files that have not been opened by {\tt OUT}, or an input file, will lead to errors. \chapter{Commands for Interactive Use} \index{Interactive use} {\REDUCE} is designed as an interactive system, but naturally it can also operate in a batch processing or background mode by taking its input command by command from the relevant input stream. There is a basic difference, however, between interactive and batch use of the system. In the former case, whenever the system discovers an ambiguity at some point in a calculation, such as a forgotten type assignment for instance, it asks the user for the correct interpretation. In batch operation, it is not practical to terminate the calculation at such points and require resubmission of the job, so the system makes the most obvious guess of the user's intentions and continues the calculation. There is also a difference in the handling of errors. In the former case, the computation can continue since the user has the opportunity to correct the mistake. In batch mode, the error may lead to consequent erroneous (and possibly time consuming) computations. So in the default case, no further evaluation occurs, although the remainder of the input is checked for syntax errors. A message {\tt "Continuing with parsing only"} informs the user that this is happening. On the other hand, the switch {\tt ERRCONT}, \ttindex{ERRCONT} if on, will cause the system to continue evaluating expressions after such errors occur. When a syntactical error occurs, the place where the system detected the error is marked with three dollar signs (\$\$\$). In interactive mode, the user can then use {\tt ED} \ttindex{ED} to correct the error, or retype the command. When a non-syntactical error occurs in interactive mode, the command being evaluated at the time the last error occurred is saved, and may later be reevaluated by the command {\tt RETRY}. \ttindex{RETRY} \section{Referencing Previous Results} It is often useful to be able to reference results of previous computations during a {\REDUCE} session. For this purpose, {\REDUCE} maintains a history \index{History} of all interactive inputs and the results of all interactive computations during a given session. These results are referenced by the command number that {\REDUCE} prints automatically in interactive mode. To use an input expression in a new computation, one writes {\tt input(}$n${\tt )}, \ttindex{INPUT} where $n$ is the command number. To use an output expression, one writes {\tt WS(}$n${\tt )}. \ttindex{WS} {\tt WS} references the previous command. E.g., if command number 1 was {\tt INT(X-1,X)}; and the result of command number 7 was {\tt X-1}, then \begin{verbatim} 2*input(1)-ws(7)^2; \end{verbatim} would give the result {\tt -1}, whereas \begin{verbatim} 2*ws(1)-ws(7)^2; \end{verbatim} would yield the same result, but {\em without} a recomputation of the integral. The operator {\tt DISPLAY} \ttindex{DISPLAY} is available to display previous inputs. If its argument is a positive integer, {\it n} say, then the previous n inputs are displayed. If its argument is {\tt ALL} (or in fact any non-numerical expression), then all previous inputs are displayed. \section{Interactive Editing} It is possible when working interactively to edit any {\REDUCE} input that comes from the user's terminal, and also some user-defined procedure definitions. At the top level, one can access any previous command string by the command {\tt ed(}$n${\tt )}, \ttindex{ED} where n is the desired command number as prompted by the system in interactive mode. {\tt ED}; (i.e. no argument) accesses the previous command. After {\tt ED} has been called, you can now edit the displayed string using a string editor with the following commands: \begin{verbatim} B move pointer to beginning C<character> replace next character by <character> D delete next character E end editing and reread text F<character> move pointer to next occurrence of <character> I<string><escape> insert <string> in front of pointer K<character> delete all chars until <character> P print string from current pointer Q give up with error exit S<string><escape> search for first occurrence of <string> positioning pointer just before it <space> or X move pointer right one char. \end{verbatim} The above table can be displayed online by typing a question mark followed by a carriage return to the editor. The editor prompts with an angle bracket. Commands can be combined on a single line, and all command sequences must be followed by a carriage return to become effective. Thus, to change the command {\tt x := a+1;} to {\tt x := a+2}; and cause it to be executed, the following edit command sequence could be used: \begin{verbatim} f1c2e<return>. \end{verbatim} The interactive editor may also be used to edit a user-defined procedure that has not been compiled (q.v.). To do this, one says: \ttindex{EDITDEF} \begin{verbatim} editdef <id>; \end{verbatim} where {\tt <id>} is the name of the procedure. The procedure definition will then be displayed in editing mode, and may then be edited and redefined on exiting from the editor. \section{Interactive File Control} If input is coming from an external file, the system treats it as a batch processed calculation. If the user desires interactive \index{Interactive use} response in this case, he can include the command {\tt on int}; \ttindex{INT} in the file. Likewise, he can issue the command {\tt off int}; in the main program if he does not desire continual questioning from the system. Regardless of the setting of {\tt INT}, input commands from a file are not kept in the system, and so cannot be edited using {\tt ED}. However, many implementations of {\REDUCE} provide a link to an external system editor that can be used for such editing. The specific instructions for the particular implementation should be consulted for information on this. Two commands are available in {\REDUCE} for interactive use of files. {\tt PAUSE}; \ttindex{PAUSE} may be inserted at any point in an input file. When this command is encountered on input, the system prints the message {\tt CONT?} on the user's terminal and halts. If the user responds {\tt Y} (for yes), the calculation continues from that point in the file. If the user responds {\tt N} (for no), control is returned to the terminal, and the user can input further statements and commands. Later on he can use the command {\tt cont;} \ttindex{CONT} to transfer control back to the point in the file following the last {\tt PAUSE} encountered. A top-level {\tt pause;} \ttindex{PAUSE} from the user's terminal has no effect. \chapter{Matrix Calculations} \index{Matrix calculations} A very powerful feature of {\REDUCE} is the ease with which matrix calculations can be performed. To extend our syntax to this class of calculations we need to add another prefix operator, {\tt MAT}, \ttindex{MAT} and a further variable and expression type as follows: \section{MAT Operator} \ttindex{MAT} This prefix operator is used to represent {\em n} x {\em m} matrices. {\tt MAT} has {\em n} arguments interpreted as rows of the matrix, each of which is a list of {\em m} expressions representing elements in that row. For example, the matrix \[ \left( \begin{array}{lcr} a & b & c \\ d & e & f \end{array} \right) \] would be written as {\tt mat((a,b,c),(d,e,f))}. Note that the single column matrix \[ \left( \begin{array}{c} x \\ y \end{array} \right) \] becomes {\tt mat((x),(y))}. The inside parentheses are required to distinguish it from the single row matrix \[ \left( \begin{array}{lr} x & y \end{array} \right) \] which would be written as {\tt mat((x,y))}. \section{Matrix Variables} An identifier may be declared a matrix variable by the declaration {\tt MATRIX}.\ttindex{MATRIX} The size of the matrix may be declared explicitly in the matrix declaration, or by default in assigning such a variable to a matrix expression. For example, \begin{verbatim} matrix x(2,1),y(3,4),z; \end{verbatim} declares {\tt X} to be a 2 x 1 (column) matrix, {\tt Y} to be a 3 x 4 matrix and {\tt Z} a matrix whose size is to be declared later. Matrix declarations can appear anywhere in a program. Once a symbol is declared to name a matrix, it can not also be used to name an array, operator or a procedure, or used as an ordinary variable. It can however be re-declared to be a matrix, and its size may be changed at that time. Note however that matrices once declared are {\em global} in scope, and so can then be referenced anywhere in the program. In other words, a declaration within a block (or a procedure) does not limit the scope of the matrix to that block, nor does the matrix go away on exiting the block (use {\tt CLEAR} instead for this purpose). An element of a matrix is referred to in the expected manner; thus {\tt x(1,1)} gives the first element of the matrix {\tt X} defined above. References to elements of a matrix whose size has not yet been declared leads to an error. All elements of a matrix whose size is declared are initialized to 0. As a result, a matrix element has an ``instant evaluation" \index{Instant evaluation} property and cannot stand for itself. If this is required, then an operator (q.v.) should be used to name the matrix elements as in: \begin{verbatim} matrix m; operator x; m := mat((x(1,1),x(1,2)); \end{verbatim} \section{Matrix Expressions} These follow the normal rules of matrix algebra as defined by the following syntax: \ttindex{MAT} \begin{verbatim} <matrix expression> ::= MAT<matrix description>|<matrix variable>| <scalar expression>*<matrix expression>| <matrix expression>*<matrix expression> <matrix expression>+<matrix expression>| <matrix expression>^<integer>| <matrix expression>/<matrix expression> \end{verbatim} Sums and products of matrix expressions must be of compatible size; otherwise an error will result during their evaluation. Similarly, only square matrices may be raised to a power. A negative power is computed as the inverse of the matrix raised to the corresponding positive power. {\tt a/b} is interpreted as {\tt a*b\^{ }(-1)}. {\it Examples:} Assuming {\tt X} and {\tt Y} have been declared as matrices, the following are matrix expressions \begin{verbatim} y y^2*x-3*y^(-2)*x y + mat((1,a),(b,c))/2 \end{verbatim} The computation of the quotient of two matrices normally uses a two-step elimination method due to Bareiss. An alternative method using Cramer's method is also available. This is often more efficient than the Bareiss method, although we have no solid statistics on this as yet. To use Cramer's method instead, the switch {\tt CRAMER} should be turned on. \section{Operators with Matrix Arguments} The operator {\tt LENGTH} (q.v.) \ttindex{LENGTH} applied to a matrix returns a list of the number of rows and columns in the matrix. Three additional operators are useful in matrix calculations, namely {\tt DET}, {\tt TP} and {\tt TRACE} defined in the following subsections. \subsection{DET Operator} \ttindex{DET} Syntax: \begin{verbatim} DET(EXPRN:matrix_expression):algebraic. \end{verbatim} The operator {\tt DET} is used to represent the determinant of a square matrix expression. E.g., \begin{verbatim} det(y^2) \end{verbatim} is a scalar expression whose value is the determinant of the square of the matrix {\tt Y}, and \begin{verbatim} det mat((a,b,c),(d,e,f),(g,h,j)); \end{verbatim} is a scalar expression whose value is the determinant of the matrix \[ \left( \begin{array}{lcr} a & b & c \\ d & e & f \\ g & h & j \end{array} \right) \] Determinant expressions have the ``instant evaluation" property. \index{Instant evaluation} In other words, the statement \begin{verbatim} let det mat((a,b),(c,d)) = 2; \end{verbatim} sets the {\em value} of the determinant to 2, and does not set up a rule for the determinant itself. \subsection{MATEIGEN Operator} \ttindex{MATEIGEN} Syntax: \begin{verbatim} MATEIGEN(EXPRN:matrix_expression,ID):list. \end{verbatim} {\tt MATEIGEN} calculates the eigenvalue equation and the corresponding eigenvectors of a matrix, using the variable {\tt ID} to denote the eigenvalue. A square free decomposition of the characteristic polynomial is carried out. The result is a list of lists of 3 elements, where the first element is a square free factor of the characteristic polynomial, the second its multiplicity and the third the corresponding eigenvector (as an {\em n} by 1 matrix). If the square free decomposition was successful, the product of the first elements in the lists is the minimal polynomial. In the case of degeneracy, several eigenvectors can exist for the same eigenvalue, which manifests itself in the appearance of more than one arbitrary variable in the eigenvector. To extract the various parts of the result use the operations defined on lists. {\it Example:} The command \begin{verbatim} mateigen(mat((2,-1,1),(0,1,1),(-1,1,1)),eta); \end{verbatim} gives the output \begin{verbatim} {{ETA - 1,2, [ARBCOMPLEX(1)] [ ] [ARBCOMPLEX(1)] [ ] [ 0 ] }, {ETA - 2,1, [ 0 ] [ ] [ARBCOMPLEX(2)] [ ] [ARBCOMPLEX(2)] }} \end{verbatim} \subsection{TP Operator} \ttindex{TP} Syntax: \begin{verbatim} TP(EXPRN:matrix_expression):matrix. \end{verbatim} This operator takes a single matrix argument and returns its transpose. \subsection{Trace Operator} \ttindex{TRACE} Syntax: \begin{verbatim} TRACE(EXPRN:matrix_expression):algebraic. \end{verbatim} The operator {\tt TRACE} is used to represent the trace of a square matrix. \subsection{Matrix Cofactors} \ttindex{COFACTOR} Syntax: \begin{verbatim} COFACTOR(EXPRN:matrix_expression,ROW:integer,COLUMN:integer): algebraic \end{verbatim} The operator {\tt COFACTOR} returns the cofactor of the element in row {\tt ROW} and column {\tt COLUMN} of the matrix {\tt MATRIX}. Errors occur if {\tt ROW} or {\tt COLUMN} do not simplify to integer expressions or if {\tt MATRIX} is not square. \subsection{NULLSPACE Operator} \ttindex{NULLSPACE} Syntax: \begin{verbatim} NULLSPACE(EXPRN:matrix_expression):list \end{verbatim} {\tt NULLSPACE} calculates for a matrix {\tt A} a list of linear independent vectors (a basis) whose linear combinations satisfy the equation $A x = 0$. The basis is provided in a form such that as many upper components as possible are isolated. Note that with {\tt b := nullspace a} the expression {\tt length b} is the {\em nullity} of A, and that {\tt second length a - length b} calculates the {\em rank} of A. The rank of a matrix expression can also be found more directly by the {\tt RANK} operator described below. {\it Example:} The command \begin{verbatim} nullspace mat((1,2,3,4),(5,6,7,8)); \end{verbatim} gives the output \begin{verbatim} { [ 1 ] [ ] [ 0 ] [ ] [ - 3] [ ] [ 2 ] , [ 0 ] [ ] [ 1 ] [ ] [ - 2] [ ] [ 1 ] } \end{verbatim} In addition to the {\REDUCE} matrix form, {\tt NULLSPACE} accepts as input a matrix given as a list of lists, which is interpreted as a row matrix. If that form of input is chosen, the vectors in the result will be represented by lists as well. This additional input syntax facilitates the use of {\tt NULLSPACE} in applications different from classical linear algebra. \subsection{RANK Operator} \ttindex{RANK} Syntax: \begin{verbatim} RANK(EXPRN:matrix_expression):integer \end{verbatim} {\tt RANK} calculates the rank of its argument, which, like {\tt NULLSPACE} can either be a standard matrix expression, or a list of lists, which can be interpreted either as a row matrix or a set of equations. {\tt Example:} \begin{verbatim} rank mat((a,b,c),(d,e,f)); \end{verbatim} returns the value 2. \section{Matrix Assignments} \index{Matrix assignment} Matrix expressions may appear in the right-hand side of assignment statements. If the left-hand side of the assignment, which must be a variable, has not already been declared a matrix, it is declared by default to the size of the right-hand side. The variable is then set to the value of the right-hand side. Such an assignment may be used very conveniently to find the solution of a set of linear equations. For example, to find the solution of the following set of equations \begin{verbatim} a11*x(1) + a12*x(2) = y1 a21*x(1) + a22*x(2) = y2 \end{verbatim} we simply write \begin{verbatim} x := 1/mat((a11,a12),(a21,a22))*mat((y1),(y2)); \end{verbatim} \section{Evaluating Matrix Elements} Once an element of a matrix has been assigned, it may be referred to in standard array element notation. Thus {\tt y(2,1)} refers to the element in the second row and first column of the matrix {\tt Y}. \chapter{Procedures} \ttindex{PROCEDURE} It is often useful to name a statement for repeated use in calculations with varying parameters, or to define a complete evaluation procedure for an operator. {\REDUCE} offers a procedural declaration for this purpose. Its general syntax is: \begin{verbatim} [<procedural type>] PROCEDURE <name>[<varlist>];<statement>; \end{verbatim} where \begin{verbatim} <varlist> ::= (<variable>,...,<variable>) \end{verbatim} This will be explained more fully in the following sections. In the algebraic mode of {\REDUCE} the {\tt <procedure type>} can be omitted, since the default is {\tt ALGEBRAIC}. Procedures of type {\tt INTEGER} or {\tt REAL} may also be used. In the former case, the system checks that the value of the procedure is an integer. At present, such checking is not done for a real procedure, although this will change in the future when a more complete type checking mechanism is installed. Users should therefore only use these types when appropriate. An empty variable list may also be omitted. All user-defined procedures are automatically declared to be operators. In order to allow users relatively easy access to the whole {\REDUCE} source program, system procedures are not protected against user redefinition. If a procedure is redefined, a message \begin{verbatim} *** <procedure name> REDEFINED \end{verbatim} is printed. If this occurs, and the user is not redefining his own procedure, he is well advised to rename it, and possibly start over (because he has {\em already} redefined some internal procedure whose correct functioning may be required for his job!) All required procedures should be defined at the top level, since they have global scope throughout a program. In particular, an attempt to define a procedure within a procedure will cause an error to occur. \section{Procedure Heading} \index{Procedure heading} Each procedure has a heading consisting of the word {\tt PROCEDURE} (optionally preceded by the word {\tt ALGEBRAIC}), followed by the name of the procedure to be defined, and followed by its formal parameters -- the symbols which will be used in the body of the definition to illustrate what is to be done. There are three cases: \begin{enumerate} \item No parameters. Simply follow the procedure name with a terminator (semicolon or dollar sign). \begin{verbatim} procedure abc; \end{verbatim} When such a procedure is used in an expression or command, {\tt abc()}, with empty parentheses, must be written. \item One parameter. Enclose it in parentheses {\em or} just leave at least one space, then follow with a terminator. \begin{verbatim} procedure abc(x); \end{verbatim} or \begin{verbatim} procedure abc x; \end{verbatim} \item More than one parameter. Enclose them in parentheses, separated by commas, then follow with a terminator. \begin{verbatim} procedure abc(x,y,z); \end{verbatim} \end{enumerate} Referring to the last example, if later in some expression being evaluated the symbols {\tt abc(u,p*q,123)} appear, the operations of the procedure body will be carried out as if {\tt X} had the same value as {\tt U} does, {\tt Y} the same value as {\tt p*q} does, and {\tt Z} the value 123. The values of {\tt X}, {\tt Y}, {\tt Z}, after the procedure body operations are completed are unchanged. So, normally, are the values of {\tt U}, {\tt P}, {\tt Q}, and (of course) 123. (This is technically referred to as call by value.) \index{Call by value} The reader will have noted the word {\em normally} a few lines earlier. The call by value protections can be bypassed if necessary, as described elsewhere. \section{Procedure Body} \index{Procedure body} Following the delimiter which ends the procedure heading must be a {\em single} statement defining the action to be performed or the value to be delivered. A terminator must follow the statement. If it is a semicolon, the name of the procedure just defined is printed. It is not printed if a dollar sign is used. If the result wanted is given by a formula of some kind, the body is just that formula, using the variables in the procedure heading. {\it Simple Example:} If {\tt f(x)} is to mean {\tt (x+5)*(x+6)/(x+7)}, the entire procedure definition could read \begin{verbatim} procedure f x; (x+5)*(x+6)/(x+7); \end{verbatim} Then {\tt f(10)} would evaluate to 240/17, {\tt f(a-6)} to {\tt A*(A-1)/(A+1)}, and so on. {\it More Complicated Example:} Suppose we need a function {\tt p(n,x)} which, for any positive integer {\tt N}, is the Legendre polynomial \index{Legendre polynomial} of order {\em n}. We can define this operator using the textbook formula defining these functions: \begin{displaymath} p_n(x) = \displaystyle{1\over{n!}}\ \displaystyle{d^n\over dy^n}\ \displaystyle{{1\over{(y^2 - 2xy + 1) ^{{1\over2}}}}}\Bigg\vert_{y=0} \end{displaymath} Put into words, the Legendre polynomial $p_n(x)$ is the result of substituting $y=0$ in the $n^{th}$ partial derivative with respect to $y$ of a certain fraction involving $x$ and $y$, then dividing that by $n!$. This verbal formula can easily be written in {\REDUCE}: \begin{verbatim} procedure p(n,x); sub(y=0,df(1/(y^2-2*x*y+1)^(1/2),y,n)) /(for i:=1:n product i); \end{verbatim} Having input this definition, the expression evaluation \begin{verbatim} 2p(2,w); \end{verbatim} would result in the output \begin{verbatim} 2 3*W - 1 . \end{verbatim} If the desired process is best described as a series of steps, then a group or compound statement can be used. {\it Example:} The above Legendre polynomial example can be rewritten as a series of steps instead of a single formula as follows: \begin{verbatim} procedure p(n,x); begin scalar seed,deriv,top,fact; seed:=1/(y^2 - 2*x*y +1)^(1/2); deriv:=df(seed,y,n); top:=sub(y=0,deriv); fact:=for i:=1:n product i; return top/fact end; \end{verbatim} Procedures may also be defined recursively. In other words, the procedure body \index{Procedure body} can include references to the procedure name itself, or to other procedures which themselves reference the given procedure. As an example, we can define the Legendre polynomial through its standard recurrence relation: \begin{verbatim} procedure p(n,x); if n<0 then rederr "Invalid argument to P(N,X)" else if n=0 then 1 else if n=1 then x else ((2*n-1)*x*p(n-1,x)-(n-1)*p(n-2,x))/n; \end{verbatim} The operator {\tt REDERR} \ttindex{REDERR} in the above example provides for a simple error exit from an algebraic procedure (and also a block). It can take a string as argument. It should be noted however that all the above definitions of {\tt p(n,x)} are quite inefficient if extensive use is to be made of such polynomials, since each call effectively recomputes all lower order polynomials. It would be better to store these expressions in an array, and then use say the recurrence relation to compute only those polynomials that have not already been derived. We leave it as an exercise for the reader to write such a definition. \section{Using LET Inside Procedures} By using {\tt LET} \ttindex{LET} instead of an assignment in the procedure body \index{Procedure body} it is possible to bypass the call-by-value \index{Call by value} protection. If {\tt X} is a formal parameter or local variable of the procedure (i.e. is in the heading or in a local declaration), and {\tt LET} is used instead of {\tt :=} to make an assignment to {\tt X}, e.g. \begin{verbatim} let x = 123; \end{verbatim} then it is the variable which is the value of {\tt X} that is changed. This effect also occurs with local variables defined in a block. If the value of {\tt X} is not a variable, but a more general expression, then it is that expression that is used on the left-hand side of the {\tt LET} statement. For example, if {\tt X} had the value {\tt p*q}, it is as if {\tt let p*q = 123} had been executed. \section{LET Rules as Procedures} The {\tt LET} \ttindex{LET} statement offers an alternative syntax and semantics for procedure definition. In place of \begin{verbatim} procedure abc(x,y,z); <procedure body>; \end{verbatim} one can write \begin{verbatim} for all x,y,z let abc(x,y,z) = <procedure body>; \end{verbatim} There are several differences to note. If the procedure body contains an assignment to one of the formal parameters, e.g. \begin{verbatim} x := 123; \end{verbatim} in the {\tt PROCEDURE} case it is a variable holding a copy of the first actual argument which is changed. The actual argument is not changed. In the {\tt LET} case, the actual argument is changed. Thus, if {\tt ABC} is defined using {\tt LET}, and {\tt abc(u,v,w)} is evaluated, the value of {\tt U} changes to 123. That is, the {\tt LET} form of definition allows the user to bypass the protections which are enforced by the call by value conventions of standard {\tt PROCEDURE} definitions. {\it Example:} We take our earlier {\tt FACTORIAL} \ttindex{FACTORIAL} procedure and write it as a {\tt LET} statement. \begin{verbatim} for all n let factorial n = begin scalar m,s; m:=1; s:=n; l1: if s=0 then return m; m:=m*s; s:=s-1; go to l1 end; \end{verbatim} The reader will notice that we introduced a new local variable, {\tt S}, and set it equal to {\tt N}. The original form of the procedure contained the statement {\tt n:=n-1;}. If the user asked for the value of {\tt factorial(5)} then {\tt N} would correspond to -- not just have the value of -- 5, and {\REDUCE} would object to trying to execute the statement 5:=5-1. If {\tt PQR} is a procedure with no parameters, \begin{verbatim} procedure pqr; <procedure body>; \end{verbatim} it can be written as a {\tt LET} statement quite simply: \begin{verbatim} let pqr = <procedure body>; \end{verbatim} To call {\em procedure} {\tt PQR}, if defined in the latter form, the empty parentheses would not be used: use {\tt PQR} not {\tt PQR()} where a call on the procedure is needed. The two notations for a procedure with no arguments can be combined. {\tt PQR} can be defined in the standard {\tt PROCEDURE} form. Then a {\tt LET} statement \begin{verbatim} let pqr = pqr(); \end{verbatim} would allow a user to use {\tt PQR} instead of {\tt PQR()} in calling the procedure. A feature available with {\tt LET}-defined procedures and not with procedures defined in the standard way is the possibility of defining partial functions. \index{Function} \begin{verbatim} for all x such that numberp x let uvw(x)=<procedure body>; \end{verbatim} Now {\tt UVW} of an integer would be calculated as prescribed by the procedure body, while {\tt UVW} of a general argument, such as {\tt Z} or {\tt p+q} (assuming these evaluate to themselves) would simply stay {\tt uvw(z)} or {\tt uvw(p+q)} as the case may be. \chapter{User Contributed Packages} \index{User packages} The complete {\REDUCE} system includes a number of packages that have been contributed by users. These packages are unsupported, but are provided with the {\REDUCE} distribution as a service to the user community. All questions regarding these packages should therefore be directed to their individual authors, who are solely responsible for their maintenance and development. There are two classes of such packages. The first are those for which explicit files exist in the source, test and documentation directories on the system tape. The second are those which are bundled into a single library directory ``lib" on the system tape, although this organization may differ from implementation to implementation. All packages in the first class have been precompiled as part of the installation process. However, in order to emphasize the unsupported nature of these packages, many must be specifically loaded before they can be used. (Those that are loaded automatically are noted specifically in their description.) You should consult the user notes for your particular implementation for further information on whether this is necessary. If it is, the relevant command is {\tt LOAD\_PACKAGE}, \index{Load package} which takes a list of one or more package names as argument, for example: \begin{verbatim} load_package algint; \end{verbatim} although this syntax may vary from implementation to implementation. Packages in the second class must be individually compiled and loaded by the installer or user. Most packages come with separate documentation and test file (except for some very simple packages in the ``lib" directory, and those noted here that have no additional documentation), which is included, along with the source of the package, in the {\REDUCE} system distribution. These items should be studied for details on the use of any particular package. We also list below the packages in the first class available in the current release of {\REDUCE}, together with a brief paragraph describing their capabilities. More detailed documentation may be found in the ``doc'' directory of the REDUCE system distribution. The packages in the second class are listed in a header ``README'' file in the ``lib'' directory. In some cases, the additional documentation for these packages is in plain text. However, an increasing number of documents are now being supplied in {\LaTeX} format (and one in troff form). Those documents not in plain text are so noted in the descriptions below. \section{ALGINT: Integration of Square Roots} \ttindex{ALGINT} This package, which is an extension of the basic integration package distributed with {\REDUCE}, will analytically integrate a wide range of expressions involving square roots where the answer exists in that class of functions. It is an implementation of the work described in J.H. Davenport, ``On the Integration of Algebraic Functions", LNCS 102, Springer Verlag, 1981. Both this and the source code should be consulted for a more detailed description of this work. Once the {\tt ALGINT} package has been loaded, using {\tt LOAD\_PACKAGE}, one enters an expression for integration, as with the regular integrator (q.v.), for example: \begin{verbatim} int(sqrt(x+sqrt(x**2+1)/x,x); \end{verbatim} If one later wishes to integrate expressions without using the facilities of this package, the switch {\tt ALGINT} \ttindex{ALGINT} should be turned off. This is turned on automatically when the package is loaded. The switches supported by the standard integrator (e.g., {\tt TRINT}) \ttindex{TRINT} are also supported by this package. In addition, the switch {\tt TRA}, \ttindex{TRA} if on, will give further tracing information about the specific functioning of the algebraic integrator. There is no additional documentation for this package. \\ \\ Author: James H. Davenport. \section{ARNUM: An Algebraic Number Package} \ttindex{ARNUM} This package provides facilities for handling algebraic numbers as polynomial coefficients in {\REDUCE} calculations. It includes facilities for introducing indeterminates to represent algebraic numbers, for calculating splitting fields, and for factoring and finding greatest common divisors in such domains. \\ \\ Author: Eberhard Schr\"ufer. \section{AVECTOR: A Vector Algebra and Calculus Package} \ttindex{AVECTOR} This package provides REDUCE with the ability to perform vector algebra using the same notation as scalar algebra. The basic algebraic operations are supported, as are differentiation and integration of vectors with respect to scalar variables, cross product and dot product, component manipulation and application of scalar functions (e.g. cosine) to a vector to yield a vector result. The documentation for this package is in {\LaTeX} format. \\ \\ Author: David Harper. \section{COMPACT: A Package for Compacting Expressions} \ttindex{COMPACT} COMPACT is a package of functions for the reduction of a polynomial in the presence of side relations. COMPACT applies the side relations to the polynomial so that an equivalent expression results with as few terms as possible. For example, the evaluation of \begin{verbatim} compact(s*(1-sin x^2)+c*(1-cos x^2)+sin x^2+cos x^2, {cos x^2+sin x^2=1}); \end{verbatim} yields the result \begin{verbatim} 2 2 SIN(X) *C + COS(X) *S + 1 \end{verbatim} The documentation for this package is in {\LaTeX} format. \\ \\ Author: Anthony C. Hearn. \section{EXCALC: A Differential Geometry Package} \ttindex{EXCALC} EXCALC is designed for easy use by all who are familiar with the calculus of Modern Differential Geometry. The program is currently able to handle scalar-valued exterior forms, vectors and operations between them, as well as non-scalar valued forms (indexed forms). It is thus an ideal tool for studying differential equations, doing calculations in general relativity and field theories, or doing simple things such as calculating the Laplacian of a tensor field for an arbitrary given frame. \\ \\ Author: Eberhard Schr\"ufer. \section{GENTRAN: A Code Generation Package} \ttindex{GENTRAN} GENTRAN is an automatic code GENerator and TRANslator. It constructs complete numerical programs based on sets of algorithmic specifications and symbolic expressions. Formatted FORTRAN, RATFOR, PASCAL or C code can be generated through a series of interactive commands or under the control of a template processing routine. Large expressions can be automatically segmented into subexpressions of manageable size, and a special file-handling mechanism maintains stacks of open I/O channels to allow output to be sent to any number of files simultaneously and to facilitate recursive invocation of the whole code generation process. The documentation for this package is in {\LaTeX} format. \\ \\ Author: Barbara L. Gates. \section{GROEBNER: A Gr\"obner Basis Package} \index{Gr\"obner basis} GROEBNER \ttindex{GROEBNER} is a package for the computation of Gr\"obner Bases using the Buchberger algorithm. It can be used over a variety of different coefficient domains, and for different variable and term orderings. The documentation for this package is in {\LaTeX} format. \\ \\ Authors: Herbert Melenk, H.M. M\"oller and Winfried Neun. \section{LIMITS: A Package for Finding Limits} \ttindex{LIMITS} LIMITS is a fast limit package for REDUCE for functions which are continuous except for computable poles and singularities, based on some earlier work by Ian Cohen and John P. Fitch. The Truncated Power Series package is used for non-critical points, at which the value of the function is the constant term in the expansion around that point. L'Hopital's rule is used in critical cases, with preprocessing of $\infty - \infty$ forms and reformatting of product forms in order to be able to apply l'Hopital's rule. A limited amount of bounded arithmetic is also employed where applicable. This package defines a {\tt LIMIT} operator, called with the syntax: \begin{verbatim} LIMIT(EXPRN:algebraic,VAR:kernel,LIMPOINT:algebraic): algebraic. \end{verbatim} For example: \begin{verbatim} limit(x*sin(1/x),x,infinity) -> 1 limit(sin x/x^2,x,0) -> INFINITY \end{verbatim} Direction-dependent limit operators {\tt LIMIT!+} and {\tt LIMIT!-} are also defined. This package loads automatically. The documentation for this package is in {\LaTeX} format. \\ \\ Author: Stanley L. Kameny. \section{ODESOLVE: A Solver for Ordinary Differential Equations} \ttindex{ODESOLVE} The ODESOLVE package is a solver for ordinary differential equations. At the present time it has very limited capabilities. It can handle only a single scalar equation presented as an algebraic expression or equation, and it can solve only first-order equations of simple types, linear equations with constant coefficients and Euler equations. These solvable types are exactly those for which Lie symmetry techniques give no useful information. For example, the evaluation of \begin{verbatim} depend(y,x); odesolve(df(y,x)=x**2+e**x,y,x); \end{verbatim} yields the result \begin{verbatim} X 3 3*E + 3*ARBCONST(1) + X {Y=---------------------------} 3 \end{verbatim} The documentation for this package is in {\LaTeX} format. \\ \\ Main Author: Malcolm A.H. MacCallum. Other contributors: Francis Wright, Alan Barnes. \section{ORTHOVEC: A Package for the Manipulation of Scalars and Vectors} \ttindex{ORTHOVEC} ORTHOVEC is a collection of REDUCE procedures and operations which provide a simple-to-use environment for the manipulation of scalars and vectors. Operations include addition, subtraction, dot and cross products, division, modulus, div, grad, curl, laplacian, differentiation, integration, and Taylor expansion. The documentation for this package is in {\LaTeX} format. \\ \\ Author: James W. Eastwood. \section{ROOTS: A REDUCE Root Finding Package} \ttindex{ROOTS} This root finding package can be used to find some or all of the roots of a univariate polynomial with real or complex coefficients, to the accuracy specified by the user. It is designed so that it can be used as an independent package, or it may be called from {\tt SOLVE} if {\tt ROUNDED} is on. For example, the evaluation of \begin{verbatim} on rounded,complex; solve(x**3+x+5,x); \end{verbatim} yields the result \begin{verbatim} {X= - 1.51598,X=0.75799 + 1.65035*I,X=0.75799 - 1.65035*I} \end{verbatim} This package loads automatically. \\ \\ Author: Stanley L. Kameny. \section{SCOPE: A Source Code Optimization Package for REDUCE} \ttindex{SCOPE} SCOPE is a package for the production of an optimized form of a set of expressions. It applies an heuristic search for common (sub)expressions to almost any set of proper REDUCE assignment statements. The output is obtained as a sequence of assignment statements. GENTRAN is used to facilitate expression output. The document for this package is in troff format. \\ \\ Author: J.A. van Hulzen. \section{SPDE: A Package for finding Symmetry groups of {PDE}'s} \ttindex{SPDE} The package SPDE provides a set of functions which may be used to determine the symmetry group of Lie- or point-symmetries of a given system of partial differential equations. In many cases the determining system is solved completely automatically. In other cases the user has to provide additional input information for the solution algorithm to terminate. \\ \\ Author: Fritz Schwarz. \section{SUM: A Package for Series Summation} \ttindex{SUM} This package implements the Gosper algorithm for the summation of series. It defines operators {\tt SUM} and {\tt PROD}. The operator {\tt SUM} returns the indefinite or definite summation of a given expresson, and {\tt PROD} returns the product of the given expression. This package loads automatically. The documentation for this package is in {\LaTeX} format. \\ \\ Author: Fujio Kako. \section{TAYLOR: A Package for the Manipulation of Taylor Series} \ttindex{TAYLOR} This package carries out the Taylor expansion of an expression in one or more variables and efficient manipulation of the resulting Taylor series. Capabilities include basic operations (addition, subtraction, multiplication and division) and also application of certain algebraic and transcendental functions. The document for this package is in {\LaTeX} format. \\ \\ Author: Rainer Sch\"opf. \section{TPS: A Truncated Power Series Package} \ttindex{TPS} \ttindex{PS} This package implements formal Laurent series expansions in one variable using the domain mechanism of REDUCE. This means that power series objects can be added, multiplied, differentiated etc., like other first class objects in the system. A lazy evaluation scheme is used and thus terms of the series are not evaluated until they are required for printing or for use in calculating terms in other power series. The series are extendible giving the user the impression that the full infinite series is being manipulated. The errors that can sometimes occur using series that are truncated at some fixed depth (for example when a term in the required series depends on terms of an intermediate series beyond the truncation depth) are thus avoided. The documentation for this package is in {\LaTeX} format. \\ \\ Authors: Alan Barnes and Julian Padget. \chapter{Symbolic Mode} \index{Symbolic mode} At the system level, {\REDUCE} is based on a version of the programming language Lisp \index{Lisp} known as {\em Standard Lisp} which is described in J. Marti, Hearn, A. C., Griss, M. L. and Griss, C., ``Standard LISP Report" SIGPLAN Notices, ACM, New York, 14, No 10 (1979) 48-68. We shall assume in this section that the reader is familiar with the material in that paper. This also assumes implicitly that the reader has a reasonable knowledge about Lisp in general, say at the level of the LISP 1.5 Programmer's Manual (McCarthy, J., Abrahams, P. W., Edwards, D. J., Hart, T. P. and Levin, M. I., ``LISP 1.5 Programmer's Manual", M.I.T. Press, 1965) or any of the books mentioned at the end of this section. Persons unfamiliar with this material will have some difficulty understanding this section. Although {\REDUCE} is designed primarily for algebraic calculations, its source language is general enough to allow for a full range of Lisp-like symbolic calculations. To achieve this generality, however, it is necessary to provide the user with two modes of evaluation, namely an algebraic mode \index{Algebraic mode} and a symbolic mode. \index{Symbolic mode} To enter symbolic mode, the user types {\tt symbolic;} \ttindex{SYMBOLIC} (or {\tt lisp;}) \ttindex{LISP} and to return to algebraic mode he types {\tt algebraic;}. \ttindex{ALGEBRAIC}. Evaluations proceed differently in each mode so the user is advised to check what mode he is in if a puzzling error arises. He can find his mode by typing \ttindex{"!*MODE} \begin{verbatim} !*mode; \end{verbatim} The current mode will then be printed as {\tt ALGEBRAIC} or {\tt SYMBOLIC}. Expression evaluation may proceed in either mode at any level of a calculation, provided the results are passed from mode to mode in a compatible manner. One simply prefixes the relevant expression by the appropriate mode. If the mode name prefixes an expression at the top level, it will then be handled as if the global system mode had been changed for the scope of that particular calculation. For example, if the current mode is {\tt ALGEBRAIC}, then the commands \begin{verbatim} symbolic car '(a); x+y; \end{verbatim} will cause the first expression to be evaluated and printed in symbolic mode and the second in algebraic mode. Only the second evaluation will thus affect the expression workspace. On the other hand, the statement \begin{verbatim} x + symbolic car '(12); \end{verbatim} will result in the algebraic value {\tt X+12}. The use of {\tt SYMBOLIC} (and equivalently {\tt ALGEBRAIC}) in this manner is the same as any operator. That means that parentheses could be omitted in the above examples since the meaning is obvious. In other cases, parentheses must be used, as in \begin{verbatim} symbolic(x := 'a); \end{verbatim} Omitting the parentheses, as in \begin{verbatim} symbolic x := a; \end{verbatim} would be wrong, since it would parse as \begin{verbatim} symbolic(x) := a; \end{verbatim} For convenience, it is assumed that any operator whose {\em first} argument is quoted is being evaluated in symbolic mode, regardless of the mode in effect at that time. Thus, the first example above could be equally well written: \begin{verbatim} car '(a); \end{verbatim} Except where explicit limitations have been made, most {\REDUCE} algebraic constructions carry over into symbolic mode. \index{Symbolic mode} However, there are some differences. First, expression evaluation now becomes Lisp evaluation. Secondly, assignment statements are handled differently, as we shall discuss shortly. Thirdly, local variables and array elements are initialized to {\tt NIL} rather than {\tt 0}. (In fact, any variables not explicitly declared {\tt INTEGER} are also initialized to {\tt NIL} in algebraic mode, but the algebraic evaluator recognizes {\tt NIL} as {\tt 0}.) Finally, function definitions follow the conventions of Standard Lisp. To begin with, we mention a few extensions to our basic syntax which are designed primarily if not exclusively for symbolic mode. \section{Symbolic Infix Operators} There are four binary infix operators in {\REDUCE} intended for use in symbolic mode, namely . {\tt (CONS), EQ, MEMBER and MEMQ}. The precedence of these operators was given in another section. \section{Symbolic Expressions} These consist of scalar variables and operators and follow the normal rules of the Lisp meta language. {\it Examples:} \begin{verbatim} x car u . reverse v simp (u+v^2) \end{verbatim} \section{Quoted Expressions} \ttindex{QUOTE} Because symbolic evaluation requires that each variable or expression has a value, it is necessary to add to {\REDUCE} the concept of a quoted expression by analogy with the Lisp {\tt QUOTE} function. This is provided by the single quote mark {\tt '}. For example, \begin{quote} \begin{tabbing} {\tt 'a} \hspace{0.5in} \= represents the Lisp S-expression \hspace{0.2 in} \= {\tt (quote a)} \\ {\tt '(a b c)} \> represents the Lisp S-expression \> {\tt (quote (a b c))} \end{tabbing} \end{quote} Note, however, that strings are constants and therefore evaluate to themselves in symbolic mode. Thus, to print the string {\tt "A String"}, one would write \begin{verbatim} prin2 "A String"; \end{verbatim} Within a quoted expression, identifier syntax rules are those of {\REDUCE}. Thus {\tt ( A !. B)} is the list consisting of the three elements {\tt A}, {\tt .}, and {\tt B}, whereas {\tt (A . B)} is the dotted pair of {\tt A} and {\tt B}. \section{Lambda Expressions} \ttindex{LAMBDA} \label{sec-lambda} {\tt LAMBDA} expressions provide the means for constructing Lisp {\tt LAMBDA} expressions in symbolic mode. They may not be used in algebraic mode. Syntax: \begin{verbatim} <LAMBDA expression> ::= LAMBDA <varlist><terminator><statement> \end{verbatim} where \begin{verbatim} <varlist> ::= (<variable>,...,<variable>) \end{verbatim} e.g., \begin{verbatim} lambda (x,y); car x . cdr y; \end{verbatim} is equivalent to the Lisp {\tt LAMBDA} expression \begin{verbatim} (lambda (x y) (cons (car x) (cdr y))) \end{verbatim} The parentheses may be omitted in specifying the variable list if desired. {\tt LAMBDA} expressions may be used in symbolic mode in place of prefix operators, or as an argument of the reserved word {\tt FUNCTION}. In those cases where a {\tt LAMBDA} expression is used to introduce local variables to avoid recomputation, a {\tt WHERE} statement can also be used. For example, the expression \begin{verbatim} (lambda (x,y); list(car x,cdr x,car y,cdr y)) (reverse u,reverse v) \end{verbatim} can also be written \begin{verbatim} {car x,cdr x,car y,cdr y} where x=reverse u,y=reverse v \end{verbatim} Where possible, {\tt WHERE} syntax is preferred to {\tt LAMBDA} syntax, since it is more natural. \section{Symbolic Assignment Statements} \index{Assignment} In symbolic mode, if the left side of an assignment statement is a variable, a {\tt SETQ} of the right-hand side to that variable occurs. If the left-hand side is an expression, it must be of the form of an array element, otherwise an error will result. For example, {\tt x:=y} translates into {\tt (SETQ X Y)} whereas {\tt a(3) := 3} will be valid if {\tt A} has been previously declared a single dimensioned array of at least four elements. \section{FOR EACH Statement} \ttindex{FOR EACH} The {\tt FOR EACH} form of the {\tt FOR} statement, designed for iteration down a list, is more general in symbolic mode. Its syntax is: \begin{verbatim} FOR EACH ID:identifier {IN|ON} LST:list {DO|COLLECT|JOIN|PRODUCT|SUM} EXPRN:S-expr \end{verbatim} As in algebraic mode, if the keyword {\tt IN} is used, iteration is on each element of the list. With {\tt ON}, iteration is on the whole list remaining at each point in the iteration. As a result, we have the following equivalence between each form of {\tt FOR EACH} and the various mapping functions in Lisp: \begin{center} {\tt \begin{tabular}{|l|lr r|} \hline & DO & COLLECT & JOIN \\ \hline IN & MAPC & MAPCAR & MAPCAN \\ ON & MAP & MAPLIST & MAPCON \\ \hline \end{tabular}} \end{center} {\it Example:} To list each element of the list {\tt (a b c)}: \begin{verbatim} for each x in '(a b c) collect list x; \end{verbatim} \section{Symbolic Procedures} \index{Symbolic procedure} All the functions described in the Standard Lisp Report are available to users in symbolic mode. Additional functions may also be defined as symbolic procedures. For example, to define the Lisp function {\tt ASSOC}, the following could be used: \begin{verbatim} symbolic procedure assoc(u,v); if null v then nil else if u = caar v then car v else assoc(u, cdr v); \end{verbatim} If the default mode were symbolic, then {\tt SYMBOLIC} could be omitted in the above definition. {\tt MACRO}s may be defined by prefixing the keyword {\tt PROCEDURE} by the word {\tt MACRO}. (In fact, ordinary functions may be defined with the keyword {\tt EXPR} prefixing {\tt PROCEDURE} as was used in the Standard Lisp Report.) For example, we could define a {\tt MACRO CONSCONS} by \begin{verbatim} symbolic macro procedure conscons l; expand(cdr l,'cons); \end{verbatim} The Standard Lisp Report also defines a function type {\tt FEXPR}. However, its use is discouraged since it is hard to implement efficiently, and most uses can be replaced by macros. At the present time, there are no {\tt FEXPR}s in the core REDUCE system. \section{Standard Lisp Equivalent of Reduce Input} A user can obtain the Standard Lisp equivalent of his {\REDUCE} input by turning on the switch {\tt DEFN} \ttindex{DEFN} (for definition). The system then prints the Lisp translation of his input but does not evaluate it. Normal operation is resumed when {\tt DEFN} is turned off. \section{Communicating with Algebraic Mode} \index{Mode communication} One of the principal motivations for a user of the algebraic facilities of {\REDUCE} to learn about symbolic mode \index{Symbolic mode} is that it gives one access to a wider range of techniques than is possible in algebraic mode \index{Algebraic mode} alone. For example, if a user wishes to use parts of the system defined in the basic system source code, or refine their algebraic code definitions to make them more efficient, then it is necessary to understand the source language in fairly complete detail. Moreover, it is also necessary to know a little more about the way {\REDUCE} operates internally. Basically, {\REDUCE} considers expressions in two forms: prefix form, which follow the normal Lisp rules of function composition, and so called canonical form, which uses a completely different syntax. Once these details are understood, the most critical problem faced by a user is how to make expressions and procedures communicate between symbolic and algebraic mode. The purpose of this section is to teach a user the basic principles for this. If one wants to evaluate an expression in algebraic mode, and then use that expression in symbolic mode calculations, or vice versa, the easiest way to do this is to assign a variable to that expression whose value is easily obtainable in both modes. To facilitate this, a declaration {\tt SHARE} \ttindex{SHARE} is available. {\tt SHARE} takes a list of identifiers as argument, and marks these variables as having recognizable values in both modes. The declaration may be used in either mode. E.g., \begin{verbatim} share x,y; \end{verbatim} says that {\tt X} and {\tt Y} will receive values to be used in both modes. If a {\tt SHARE} declaration is made for a variable with a previously assigned algebraic value, that value is also made available in symbolic mode. \subsection{Passing Algebraic Mode Values to Symbolic Mode} If one wishes to work with parts of an algebraic mode \index{Algebraic mode} expression in symbolic mode, \index{Symbolic mode} one simply makes an assignment \index{Assignment} of a shared variable to the relevant expression in algebraic mode. For example, if one wishes to work with {\tt (a+b)\^{ }2}, one would say, in algebraic mode: \begin{verbatim} x := (a+b)^2; \end{verbatim} assuming that {\tt X} was declared shared as above. If we now change to symbolic mode and say \begin{verbatim} x; \end{verbatim} its value will be printed as a prefix form with the syntax: \begin{verbatim} (*SQ <standard quotient> T) \end{verbatim} This particular format reflects the fact that the algebraic mode processor currently likes to transfer prefix forms from command to command, but doesn't like to reconvert standard forms \index{Standard form} (which represent polynomials) and standard quotients back to a true Lisp prefix form for the expression (which would result in excessive computation). So {\tt *SQ} is used to tell the algebraic processor that it is dealing with a prefix form which is really a standard quotient \index{Standard quotient} and the second argument ({\tt T} or {\tt NIL}) tells it whether it needs further processing (essentially, an {\em already simplified} flag). So to get the true standard quotient form in symbolic mode, one needs {\tt CADR} of the variable. E.g., \begin{verbatim} z := cadr x; \end{verbatim} would store in {\tt Z} the standard quotient form for {\tt (a+b)\^{ }2}. Once you have this expression, you can now manipulate it as you wish. To facilitate this, a standard set of selectors \index{Selector} and constructors \index{Constructor} are available for getting at parts of the form. Those presently defined are as follows: \begin{center} {\large REDUCE Selectors} \end{center} \begin{center} \begin{tabular}{l r} {\tt DENR} & \parbox[t]{\rboxwidth}{denominator of standard quotient} \\ \\ {\tt LC} & \parbox[t]{\rboxwidth}{leading coefficient of polynomial} \\ \\ {\tt LDEG} & \parbox[t]{\rboxwidth}{leading degree of polynomial} \\ \\ {\tt LPOW} & \parbox[t]{\rboxwidth}{leading power of polynomial} \\ \\ {\tt LT} & \parbox[t]{\rboxwidth}{leading term of polynomial} \\ \\ {\tt MVAR} & \parbox[t]{\rboxwidth}{main variable of polynomial} \\ \\ {\tt NUMR} & \parbox[t]{\rboxwidth}{numerator (of standard quotient)} \\ \\ {\tt PDEG} & \parbox[t]{\rboxwidth}{degree of a power} \\ \\ {\tt RED} & \parbox[t]{\rboxwidth}{reductum of polynomial} \\ \\ {\tt TC} & \parbox[t]{\rboxwidth}{coefficient of a term} \\ \\ {\tt TDEG} & \parbox[t]{\rboxwidth}{degree of a term} \\ \\ {\tt TPOW} & \parbox[t]{\rboxwidth}{power of a term} \\ \\ \end{tabular} \end{center} \begin{center} {\large REDUCE Constructors} \end{center} \begin{center} \begin{tabular}{l r} {\tt .+} & \parbox[t]{\redboxwidth}{add a term to a polynomial} \\ \\ {\tt ./} & \parbox[t]{\redboxwidth}{divide (two polynomials to get quotient)} \\ \\ {\tt .*} & \parbox[t]{\redboxwidth}{multiply power by coefficient to produce term} \\ \\ {\tt .\^{ }} & \parbox[t]{\redboxwidth}{raise a variable to a power} \\ \\ \end{tabular} \end{center} For example, to find the numerator of the standard quotient above, one could say: \begin{verbatim} numr z; \end{verbatim} or to find the leading term of the numerator: \begin{verbatim} lt numr z; \end{verbatim} Conversion between various data structures is facilitated by the use of a set of functions defined for this purpose. Those currently implemented include: \\ \\ \begin{tabular}{l r} {\tt !*A2F} & \parbox[t]{\reduceboxwidth}{convert an algebraic expression to a standard form. If result is rational, an error results;} \\ \\ {\tt !*A2K} & \parbox[t]{\reduceboxwidth}{converts an algebraic expression to a kernel. If this is not possible, an error results;} \\ \\ {\tt !*F2A} & \parbox[t]{\reduceboxwidth}{converts a standard form to an algebraic expression;} \\ \\ {\tt !*F2Q} & \parbox[t]{\reduceboxwidth}{convert a standard form to a standard quotient;} \\ \\ {\tt !*K2F} & \parbox[t]{\reduceboxwidth}{convert a kernel to a standard form;} \\ \\ {\tt !*K2Q} & \parbox[t]{\reduceboxwidth}{convert a kernel to a standard quotient;} \\ \\ {\tt !*P2F} & \parbox[t]{\reduceboxwidth}{convert a standard power to a standard form;} \\ \\ {\tt !*P2Q} & \parbox[t]{\reduceboxwidth}{convert a standard power to a standard quotient;} \\ \\ {\tt !*Q2F} & \parbox[t]{\reduceboxwidth}{convert a standard quotient to a standard form. If the quotient denominator is not 1, an error results;} \\ \\ {\tt !*Q2K} & \parbox[t]{\reduceboxwidth}{convert a standard quotient to a kernel. If this is not possible, an error results;} \\ \\ {\tt !*T2F} & \parbox[t]{\reduceboxwidth}{convert a standard term to a standard form} \\ \\ {\tt !*T2Q} & \parbox[t]{\reduceboxwidth}{convert a standard term to a standard quotient.} \end{tabular} \subsection{Passing Symbolic Mode Values to Algebraic Mode} In order to pass the value of a shared variable from symbolic mode to algebraic mode, the only thing to do is make sure that the value in symbolic mode is a prefix expression. E.g., one uses {\tt (expt (plus a b) 2)} for {\tt (a+b)\^{ }2}, or the format ({\tt *sq <standard quotient> t}) as described above. However, if you have been working with parts of a standard form they will probably not be in this form. In that case, you can do the following: \begin{enumerate} \item If it is a standard quotient, call {\tt PREPSQ} on it. This takes a standard quotient as argument, and returns a prefix expression. Alternatively, you can call {\tt MK!*SQ} on it, which returns a prefix form like ({\tt *SQ <standard quotient> T)} and avoids translation of the expression into a true prefix form. \item If it is a standard form, call {\tt PREPF} on it. This takes a standard form as argument, and returns the equivalent prefix expression. Alternatively, you can convert it to a standard quotient and then call {\tt MK!*SQ}. \item If it is a part of a standard form, you must usually first build up a standard form out of it, and then go to step 2. The conversion functions described earlier may be used for this purpose. For example, \begin{enumerate} \item If {\tt Z} is an expression which is a term, {\tt !*T2F Z} is a standard form. \item If {\tt Z} is a standard power, {\tt !*P2F Z} is a standard form. \item If {\tt Z} is a variable, you can pass it direct to algebraic mode. \end{enumerate} \end{enumerate} For example, to pass the leading term of {\tt (a+b)\^{ }2} back to algebraic mode, one could say: \begin{verbatim} y:= mk!*sq !*t2q lt numr z; \end{verbatim} where {\tt Y} has been declared shared as above. If you now go back to algebraic mode, you can work with {\tt Y} in the usual way. \subsection{Complete Example} The following is the complete code for doing the above steps. The end result will be that the square of the leading term of $(a+b)^{2}$ is calculated. \begin{tabular}{l r} {\tt share x,y;} & \parbox[t]{\rboxwidth}{{\tt \% declare {\tt X} and {\tt Y} as shared}} \\ {\tt x := (a+b)\^{ }2;} & \parbox[t]{\rboxwidth}{{\tt \% store (a+b)\^{ }2 in X}} \\ {\tt symbolic;} & \parbox[t]{\rboxwidth}{{\tt \% transfer to symbolic mode}} \\ {\tt z := cadr x;} & \parbox[t]{\rboxwidth}{\tt {\% store a true standard quotient \% in Z}} \\ {\tt lt numr z;} & \parbox[t]{\rboxwidth}{{\tt \% print the leading term of the \% numerator of Z}} \\ {\tt y := mk!*sq !*t2q numr z;} & \parbox[t]{\rboxwidth}{{\tt \% store the prefix form of this \% leading term in Y}} \\ {\tt algebraic;} & \parbox[t]{\rboxwidth}{{\tt \% return to algebraic mode}} \\ {\tt y\^{ }2;} & \parbox[t]{\rboxwidth}{{\tt \% evaluate square of the leading \% term of (a+b)\^{ }2}} \\ \end{tabular} \subsection{Defining Procedures to Communicate Between Modes} If one wishes to define a procedure in symbolic mode for use as an operator in algebraic mode, it is necessary to declare this fact to the system by using the declaration {\tt OPERATOR} \ttindex{OPERATOR} in symbolic mode. Thus \begin{verbatim} symbolic operator leadterm; \end{verbatim} would declare the procedure {\tt LEADTERM} as an algebraic operator. This declaration {\em must} be made in symbolic mode as the effect in algebraic mode is different. The value of such a procedure must be a prefix form. The algebraic processor will pass arguments to such procedures in prefix form. Therefore if you want to work with the arguments as standard quotients you must first convert them to that form by using the function {\tt SIMP!*}. This function takes a prefix form as argument and returns the evaluated standard quotient. For example, if you want to define a procedure {\tt LEADTERM} which gives the leading term of an algebraic expression, one could do this as follows: \begin{verbatim} symbolic operator leadterm; % Declare LEADTERM as a symbolic % mode procedure to be used in % algebraic mode. symbolic procedure leadterm u; % Define LEADTERM. mk!*sq !*t2q lt numr simp!* u; \end{verbatim} Note that this operator has a different effect than the operator {\tt LTERM} \ttindex{LTERM} (q.v.). In the latter case, the calculation is done with respect to the second argument of the operator. In the example here, we simply extract the leading term with respect to the system's choice of main variable. Finally, if you wish to use the algebraic evaluator on an argument in a symbolic mode definition, the function {\tt REVAL} can be used. The one argument of {\tt REVAL} must be the prefix form of an expression. {\tt REVAL} returns the evaluated expression as a true Lisp prefix form. \section{References} There are a number of useful books which can give you further information about LISP. Here is a selection: Allen, J.R., ``The Anatomy of LISP", McGraw Hill, New York, 1978. McCarthy J., P.W. Abrahams, J. Edwards, T.P. Hart and M.I. Levin, ``LISP 1.5 Programmer's Manual", M.I.T. Press, 1965. Touretzky, D.S, ``{LISP}: A Gentle Introduction to Symbolic Computation", Harper \& Row, New York, 1984. Winston, P.H. and Horn, B.K.P., ``LISP", Addison-Wesley, 1981. \chapter{Calculations in High Energy Physics} A set of {\REDUCE} commands is provided for users interested in symbolic calculations in high energy physics. Several extensions to our basic syntax are necessary, however, to allow for the different data structures encountered. \section{High Energy Physics Operators} We begin by introducing three new operators required in these calculations. \subsection{. (Cons) Operator} \index{Dot product} \begin{verbatim} Syntax: (EXPRN1:vector_expression) . (EXPRN2:vector_expression):algebraic. \end{verbatim} The binary {\tt .} operator, which is normally used to denote the addition of an element to the front of a list, can also be used in algebraic mode to denote the scalar product of two Lorentz four-vectors. For this to happen, the second argument must be recognizable as a vector expression \index{High energy vector expression} (q.v.) at the time of evaluation. With this meaning, this operator is often referred to as the ``dot" operator. In the present system, the index handling routines all assume that Lorentz four-vectors are used, but these routines could be rewritten to handle other cases. Components of vectors can be represented by including representations of unit vectors in the system. Thus if {\tt EO} represents the unit vector {\tt (1,0,0,0)}, {\tt (p.eo)} represents the zeroth component of the four-vector P. Our metric and notation follows Bjorken and Drell ``Relativistic Quantum Mechanics" (McGraw-Hill, New York, 1965). Similarly, an arbitrary component {\tt P} may be represented by {\tt (p.u)}. If contraction over components of vectors is required, then the declaration {\tt INDEX} \ttindex{INDEX} must be used. Thus \begin{verbatim} index u; \end{verbatim} declares {\tt U} as an index, and the simplification of \begin{verbatim} p.u * q.u \end{verbatim} would result in \begin{verbatim} P.Q \end{verbatim} The metric tensor $g^{\mu \nu}$ may be represented by {\tt (u.v)}. If contraction over {\tt U} and {\tt V} is required, then they should be declared as indices. Errors occur if indices are not properly matched in expressions. If a user later wishes to remove the index property from specific vectors, he can do it with the declaration {\tt REMIND}.\ttindex{REMIND} Thus {\tt remind v1...vn;} removes the index flags from the variables {\tt V1} through {\tt Vn}. However, these variables remain vectors in the system. \subsection{G Operator for Gamma Matrices} \index{Dirac $\gamma$ matrix} \ttindex{G} Syntax: \begin{verbatim} G(ID:identifier[,EXPRN:vector_expression]) :gamma_matrix_expression. \end{verbatim} {\tt G} is an n-ary operator used to denote a product of $\gamma$ matrices contracted with Lorentz four-vectors. Gamma matrices are associated with fermion lines in a Feynman diagram. If more than one such line occurs, then a different set of $\gamma$ matrices (operating in independent spin spaces) is required to represent each line. To facilitate this, the first argument of {\tt G} is a line identification identifier (not a number) used to distinguish different lines. Thus \begin{verbatim} g(l1,p) * g(l2,q) \end{verbatim} denotes the product of {\tt P/} associated with a fermion line identified as {\tt L1}, and {\tt Q/} associated with another line identified as {\tt L2} and where {\tt P} and {\tt Q} are Lorentz four-vectors. A product of $\gamma$ matrices associated with the same line may be written in a contracted form. Thus \begin{verbatim} g(l1,p1,p2,...,p3) = g(l1,p1)*g(l1,p2)*,...,*g(l1,p3) . \end{verbatim} The vector {\tt A} is reserved in arguments of G to denote the special $\gamma$ matrix $\gamma^{5}$. Thus \begin{quote} \begin{tabbing} \ \ \ \ \ {\tt g(l,a)}\hspace{0.2in} \= =\ \ \ $\gamma^{5}$ \hspace{0.5in} \= associated with the line {\tt l} \\[0.1in] \ \ \ \ \ {\tt g(l,p,a)} \> =\ \ \ $\gamma$.p $\times \gamma^{5}$ \> associated with the line {\tt L}. \end{tabbing} \end{quote} $\gamma^{\mu}$ (associated with the line {\tt L}) may be written as {\tt g(l,u)}, with {\tt U} flagged as an index if contraction over {\tt U} is required. The notation of Bjorken and Drell is assumed in all operations involving $\gamma$ matrices. \subsection{EPS Operator} \ttindex{EPS} \begin{verbatim} Syntax: EPS(EXPRN1:vector_expression,...,EXPRN4:vector_exp) :vector_exp. \end{verbatim} The operator {\tt EPS} has four arguments, and is used only to denote the completely antisymmetric tensor of order 4 and its contraction with Lorentz four-vectors. Thus \[ \epsilon_{i j k l} = \left\{ \begin{array}{cl} +1 & \mbox{if $i,j,k,l$ is an even permutation of 0,1,2,3} \\ -1 & \mbox{if an odd permutation} \\ 0 & \mbox{otherwise} \end{array} \right. \] A contraction of the form $\epsilon_{i j \mu \nu}p_{\mu}q_{\nu}$ may be written as {\tt eps(i,j,p,q)}, with {\tt I} and {\tt J} flagged as indices, and so on. \section{Vector Variables} Apart from the line identification identifier in the {\tt G} operator, all other arguments of the operators in this section are vectors. Variables used as such must be declared so by the type declaration {\tt VECTOR}, \ttindex{VECTOR} for example: \begin{verbatim} vector p1,p2; \end{verbatim} declares {\tt P1} and {\tt P2} to be vectors. Variables declared as indices or given a mass \ttindex{MASS} (q.v.) are automatically declared vector by these declarations. \section{Additional Expression Types} Two additional expression types are necessary for high energy calculations, namely \subsection{Vector Expressions} \index{High energy vector expression} These follow the normal rules of vector combination. Thus the product of a scalar or numerical expression and a vector expression is a vector, as are the sum and difference of vector expressions. If these rules are not followed, error messages are printed. Furthermore, if the system finds an undeclared variable where it expects a vector variable, it will ask the user in interactive mode whether to make that variable a vector or not. In batch mode, the declaration will be made automatically and the user informed of this by a message. {\tt Examples:} Assuming {\tt P} and {\tt Q} have been declared vectors, the following are vector expressions \begin{verbatim} p 2*q/3 2*x*y*p - p.q*q/(3*q.q) \end{verbatim} whereas {\tt p*q} and {\tt p/q} are not. \subsection{Dirac Expressions} These denote those expressions which involve $\gamma$ matrices. A $\gamma$ matrix is implicitly a 4 $\times$ 4 matrix, and so the product, sum and difference of such expressions, or the product of a scalar and Dirac expression is again a Dirac expression. There are no Dirac variables in the system, so whenever a scalar variable appears in a Dirac expression without an associated $\gamma$ matrix expression, an implicit unit 4 by 4 matrix is assumed. For example, {\tt g(l,p) + m} denotes {\tt g(l,p) + m*<unit 4 by 4 matrix>}. Multiplication of Dirac expressions, as for matrix expressions, is of course non-commutative. \section{Trace Calculations} \index{High energy trace} When a Dirac expression is evaluated, the system computes one quarter of the trace of each $\gamma$ matrix product in the expansion of the expression. One quarter of each trace is taken in order to avoid confusion between the trace of the scalar {\tt M}, say, and {\tt M} representing {\tt M * <unit 4 by 4 matrix>}. Contraction over indices occurring in such expressions is also performed. If an unmatched index is found in such an expression, an error occurs. The algorithms used for trace calculations are the best available at the time this system was produced. For example, in addition to the algorithm developed by Chisholm for contracting indices in products of traces, {\REDUCE} uses the elegant algorithm of Kahane for contracting indices in $\gamma$ matrix products. These algorithms are described in Chisholm, J. S. R., Il Nuovo Cimento X, 30, 426 (1963) and Kahane, J., Journal Math. Phys. 9, 1732 (1968). It is possible to prevent the trace calculation over any line identifier by the declaration {\tt NOSPUR}. \ttindex{NOSPUR} For example, \begin{verbatim} nospur l1,l2; \end{verbatim} will mean that no traces are taken of $\gamma$ matrix terms involving the line numbers {\tt L1} and {\tt L2}. However, in some calculations involving more than one line, a catastrophic error \begin{verbatim} This NOSPUR option not implemented \end{verbatim} can occur (for the reason stated!) If you encounter this error, please let us know! A trace of a $\gamma$ matrix expression involving a line identifier which has been declared {\tt NOSPUR} may be later taken by making the declaration {\tt SPUR}. \ttindex{SPUR} \section{Mass Declarations} \ttindex{MASS} It is often necessary to put a particle ``on the mass shell" in a calculation. This can, of course, be accomplished with a {\tt LET} command such as \begin{verbatim} let p.p= m^2; \end{verbatim} but an alternative method is provided by two commands {\tt MASS} and {\tt MSHELL}. \ttindex{MSHELL} {\tt MASS} takes a list of equations of the form: \begin{verbatim} <vector variable> = <scalar variable> \end{verbatim} for example, \begin{verbatim} mass p1=m, q1=mu; \end{verbatim} The only effect of this command is to associate the relevant scalar variable as a mass with the corresponding vector. If we now say \begin{verbatim} mshell <vector variable>,...,<vector variable>; \end{verbatim} and a mass has been associated with these arguments, a substitution of the form \begin{verbatim} <vector variable>.<vector variable> = <mass>^2 \end{verbatim} is set up. An error results if the variable has no preassigned mass. \section{Example} We give here as an example of a simple calculation in high energy physics the computation of the Compton scattering cross-section as given in Bjorken and Drell Eqs. (7.72) through (7.74). We wish to compute the trace of $$\left. \alpha^2\over2 \right. \left({k^\prime\over k}\right)^2 \left({\gamma.p_f+m\over2m}\right)\left({\gamma.e^\prime \gamma.e \gamma.k_i\over2k\cdot \gamma.p_i} + {\gamma.e\gamma.e^\prime \gamma.k_f\over2k^\prime\cdot \gamma.p_i}\right) \left({\gamma.p_i+m\over2m}\right)$$ $$ \left({\gamma.k_i\gamma.e\gamma.e^\prime\over2k\cdot \gamma.p_i} + {\gamma.k_f\gamma.e^\prime\gamma.e\over2k^\prime\cdot \gamma.p_i} \right) $$ where $k_i$ and $k_f$ are the four-momenta of incoming and outgoing photons (with polarization vectors $e$ and $e^\prime$ and laboratory energies $k$ and $k^\prime$ respectively) and $p_i$, $p_f$ are incident and final electron four-momenta. Omitting therefore an overall factor ${\alpha^2\over2m^2}\left({k^\prime\over k}\right)^2$ we need to find one quarter of the trace of $${ \left( \gamma.p_f + m\right) \left({\gamma.e^\prime \gamma.e\gamma.k_i\over2k.pi} + {\gamma.e\gamma.e^\prime \gamma.k_f\over 2k^\prime .p_i}\right) \left( \gamma.p_i + m\right) \left({\gamma.k_i\gamma.e\gamma.e^\prime\over 2k.p_i} + {\gamma.k_f\gamma.e^\prime \gamma.e\over2k^\prime .p_i}\right) }$$ A straightforward REDUCE program for this, with appropriate substitutions (using {\tt P1} for $p_i$, {\tt PF} for $p_f$, {\tt KI} for $k_i$ and {\tt KF} for $k_f$) is \begin{verbatim} on div; % this gives output in same form as Bjorken and Drell. mass ki= 0, kf= 0, p1= m, pf= m; vector e,ep; % if e is used as a vector, it loses its scalar identity as the base of natural logarithms. mshell ki,kf,p1,pf; let p1.e= 0, p1.ep= 0, p1.pf= m^2+ki.kf, p1.ki= m*k,p1.kf= m*kp, pf.e= -kf.e, pf.ep= ki.ep, pf.ki= m*kp, pf.kf= m*k, ki.e= 0, ki.kf= m*(k-kp), kf.ep= 0, e.e= -1, ep.ep=-1; for all p let gp(p)= g(l,p)+m; comment this is just to save us a lot of writing; gp(pf)*(g(l,ep,e,ki)/(2*ki.p1) + g(l,e,ep,kf)/(2*kf.p1)) * gp(p1)*(g(l,ki,e,ep)/(2*ki.p1) + g(l,kf,ep,e)/ (2*kf.p1))$ write "The Compton cxn is",ws; \end{verbatim} (We use {\tt P1} instead of {\tt PI} in the above to avoid confusion with the reserved variable {\tt PI}). This program will print the following result \begin{verbatim} (-1) (-1) 2 The Compton cxn is 1/2*K*KP + 1/2*K *KP + 2*E.EP - 1 \end{verbatim} \section{Extensions to More Than Four Dimensions} In our discussion so far, we have assumed that we are working in the normal four dimensions of QED calculations. However, in most cases, the programs will also work in an arbitrary number of dimensions. The command \ttindex{VECDIM} \begin{verbatim} vecdim <expression>; \end{verbatim} sets the appropriate dimension. The dimension can be symbolic as well as numeric. Users should note however, that the {\tt EPS} operator and the $\gamma_{5}$ symbol ({\tt A}) are not properly defined in other than four dimensions and will lead to an error if used. \chapter{{\REDUCE} and Rlisp Utilities} {\REDUCE} and its associated support language system Rlisp \index{Rlisp} include a number of utilities which have proved useful for program development over the years. The following are supported in most of the implementations of {\REDUCE} currently available. \section{The Standard Lisp Compiler} \index{Compiler} Many versions of {\REDUCE} include a Standard Lisp compiler that is automatically loaded on demand. You should check your system specific user guide to make sure you have such a compiler. To make the compiler active, the switch {\tt COMP} \ttindex{COMP} should be turned on. Any further definitions input after this will be compiled automatically. If the compiler used is a derivative version of the original Griss-Hearn compiler (M. L. Griss and A. C. Hearn, ``A Portable LISP Compiler", SOFTWARE --- Practice and Experience 11 (1981) 541-605), there are other switches that might also be used in this regard. However, these additional switches are not supported in all compilers. They are as follows: \ttindex{PLAP} \ttindex{PGWD} \ttindex{PWRDS} \begin{tabular}{l r} {\tt PLAP} & \parbox[t]{\reduceboxwidth}{If ON, causes the printing of the portable macros produced by the compiler;} \\ \\ {\tt PGWD} & \parbox[t]{\reduceboxwidth}{If ON, causes the printing of the actual assembly language instructions generated from the macros;} \\ \\ {\tt PWRDS} & \parbox[t]{\reduceboxwidth}{If ON, causes a statistic message of the form \\ {\tt <function> COMPILED, <words> WORDS, <words> LEFT} \\ to be printed. The first number is the number of words of binary program space the compiled function took, and the second number the number of words left unused in binary program space.} \\ \\ \end{tabular} \section{Fast Loading Code Generation Program} \index{Fast loading of code} \label{sec-load} In most versions of {\REDUCE}, it is possible to take any set of Lisp, Rlisp or {\REDUCE} commands and build a fast loading version of them. In Rlisp or {\REDUCE}, one does the following: \begin{verbatim} faslout <filename>; <commands or IN statements> faslend; \end{verbatim} To load such a file, one uses the command {\tt LOAD}, \ttindex{LOAD} e.g. {\tt load foo;} or {\tt load foo,bah;} Fast-loading files produced by this process may have an implementation dependent extension added by this process. For example, in PSL-based systems, the extension is {\tt b} (for binary). Such extensions are required by the {\tt LOAD} program; if they are missing, an error occurs. In doing this build, as with the production of a Standard Lisp form of such statements, it is important to remember that some of the commands must be instantiated during the building process. For example, macros must be expanded, and some property list operations must happen. The {\REDUCE} sources should be consulted for further details on this. % To facilitate this, the {\tt EVAL} and {\tt IGNORE} flags (q.v.) may be % used. Note also that there can be no {\tt LOAD} command within the input % statements. To avoid excessive printout, input statements should be followed by a \$ instead of the semicolon. With {\tt LOAD} however, the input doesn't print out regardless of which terminator is used with the command. If you subsequently change the source files used in producing a fast loading file, don't forget to repeat the above process in order to update the fast loading file correspondingly. Remember also that the text which is read in during the creation of the fast load file, in the compiling process described above, is {\em not} stored in your {\REDUCE} environment, but only translated and output. If you want to use the file just created, you must then use {\tt LOAD} to load the output of the fast-loading file generation program. When the file to be loaded contains a complete package for a given application, the use of {\tt LOAD\_PACKAGE} \index{Load package} rather than {\tt LOAD} is recommended. The syntax is the same. However, {\tt LOAD\_PACKAGE} does some additional bookkeeping such as recording that this package has now be loaded, which may be used by various utilities in future releases of REDUCE. \section{The Standard Lisp Cross Reference Program} \index{Cross reference} {\tt CREF} \ttindex{CREF} is a Standard Lisp program for processing a set of Standard LISP function definitions to produce: \begin{enumerate} \item A ``summary" showing: \begin{enumerate} \item A list of files processed; \item A list of ``entry points" (functions which are not called or are only called by themselves); \item A list of undefined functions (functions called but not defined in this set of functions); \item A list of variables that were used non-locally but not declared {\tt GLOBAL} or {\tt FLUID} before their use; \item A list of variables that were declared {\tt GLOBAL} but not used as {\tt FLUID}s, i.e., bound in a function; \item A list of {\tt FLUID} variables that were not bound in a function so that one might consider declaring them {\tt GLOBAL}s; \item A list of all {\tt GLOBAL} variables present; \item A list of all {\tt FLUID} variables present; \item A list of all functions present. \end{enumerate} \item A ``global variable usage" table, showing for each non-local variable: \begin{enumerate} \item Functions in which it is used as a declared {\tt FLUID} or {\tt GLOBAL}; \item Functions in which it is used but not declared; \item Functions in which it is bound; \item Functions in which it is changed by {\tt SETQ}. \end{enumerate} \item A ``function usage" table showing for each function: \begin{enumerate} \item Where it is defined; \item Functions which call this function; \item Functions called by it; \item Non-local variables used. \end{enumerate} \end{enumerate} The program will also check that functions are called with the correct number of arguments, and print a diagnostic message otherwise. The output is alphabetized on the first seven characters of each function name. \subsection{Restrictions} Algebraic procedures in {\REDUCE} are treated as if they were symbolic, so that algebraic constructs will actually appear as calls to symbolic functions, such as {\tt AEVAL}. \subsection{Usage} To invoke the cross reference program, the switch {\tt CREF} \ttindex{CREF} is used. {\tt on cref} causes the cref program to load and the cross-referencing process to begin. After all the required definitions are loaded, {\tt off cref} will cause the cross-reference listing to be produced. For example, if you wish to cross-reference all functions in the file {\tt tst.red}, and produce the cross-reference listing in the file {\tt tst.crf}, the following sequence can be used: \begin{verbatim} out "tst.crf"; on cref; in "tst.red"$ off cref; end; \end{verbatim} To process more than one file, more {\tt IN} statements may be added before the call of {\tt off cref}, or the {\tt IN} statement changed to include a list of files. \subsection{Options} Functions with the flag {\tt NOLIST} will not be examined or output. Initially, all Standard Lisp functions are so flagged. (In fact, they are kept on a list {\tt NOLIST!*}, so if you wish to see references to {\em all} functions, then {\tt CREF} should be first loaded with the command {\tt load cref}, and this variable then set to {\tt NIL}). It should also be remembered that any macros with the property list flag {\tt EXPAND}, or, if the switch {\tt FORCE} is on, without the property list flag {\tt NOEXPAND}, will be expanded before the definition is seen by the cross-reference program, so this flag can also be used to select those macros you require expanded and those you do not. \section{Prettyprinting Reduce Expressions} \index{Prettyprinting} {\REDUCE} includes a module for printing {\REDUCE} syntax in a standard format. This module is activated by the switch {\tt PRET}, \ttindex{PRET} which is normally off. Since the system converts algebraic input into an equivalent symbolic form, the printing program tries to interpret this as an algebraic expression before printing it. In most cases, this can be done successfully. However, there will be occasional instances where results are printed in symbolic mode form that bears little resemblance to the original input, even though it is formally equivalent. If you want to prettyprint a whole file, say {\tt off output,msg;} \ttindex{MSG} and (hopefully) only clean output will result. Unlike {\tt DEFN} (q.v.), \ttindex{DEFN} input is also evaluated with {\tt PRET} \ttindex{PRET} on. \section{Prettyprinting Standard Lisp S-Expressions} \index{Prettyprinting} REDUCE includes a module for printing S-expressions in a standard format. The Standard Lisp function for this purpose is {\tt PRETTYPRINT} \ttindex{PRETTYPRINT} which takes a Lisp expression and prints the formatted equivalent. Users can also have their {\REDUCE} input printed in this form by use of the switch {\tt DEFN}. \ttindex{DEFN} This is in fact a convenient way to convert {\REDUCE} (or Rlisp) syntax into Lisp. {\tt off msg;} will prevent warning messages from being printed. NOTE: When {\tt DEFN} is on, input is not evaluated. \chapter {Maintaining {\REDUCE}} {\REDUCE} continues to evolve both in terms of the number of facilities available, and the power of the individual facilities. Corrections are made as bugs are discovered, and awkward features simplified. In order to provide users with easy access to such enhancements, a {\em {\REDUCE} Network Library} has been established from which material can be extracted by anyone with electronic mail access to the Internet computer network. This includes those with access to BITNET, EARN and UUCP-based networks as well as commercial networks such as MCIMail and Compuserve. In addition to miscellaneous documents, source and utility files, the library includes a bibliography of papers referencing {\REDUCE} which contains over 600 entries. Instructions on using this library are sent to all registered {\REDUCE} users who provide a network address. If you would like a more complete list of the contents of the library, send to {\em reduce-netlib@rand.org} the single line message {\em send index} or {\em help}. The current {\REDUCE} information package can also be obtained in this manner by including on a separate line {\em send info-package} and a demonstration file by including the line {\em send demonstration}. If you prefer, hard copies of the information package and the bibliography are available from the {\REDUCE} secretary at RAND, 1700 Main Street, P.O. Box 2138, Santa Monica, CA 90407-2138 ({\em reduce@rand.org}). Copies of the network library are also maintained at other addresses. At the time of writing, {\em reduce-netlib@can.nl} may also be used instead of {\em reduce-netlib@rand.org}. In addition, elib@elib.zib-berlin.de provides interactive access to this library. For more information on {\em eLib}, send the message {\em send index} or {\em help} to that address. Finally, there is a {\REDUCE} electronic forum accessible from the same networks. This enables {\REDUCE} users to raise questions and discuss ideas concerning the use and development of {\REDUCE} with other users. Additions and changes to the network library and new releases of {\REDUCE} are also announced in this forum. Any user with appropriate electronic mail access is encouraged to register for membership in this forum. To do so, send a message requesting inclusion to {\em reduce-forum-request@rand.org}. \appendix \chapter{Reserved Identifiers} We list here all identifiers that are normally reserved in REDUCE including names of commands, operators and switches initially in the system. Excluded are words that are reserved in specific implementations of the system. \\ \\ \begin{tabular}{l r} {Commands} & \parbox[t]{\redboxwidth}{{\tt ALGEBRAIC} {\tt ANTISYMMETRIC} {\tt ARRAY} {\tt BYE} {\tt CLEAR} {\tt CLEARRULES} {\tt COMMENT} {\tt CONT} {\tt DECOMPOSE} {\tt DEFINE} {\tt DEPEND} {\tt DISPLAY} {\tt ED} {\tt EDITDEF} {\tt END} {\tt FACTOR} {\tt FOR} {\tt FORALL} {\tt FOREACH} {\tt GO} {\tt GOTO} {\tt IF} {\tt IN} {\tt INDEX} {\tt INFIX} {\tt INPUT} {\tt INTEGER} {\tt KORDER} {\tt LET} {\tt LINEAR} {\tt LISP} {\tt MASS} {\tt MATCH} {\tt MATRIX} {\tt MSHELL} {\tt NODEPEND} {\tt NONCOM} {\tt NOSPUR} {\tt OFF} {\tt ON} {\tt OPERATOR} {\tt ORDER} {\tt OUT} {\tt PAUSE} {\tt PRECEDENCE} {\tt PRINT\_PRECISION} {\tt PROCEDURE} {\tt QUIT} {\tt REAL} {\tt REMFAC} {\tt REMIND} {\tt RETRY} {\tt RETURN} {\tt SAVEAS} {\tt SCALAR} {\tt SETMOD} {\tt SHARE} {\tt SHOWTIME} {\tt SHUT} {\tt SPUR} {\tt SYMBOLIC} {\tt SYMMETRIC} {\tt VECDIM} {\tt VECTOR} {\tt WEIGHT} {\tt WRITE} {\tt WTLEVEL}} \\ \\ {Boolean Operators} & \parbox[t]{\redboxwidth}{{\tt EVENP} {\tt FIXP} {\tt FREEOF} {\tt NUMBERP} {\tt ORDP} {\tt PRIMEP}} \\ \\ {Infix Operators} & \parbox[t]{\redboxwidth}{ {\tt \&} {\tt :=} {\tt =} {\tt $>$=} {\tt $>$} {\tt $<$=} {\tt $<$} {\tt =$>$} {\tt +} {\tt *} {\tt /} {\tt \^{ }} {\tt **} {\tt .} {\tt WHERE} {\tt SETQ} {\tt OR} {\tt AND} {\tt NOT} {\tt MEMBER} {\tt MEMQ} {\tt EQUAL} {\tt NEQ} {\tt EQ} {\tt GEQ} {\tt GREATERP} {\tt LEQ} {\tt LESSP} {\tt PLUS} {\tt DIFFERENCE} {\tt MINUS} {\tt TIMES} {\tt QUOTIENT} {\tt EXPT} {\tt CONS}} \end{tabular} \newpage \begin{tabular}{l r} {Numerical Operators} & \parbox[t]{\redboxwidth}{{\tt ABS} {\tt ACOS} {\tt ACOSD} {\tt ACOSH} {\tt ACOT} {\tt ACOTD} {\tt ACOTH} {\tt ACSC} {\tt ACSCD} {\tt ACSCH} {\tt ASEC} {\tt ASECD} {\tt ASECH} {\tt ASIN} {\tt ASIND} {\tt ASINH} {\tt ATAN} {\tt ATAND} {\tt ATANH} {\tt ATAN2} {\tt ATAN2D} {\tt CBRT} {\tt COS} {\tt COSD} {\tt COSH} {\tt COT} {\tt COTD} {\tt COTH} {\tt CSC} {\tt CSCD} {\tt CSCH} {\tt EXP} {\tt FACTORIAL} {\tt FIX} {\tt FLOOR} {\tt HYPOT} {\tt LN} {\tt LOG} {\tt LOGB} {\tt LOG10} {\tt NEXTPRIME} {\tt ROUND} {\tt SEC} {\tt SECD} {\tt SECH} {\tt SIN} {\tt SIND} {\tt SINH} {\tt SQRT} {\tt TAN} {\tt TAND} {\tt TANH}} \\ \\ {Prefix Operators} & \parbox[t]{\redboxwidth}{{\tt APPEND} {\tt ARGLENGTH} {\tt CEILING} {\tt COEFF} {\tt COEFFN} {\tt COFACTOR} {\tt CONJ} {\tt DEG} {\tt DEN} {\tt DET} {\tt DF} {\tt DILOG} {\tt EPS} {\tt ERF} {\tt EXPINT} {\tt FACTORIZE} {\tt FIRST} {\tt GCD} {\tt G} {\tt IMPART} {\tt INT} {\tt INTERPOL} {\tt LCM} {\tt LCOF} {\tt LENGTH} {\tt LHS} {\tt LINELENGTH} {\tt LTERM} {\tt MAINVAR} {\tt MAT} {\tt MATEIGEN} {\tt MAX} {\tt MIN} {\tt MKID} {\tt NULLSPACE} {\tt NUM} {\tt PART} {\tt PF} {\tt PRECISION} {\tt RANK} {\tt REDERR} {\tt REDUCT} {\tt REMAINDER} {\tt REPART} {\tt REST} {\tt RESULTANT} {\tt REVERSE} {\tt RHS} {\tt SECOND} {\tt SET} {\tt SOLVE} {\tt STRUCTR} {\tt SUB} {\tt SUM} {\tt THIRD} {\tt TP} {\tt TRACE} {\tt VARNAME}} \\ \\ {Reserved Variables} & \parbox[t]{\redboxwidth}{{\tt E} {\tt I} {\tt INFINITY} {\tt K!*} {\tt NIL} {\tt PI} {\tt T}} \\ \\ {Switches} & \parbox[t]{\redboxwidth}{{\tt ADJPREC} {\tt ALGINT} {\tt ALLBRANCH} {\tt ALLFAC} {\tt BFSPACE} {\tt COMP} {\tt COMPLEX} {\tt CRAMER} {\tt CREF} {\tt DEFN} {\tt DEMO} {\tt DIV} {\tt ECHO} {\tt ERRCONT} {\tt EVALLHSEQP} {\tt EXP} {\tt EZGCD} {\tt FACTOR} {\tt FORT} {\tt GCD} {\tt IFACTOR} {\tt INT} {\tt INTSTR} {\tt LCM} {\tt LIST} {\tt LISTARGS} {\tt MCD} {\tt MODULAR} {\tt MSG} {\tt MULTIPLICITIES} {\tt NAT} {\tt NERO} {\tt NOSPLIT} {\tt OUTPUT} {\tt PERIOD} {\tt PGWD} {\tt PLAP} {\tt PRET} {\tt PRI} {\tt PWRDS} {\tt RAISE} {\tt RAT} {\tt RATARG} {\tt RATIONAL} {\tt RATIONALIZE} {\tt RATPRI} {\tt REVPRI} {\tt ROUNDALL} {\tt ROUNDBF} {\tt ROUNDED} {\tt SAVESTRUCTR} {\tt SOLVESINGULAR} {\tt TIME} {\tt TRA} {\tt TRFAC} {\tt TRINT}} \\ \\ {Other Reserved Ids} & \parbox[t]{\redboxwidth}{{\tt BEGIN} {\tt DO} {\tt EXPR} {\tt FASLOUT} {\tt FEXPR} {\tt FLAGOP} {\tt INPUT} {\tt LAMBDA} {\tt LISP} {\tt LOAD} {\tt MACRO} {\tt PRODUCT} {\tt REPEAT} {\tt SMACRO} {\tt SUM} {\tt WHILE} {\tt WS}} \end{tabular} \printindex \end{document} |
Added r34.1/doc/roots.tex version [32d07988c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{The REDUCE Root Finding Package \\ Mod 1.91, 16 May 1990} \date{} \author {Stanley L. Kameny \\ E-mail: valley!stan@rand.org} \begin{document} \maketitle \index{root finding} \index{ROOTS package} \section{Introduction} The Root Finding package is designed so that it can be used as an independent package, or it can be integrated with and called by {\tt SOLVE}. \index{SOLVE package ! with ROOTS package} This document describes the package in its independent use. It can be used to find some or all of the roots of polynomials with real or complex coefficients, to the accuracy specified by the user. \section{Top Level Functions} The top level functions can be called either as symbolic operators from algebraic mode, or they can be called directly from symbolic mode with symbolic mode arguments. Outputs are expressed in forms that print out correctly in algebraic mode. \subsection{Functions which refer to real roots only} Three top level functions refer only to real roots. Each of these functions can receive 1, 2 or 3 arguments. The first argument is the polynomial p, which can be complex and can have multiple or zero roots. If arg2 and arg3 are not present, all real roots are found. If the additional arguments are present, they restrict the region of consideration. \begin{itemize} \item If arguments are (p,arg2) then (Arg2 must be POSITIVE or NEGATIVE) If arg2=NEGATIVE then only negative roots of p are included; if arg2=POSITIVE then only positive roots of p are included. Zero roots are excluded. \item If arguments are (p,arg2,arg3) \ttindex{EXCLUDE} \ttindex{POSITIVE} \ttindex{NEGATIVE} \ttindex{INFINITY} (Arg2 and Arg3 must be r (a real number) or EXCLUDE r or a member of the list POSITIVE, NEGATIVE, INFINITY, -INFINITY. EXCLUDE r causes the value r to be excluded from the region. The order of the sequence arg2, arg3 is unimportant. Assuming that arg2 $\leq$ arg3 if both are numeric, then \begin{tabular}{l c l} \{-INFINITY,INFINITY\} & is equivalent to & \{\} represents all roots; \\ \{arg2,NEGATIVE\} & represents & $-\infty < r < arg2$; \\ \{arg2,POSITIVE\} & represents & $arg2 < r < \infty$; \end{tabular} In each of the following, replacing an {\em arg} with EXCLUDE {\em arg} converts the corresponding inclusive $\leq$ to the exclusive $<$ \begin{tabular}{l c l} \{arg2,-INFINITY\} & represents & $-\infty < r \leq arg2$; \\ \{arg2,INFINITY\} & represents & $arg2 \leq r < \infty$; \\ \{arg2,arg3\} & represents & $arg2 \leq r \leq arg3$; \end{tabular} \item If zero is in the interval, zero root is included. \end{itemize} \begin{description} \ttindex{REALROOTS} \index{Sturm Sequences} \item[REALROOTS] This function finds the real roots of the polynomial p, using the REALROOT package to isolate real roots by the method of Sturm sequences, then polishing the root to the desired accuracy. Precision of computation is guaranteed to be sufficient to separate all real roots in the specified region. (cf. MULTIROOT for treatment of multiple roots.) \ttindex{ISOLATER} \item[ISOLATER] This function produces a list of rational intervals, each containing a single real root of the polynomial p, within the specified region, but does not find the roots. \ttindex{RLROOTNO} \item[RLROOTNO] This function computes the number of real roots of p in the specified region, but does not find the roots. \end{description} \subsection{Functions which return both real and complex roots} \begin{description} \ttindex{ROOTS} \item[ROOTS p;] This is the main top level function of the roots package. It will find all roots, real and complex, of the polynomial p to an accuracy sufficient to separate them. The value returned by ROOTS is a list of equations for all roots. In addition, ROOTS stores separate lists of real roots and complex roots in the global variables ROOTSREAL and ROOTSCOMPLEX. \ttindex{ROOTSREAL} \ttindex{ROOTSCOMPLEX} \ttindex{NEARESTROOT} \item[NEARESTROOT(p,s);] This top level function uses an iterative method to find the root to which the method converges given the initial starting origin s, which can be complex. If there are several roots in the vicinity of s and s is not significantly closer to one root than it is to all others, the convergence could arrive at a root which is not truly the nearest root. This function should therefore be used only when the user is certain that there is only one root in the immediate vicinity of the starting point s. \ttindex{FIRSTROOT} \item[FIRSTROOT p;] Equivalent to NEARESTROOT(p,0). \end{description} \subsection{Other top level function} \begin{description} \ttindex{CSIZE} \item[CSIZE p;] This function will determine the maximum coefficient size of the polynomial p. The initial precision used in root finding is at least 2+CSIZE p (in some cases significantly greater, as determined by the heuristic function CALCPREC.) \ttindex{GETROOT} \ttindex{ROOTS} \ttindex{REALROOTS} \ttindex{NEARESTROOTS} \item[GETROOT(n,rr);] If rr has the form of the output of ROOTS, REALROOTS, or NEARESTROOTS; GETROOT returns the rational, real, or complex value of the root equation. Error occurs if $n<1$ or $n>$ the number of roots in rr. \ttindex{MKPOLY} \item[MKPOLY rr;] This function can be used to reconstruct a polynomial whose root equation list is rr and whose denominator is 1. Thus one can verify that $if rr := ROOTS p, and rr1 := ROOTS MKPOLY rr, then rr1 = rr$. (This will be true if MULTIROOT and RATROOT are ON, and BIGFLOAT and FLOAT are off.) However, $MKPOLY rr - NUM p = 0$ will be true iff all roots of p have been computed exactly. \end{description} \subsection{Functions available for diagnostic or instructional use only} \begin{description} \ttindex{GFNEWT} \item[GFNEWT(p,r,cpx);] This function will do a single pass through the function GFNEWTON for polynomial p and root r. If cpx=T, then any complex part of the root will be kept, no matter how small. \ttindex{GFROOT} \item[GFROOT(p,r,cpx);] This function will do a single pass through the function GFROOTFIND for polynomial p and root r. If cpx=T, then any complex part of the root will be kept, no matter how small. \ttindex{ROOTS2} \item[ROOTS2 p;] The same as ROOTS p, except that if an abort occurs, the roots already found will be printed and then ROOTS2 will be applied to the polynomial which exists at that point. (Note: there is no known polynomial on which ROOTS aborts.) \end{description} \section{Switches Used in Input} The input of polynomials in algebraic mode is sensitive to the switches {\tt COMPLEX}, {\tt FLOAT} and {\tt BIGFLOAT}. The correct choice of input method is important since incorrect choices will result in undesirable truncation or rounding of the input coefficients. Truncation or rounding will occur if {\tt FLOAT} or {\tt BIGFLOAT} is on and one of the following is true: \begin{enumerate} \item a coefficient is entered in floating point form or rational form. \item {\tt COMPLEX} is on and a coefficient is imaginary or complex. \end{enumerate} Therefore, to avoid undesirable truncation or rounding, then: \begin{enumerate} \item both {\tt FLOAT} and {\tt BIGFLOAT} should be off and input should be in integer or rational form; or \item {\tt FLOAT} can be on if it is acceptable to truncate or round input to the machine-dependent precision limit, which may be quite small; or \item {\tt BIGFLOAT} can be on if {\tt PRECISION} is set to a value large enough to prevent undesired rounding. \end{enumerate} \begin{description} \item[integer and complex modes] (off {\tt FLOAT, BIGFLOAT}) any real polynomial can be input using integer coefficients of any size; integer or rational coefficients can be used to input any real or complex polynomial, independent of the setting of the switch {\tt COMPLEX}. These are the most versatile input modes, since any real or complex polynomial can be input exactly. \item[modes float and complex-float] (on {\tt FLOAT}) polynomials can be input using integer coefficients of any size. Floating point coefficients will be truncated or rounded, to a size dependent upon the system. If complex is on, real coefficients can be input to any precision using integer form, but coefficients of imaginary parts of complex coefficients will be rounded or truncated. \item[modes bigfloat and big-complex] (on {\tt BIGFLOAT}) the setting of precision determines the precision of all coefficients except for real coefficients input in integer form. Floating point coefficients will be truncated by the system to a size dependent upon the system, the same as floating point coefficients in float mode. If precision is set high enough, any real or complex polynomial can be input exactly provided that coefficients are input in integer or rational form. \end{description} \section{Internal and Output Use of Switches} REDUCE arithmetic mode switches {\tt BIGFLOAT, FLOAT}, and {\tt COMPLEX}. These switches are returned in the same state in which they were set initially, (barring catastrophic error). \begin{description} \ttindex{COMPLEX} \item[COMPLEX] The Root Finding Package controls the switch {\tt COMPLEX} internally, turning the switch on if it is processing a complex polynomial. (However, if {\tt COMPLEX} is on, algebraic mode input may not work correctly in modes {\tt COMPLEX\_FLOAT} or {\tt BIG\_COMPLEX}, so it is best to use integer or rational input only. See example 62 of {\tt roots.tst} for a way to get this to work.) For a polynomial with real coefficients, the \ttindex{NEARESTROOT} starting point argument for NEARESTROOT can be given in algebraic mode in complex form as rl + im * I and will be handled correctly, independent of the setting of the switch {\tt COMPLEX.} Complex roots will be computed and printed correctly regardless of the setting of the switch {\tt COMPLEX}. However, if {\tt COMPLEX} is off, the imaginary part will print out ahead of the real part, while the reverse order will be obtained if COMPLEX is on. \ttindex{FLOAT} \ttindex{BIGFLOAT} \item[FLOAT, BIGFLOAT] If the switch {\tt AUTOMODE} (Default ON) is ON, the Root Finding package performs computations using the arithmetic mode that is required at the time, which may be integer, Gaussian integer, float, bigfloat, complex float or complex bigfloat. Switch BFTAG is used internally to govern the mode of computation and :PREC: is adjusted whenever necessary. The initial position of switches {\tt FLOAT} and {\tt BIGFLOAT} are ignored. At output, these switches will emerge in their initial positions. Outputs will be printed out in float format only if the float format of the Lisp system will properly print out quantities of the required accuracy. Otherwise, the printout will be in bigfloat format. (See also the paragraph describing {\tt AUTOMODE.)} \ttindex{AUTOMODE} \end{description} \section{Root Package Switches} Note: switches ISOROOT and ACCROOT, present in earlier versions, have been eliminated. \begin{description} \ttindex{RATROOT} \item[RATROOT] (Default OFF) If {\tt RATROOT} is on all root equations are output in rational form. Assuming that the mode is {\tt COMPLEX} (i.e. {\tt FLOAT} and {\tt BIGFLOAT} are both off,) the root equations are guaranteed to be able to be input into REDUCE without truncation or rounding errors. (Cf. the function MKPOLY described above.) \ttindex{MULTIROOT} \item[MULTIROOT] (Default ON) Whenever the polynomial has complex coefficients or has real coefficients and has multiple roots, as \ttindex{SQFRF} determined by the Sturm function, the function {\tt SQFRF} is called automatically to factor the polynomial into square-free factors. If {\tt MULTIROOT} is on, the multiplicity of the roots will be indicated in the output of ROOTS or REALROOTS by printing the root output repeatedly, according to its multiplicity. If {\tt MULTIROOT} is off, each root will be printed once, and all roots should be normally be distinct. (Two identical roots should not appear. If the initial precision of the computation or the accuracy of the output was insufficient to separate two closely-spaced roots, the program attempts to increase accuracy and/or precision if it detects equal roots. If however, if the initial accuracy specified was too low, and it was possible to separate the roots, the program will abort.) \index{tracing ! ROOTS package} \ttindex{TRROOT} \item[TRROOT] (Default OFF) If switch {\tt TRROOT} is on, trace messages are printed out during the course of root determination, to show the progress of solution. \ttindex{ROOTMSG} \item[ROOTMSG] (Default OFF) If switch {\tt ROOTMSG} is on in addition to switch {\tt TRROOT,} additional messages are printed out to aid in following the progress of Laguerre and Newton complex iteration. These messages are intended for debugging use primarily. NOTE: the switch {\tt AUTOMODE} is included mainly for diagnostic purposes. If it is changed from its default setting, the automatic determination of computation modes is bypassed, and correct root determination may not be achieved! \ttindex{AUTOMODE} \item[AUTOMODE] (Default ON) If switch {\tt AUTOMODE} is on, then, independent of the user setting of the switch {\tt BIGFLOAT}, all floating point computations are carried out in floating point mode (rather than bigfloat) if the system floating point mode has sufficient precision at that point in the computation. If {\tt AUTOMODE} is off and the user setting of {\tt BIGFLOAT} is on, bigfloat computations are used for all floating point computations. The default setting of {\tt AUTOMODE} is {\tt ON}, in order to speed up computations and guarantee that the exact input polynomial is evaluated. \end{description} \section{Operational Parameters and Parameter Setting.} \begin{description} \ttindex{ROOTACC\#} \item[ROOTACC\#] (Default 6) This parameter can be set using the function ROOTACC n; which causes {\tt ROOTACC\#} to be set to MAX(n,6). If {\tt ACCROOT} is on, roots will be determined to a minimum of {\tt ROOT\-ACC\#} significant places. (If roots are closely spaced, a higher number of significant places is computed where needed.) \ttindex{:PREC:} \item[:PREC:] (Default 8) This REDUCE parameter is used to determine the precision of bigfloat computations. The function PRECISION n; causes :PREC: to be set to the value n+2 but returns the value n. The roots package, during its operation, will change the value of :PREC: but will restore the original value of :PREC: at termination except that the value of :PREC: is increased if necessary to allow the full output to be printed. \ttindex{ROOTPREC} \item[ROOTPREC n;] The roots package normally sets the computation mode and precision automatically if {\tt AUTOMODE} is on. However, if ROOTPREC n; is called and $n>!!NFPD$ (where !!NFPD is the number of floating point digits in the Lisp system,) then all root computation will be done initially in bigfloat mode of minimum precision n. Automatic operation can be restored by input of ROOTPREC 0;. \ttindex{"!"!NFPD} \end{description} \section{Avoiding truncation of polynomials on input} The roots package will not internally truncate polynomials provided that the switch {\tt AUTOMODE} is on (or, if {\tt AUTOMODE} is off, provided that {\tt ROOTPREC} is not set to some value smaller than the number of significant figures needed to represent the polynomial precisely.) However, it is possible that a polynomial can be truncated by input reading functions of the embedding lisp system, particularly when input is given in floating point or bigfloat formats. (Some lisp systems use the floating point input routines to input bigfloats.) To avoid any difficulties, input can be done in integer or Gaussian integer format, or mixed, with integers or rationals used to represent quantities of high precision. There are many examples of this in the test package. Note that use of bigfloat of high precision will not necessarily avoid truncation of coefficients if floating point input format is used. It is usually sufficient to let the roots package determine the precision needed to compute roots. The number of digits that can be safely represented in floating point in the lisp system are contained in the global variable {\tt !!NFPD}. Similarly, the maximum number of significant figures in floating point output are contained in the global variable {\tt !!FLIM}. The roots package computes these values, which are needed to control the logic of the program. \ttindex{"!"!FLIM} \ttindex{"!"!NFPD} The values of intermediate root iterations (that are printed when {\tt TRROOT} is on) are given in bigfloat format even when the actual values are computed in floating point. This avoids intrusive rounding of root printout. \end{document} |
Added r34.1/doc/scope.bib version [ef77a810ed].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @ARTICLE{Gates:85, AUTHOR = "B. L. Gates", TITLE = "{GENTRAN}: An automatic code generation facility for {REDUCE}", JOURNAL = "{SIGSAM} Bulletin", VOLUME = 19, NUMBER = 3, PAGES = "24-42", YEAR = 1985} @INPROCEEDINGS{Gates:84, AUTHOR = "B. L. Gates and P. S. Wang", TITLE = "{LISP}-based {RATFOR} code generator", YEAR = 1984, EDITOR = "V. E. Golden", PAGES = "319-329", BOOKTITLE = "1984 MACSYMA User's Conference", ADDRESS = "Schenectady, N.Y.", ORGANIZATION = "Gen. El."} @INPROCEEDINGS{Hearn:85, AUTHOR = "Anthony C. Hearn", TITLE = "Structure: The Key to Improved Algebraic Computation", YEAR = 1985, BOOKTITLE = "Proc. of the Second {RIKEN} International Symposium on Symbolic and Algebraic Computation by Computers", PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "215-230"} @INPROCEEDINGS{Hearn:86, AUTHOR = "Anthony C. Hearn", TITLE = "Optimal Evaluation of Algebraic Expressions", BOOKTITLE = "Proc. of {AAECC}-3, Lecture Notes on Comp. Science", YEAR = 1986, VOLUME = 229, PAGES = "392-403"} @ARTICLE{Knuth:71, AUTHOR = "D. E. Knuth", TITLE = "An empirical study of Fortran programs", JOURNAL = "Software Practice and Experience", VOLUME = 1, PAGES = "105-133", YEAR = 1971} @BOOK{Aho:86, AUTHOR = "A. V. Aho and R. Sethi and J. D. Ullman", TITLE = "Compiler Principles, Techniques and Tools", ADDRESS = "Reading, Mass", PUBLISHER = "Addison-Wesley", YEAR = 1986} @ARTICLE{Gonzales, AUTHOR = "T. Gonzales and J. Ja' Ja'", TITLE = "Evaluation of arithmetic expressions with algebraic identities", JOURNAL = "{SIAM} J. Comp", YEAR = 1982, VOLUME = 11, NUMBER = 4, PAGES = "633-662"} @ARTICLE{Johnson:79, AUTHOR = "B. B. Johnson and W. Miller and B. Minnihan and C. Wrathall", TITLE = "Reducibility among floating-point graphs", JOURNAL = "Journal of the {ACM}", VOLUME = 26, NUMBER = 4, PAGES = "739-760", YEAR = 1979} @ARTICLE{Smit:81, AUTHOR = "J. Smit and J.A. van Hulzen and B.J.A. Hulshof", TITLE = "{NETFORM} and code optimizer manual", JOURNAL = "{SIGSAM} Bulletin", VOLUME =15, NUMBER = 4, PAGES = "23-32", YEAR = 1981} @INPROCEEDINGS{Smit:82, AUTHOR = "J. Smit and J.A. van Hulzen", TITLE = "Symbolic-numeric methods in microwave technology", BOOKTITLE = "Proceedings {EUROCAM} '82", EDITOR = "J. Calmet", PUBLISHER = "Springer Verlag", SERIES = "Springer {LNCS}", VOLUME = 144, PAGES = "281-288", ADDRESS = "Heidelberg", YEAR = 1982} @INPROCEEDINGS{vanHulzen:83, AUTHOR = "J.A. van Hulzen", TITLE = "Code optimization of multivariate polynomial schemes: A pragmatic approach", BOOKTITLE = "Proceedings {EUROCAL} '83", EDITOR = "J.A. van Hulzen", SERIES = "Springer {LNCS}", VOLUME = 162, PAGES = "286-300", ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1983} @INPROCEEDINGS{Wang:84, AUTHOR = "P.S. Wang and T.Y.P. Chang and J.A. van Hulzen, J.A", TITLE = "Code generation and optimization for finite element analysis", BOOKTITLE = "Proceedings {EUROSAM} '84", EDITOR = "J.P. Fitch", SERIES = "Springer {LNCS}", VOLUME = 174, PAGES = "237-247", ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1984} @INPROCEEDINGS{Heuvel:89, AUTHOR = "P. van den Heuvel and J.A. van Hulzen and V.V. Goldman", TITLE = "Automatic generation of {FORTRAN}-coded Jacobians and Hessians", BOOKTITLE = "Proceedings {EUROCAL} '87", EDITOR = "J.H. Davenport", SERIES = "Springer {LNCS}", VOLUME = 378, PAGES = "120-131", ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1989} @INBOOK{Goldman:89, AUTHOR = "V.V. Goldman and J.A. van Hulzen", TITLE = "Automatic code vectorization of arithmetic expressions by bottom-up structure recognition", BOOKTITLE = "Computer Algebra and Parallelism", PAGES = "119-132", ADDRESS = "London", PUBLISHER = "Academic Press", YEAR = 1989} @INPROCEEDINGS{vanHulzen:81, AUTHOR = "J.A. van Hulzen", TITLE = "Breuer's grow factor algorithm in computer algebra", BOOKTITLE = "Proceedings {SYMSAC} '81", EDITOR = "P.S. Wang", PAGES = "100-104", ADDRESS = "New York", PUBLSHER = "{ACM} Press", YEAR = 1981} @ARTICLE{Breuer:69, AUTHOR = "M.A. Breuer", TITLE = "Generation of optimal code for expressions via factorization", JOURNAL = "Communications of the {ACM}", VOLUME = 12, NUMBER = 6, PAGES = "330-340", YEAR = 1969} @BOOK{Knuth:80, AUTHOR = "D.E. Knuth", TITLE = "The art of computer programming", VOLUME = 2, EDITION = "Second", ADDRESS = "Reading, Mass", PUBLISHER = "Addison-Wesley", YEAR = 1980} @INPROCEEDINGS{vanHulzen:90, AUTHOR = "J.A. van Hulzen", TITLE = "Current trends in source-code optimization", BOOKTITLE = "Proceedings {JINR IV} Conference on Computer Algebra and its Applications in Theoretical Physics", ADDRESS = "Dubna", MONTH = "May", YEAR = 1990, NOTE = "Also available as Memorandum {\bf INF-90-41}, Department of Computer Science, Uniersity Twente"} |
Added r34.1/doc/scope.tex version [95654e9f28].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{SCOPE, a Source-Code Optimization PackagE for REDUCE} \date{} \author{J.A. van Hulzen \\ Twente University, The Netherlands \\ Email: infhvh@cs.utwente.nl} \begin{document} \maketitle \index{SCOPE package !} A survey of the strategy behind and the facilities of SCOPE, a Source-Code Optimization PackagE for {\REDUCE} is given. We avoid a detailed discussion of the different algorithms and concentrate on the user aspects of the package. Examples of straightforward and more advanced usage are shown. A combined use of GENTRAN and SCOPE is not yet discussed in this preliminary version of the SCOPE manual. \index{GENTRAN ! with SCOPE package} \section{Introduction}\label{SCOPE:intro} An important application of computer algebra systems is the generation of code for numerical purposes via automatic or semiautomatic program generation. GENTRAN~\cite{Gates:85,Gates:84} a flexible general-purpose package, was especially developed to assist in such a task, when using MACSYMA or {\REDUCE}. \index{optimization} Attendant to automatic program generation is the problem of automatic source-code optimization. This is a crucial aspect because code generated from symbolic computations often tends to be made up of lengthy arithmetic expressions. One of our test examples contained, for instance, 20534 additions and subtractions, 4174 multiplications, 12473 integer exponentiations and 7990 other operations, such as function calls. These lengthy expressions will be grouped together in blocks of straight-line code in a program for numerical purposes. The main objective of source-code optimization is to minimize the number of (elementary) arithmetic operations in such blocks. This form of optimization is often helpful in reducing redundancy in expressions. Simplification algorithms applied on expressions viewed as entities, neither guarantee complete structure preservation nor allow improvements inside expressions by renaming subexpressions. \index{optimizing compilers} Optimizing compilers ought to deal effectively and efficiently with the average, hand coded program. The enormous, arithmetic intensive expressions, easily producable by a computer algebra system, fall outside the range of the FORTRAN programs, once analyzed and discussed by Knuth~\cite{Knuth:71}. He suggested that optimization of the arithmetic in such a program is slightly overdone. This may explain why even in reasonably recent literature, such as~\cite{Aho:86}, optimization of arithmetic code is hardly discussed. The DAG models, usually employed for optimization of arithmetic code, hardly allow the application of any algebraic identity (see for instance~\cite{Gonzales}). These models often force constants to act as if they were indeterminates and powers as objects requiring function calls, i.e. they force to think of $2a\ +\ 3b$ and $4 a \ +\ 6b$ or of $a^2$, $a^{4}$ and $a^{6}$ as being different entities. Our optimization strategy however, requires the validity of some elementary algebraic laws. We employ heuristic techniques to reduce the arithmetic complexity of the given representation of a set of input expressions $ {\rm E}_in$, thus producing a set of output expressions ${\rm E}_out$. The optimized version of the earlier mentioned test example contains ``only'' 4316 additions and subtractions, 4919 multiplications, 13 integer exponentiations and 60 other operations. ${\rm E}_{in}$ and ${\rm E}_{out}$ define blocks of code, which would compute the same exact values for the same exact inputs, thus implicitly proving the correctness of the underlying software. Obviously the use of ${\rm E}_{out}$ saves a considerable amount of execution time in comparison with the application of ${\rm E}_{in}$. Johnson et al~\cite{Johnson:79} suggest that such transformations do not destabilize the computations. However this is only apparent after a careful error analysis of both ${\rm E}_{in}$ and ${\rm E}_{out}$. In view of the size of both ${\rm E}_{in}$ and ${\rm E}_{out}$ such an analysis has to be automatized as well. Work in this direction is in progress. The current version of SCOPE, our Source-Code Optimization PackagE, is written in RLISP. It can be used as an extension of {\REDUCE}. It allows to subject almost any set of proper {\REDUCE} assignment \index{common subexpressions (cse)} \index{cse (common subexpressions)} statements to a heuristic search for common (sub)expressions (cse's). The output is obtained as a sequence of assignment statements, by default given in {\REDUCE} syntax. The first version of the package was designed to optimize the description of {\REDUCE}-statements, generated by NETFORM~\cite{Smit:81,Smit:82}. This version was tailored to a restrictive class of problems, occurring mainly in electrical network theory, thus implying that the right-hand sides (rhs's) in the input were limited to elements of ${{\rm {\bf }} Z}_2$[V], where V is a set of identifiers. The second version~\cite{vanHulzen:83} allowed rhs's from {\bf Z}[V]. For both versions the validity of the commutative and the associative law was assumed. A third version evolved from the latter package by allowing to apply the distributive law, i.e. by replacing (sub)expressions like $a.b\ +\ a.c$ by $a.(b\ +\ c)$ whenever possible. But the range of possible applications of this version was really enlarged by redefining V as a set of kernels, implying that, at least by that time, almost any proper {\REDUCE} expression could function as a rhs. The mathematical capabilities of this version are shortly summarized in~\cite{Wang:84}, in the context of code generation and optimization for finite-element analysis. It is used \index{GENTRAN ! with SCOPE package} in combination with GENTRAN, for the construction of Jacobians and Hessians~\cite{Heuvel:89} and also in experiments with strategies for code vectorization~\cite{Goldman:89}. It still assumes constant coefficients to be elements of {\bf Z}. The user-interface of the present version relies on some GENTRAN facilities. In~\cite{vanHulzen:81,vanHulzen:83} we described the overall optimization strategy used for SCOPE as a composite function ${{\rm R}^{-1}}\ \circ\ {{\rm T}}\ \circ\ {{\rm R}}$. The function R defines how to store the input ${{\rm E}}_{0}$ in an expression data base ${{\rm D}}_{0}$. This ${{\rm D}}_{0}$ is formed by two matrix structures and a function table. The incidence matrices represent ${{\rm E}}_{0}$, a set of arithmetic expressions, in a two-dimensional structure where the rows represent expression or subexpression references and the columns represent identifier references such as variable and function names. The function names are taken from the function table, consisting of a list of pairs of function applications occurring in ${{\rm E}}_0$, and system selected names functioning as their placeholders during the optimization process. Arguments of functions are similarly entered in the matrix structures when ever relevant. A given subexpression will be entered in one of two types of incidence matrices, one for sums and one for products, depending on the nature of the arithmetic operation at the top level of the expression. The two matrices are correlated by auxiliary predecessor-successor information at the row level for every subexpression reference. The actual entries in the matrices are either multiplicative numerical coefficients for the sums matrix or powers for the products matrix. The inverse function ${{\rm R}}^{{-1}}$ defines the output production. The function T defines the optimization process itself. It essentially consists of a heuristic remodeling of the (extendable) matrices in combination with storing information required for a fast retrieval and correct insertion of the detected cse's in the output. This is accomplished by an iteratively applied search, resulting in a stepwise reduction of the arithmetic complexity of the input set, using an extended version of Breuer's \index{Breuer's Algorithm} grow factor algorithm~\cite{Breuer:69,vanHulzen:81,vanHulzen:83}. It is applied until no further profit is gained, i.e. until the reduction in arithmetic complexity stops. Before producing output, a finishing touch can be performed to further reduce the arithmetic complexity with some locally applied techniques. The overall process can be summarized as follows: $$ {{\rm R}}\ :\ {{{\rm E}}_0}\ \to\ ({{{\rm D}}_0},{{{\rm profit}}_0}) $$ $$ {{{\rm T}}_{\beta}}\ :\ ({{{\rm D}}_i},{{{\rm profit}}_i})\ \to\ ({{{\rm D}}_{{i+1}}},{{{\rm profit}}_{{i+1}}})\ ,\ {{\rm i}}\ =\ 0,..., \lambda - 1. $$ $$ {{\rm F}}\ :\ ({{{\rm D}}_{\lambda}},{{{\rm profit}}_{\lambda}})\ \to\ {D_{\lambda}} $$ $$ {{{\rm R}}^{{-1}}}\ :\ {D_{\lambda}}\ \to\ {{{\rm E}}_{\lambda}} $$ ${{\rm D}}_{0}$ is created as a result of an R-application performed on input ${{\rm E}}_{0}$. The termination condition depends on some profit criterion related to the arithmetic complexity of the latest version of the input, ${{{\rm D}}_i}$. Hence we assume ${{{\rm profit}}_i}\ =\ true$ for $i\ =\ 0,..., \lambda -1$ and ${{{\rm profit}}_\lambda}\ =\ false$. The function T is composite as well, and defined by ${{\rm T}}\ =\ {{\rm F}}\ \circ\ {{{{\rm T}}_{\beta}}^{\lambda}}$. ${{\rm T}}_{\beta}$ defines one iteration step, i.e. one application of the extended version of Breuer's algorithm. The function F defines a finishing touch, resulting in the final version $D_{\lambda}$ of ${{\rm D}}_{0}$, used to produce the output ${{\rm E}}_{\lambda}$. We omit a further discussion of the different algorithms used for optimization; this can be found in~\cite{vanHulzen:81,vanHulzen:83}, for instance. The present version makes use of some GENTRAN facilities to translate its input into LISP prefix forms. This approach can be seen as a form of preprocessing, i.e. ${{\rm E}}_{0}$, the input for R can be considered as a list of {\bf setq}-applications The GENTRAN-SCOPE Interface, allows other preprocessing activities. We introduced the optional use of GENTRAN's {\bf declare}-statement, \index{DECLARE statement ! GENTRAN} thus allowing specification of the type of some or all of the lhs's and of the identifiers used to construct the rhs's. In addition to the prefixlist, a list of declarations in the Target Language can be produced, based on default assumptions concerning untyped lhs's and identifiers in the input. This facility is based on the use of GENTRAN's symbol table. Before optimizing rhs's it might be attractive to rewrite them using a \index{Horner's Rule} generalized form of Horner's Rule. We designed such a command, which does not necessarily have to be used in the context of SCOPE. It can operate on a set of assignment statements and it can deliver the result in the form of a sequence of prefix forms, defining the rewritten statements. Subjecting such a sequence of prefix forms to a SCOPE application implies that the GENTRAN approach is not directly applicable. The GENTRAN := and :=: assignment operators define literal translation or rhs-simplification, respectively. Therefore we extended our Interface with special facilities, allowing SCOPE to accept the result of the application of such a command literally. Besides the {\bf g}(eneralized) {\bf horner} (rule) we have a command, generalizing the impact of the {\bf structr}-command to a set of assignment statements. We discuss and illustrate a straightforward use of SCOPE in section~\ref{SCOPE:basic} In section~\ref{SCOPE:pre} we introduce the special commands {\bf ghorner} and {\bf gstructr} and show how to use them, also in combination with SCOPE. We use section~\ref{SCOPE:decl} to discuss the declaration facilities and section~\ref{SCOPE:files} to show the different file-handling possibilities and modes of operation. Section!\ref{SCOPE:future} discusses future work. Guidelines for installing the package are given in the final section. \section{Source-Code Optimization : The Basic Facilities}\label{SCOPE:basic} \subsection{The Strategy} Before illustrating the effect of applying SCOPE, we shortly describe the operations, covered by the functions ${{\rm T}}_{\beta}$ and F, mentioned in the previous section. The function R accepts assignment statements given in prefix form. We can divide these forms in three categories using their leading operator. We distinguish between PLUS, TIMES and OTHER-operators. Leaving aside the OTHER-operators for awhile, we reduce the structure of possible rhs's to those of not necessarily expanded multivariate polynomials with integer coefficients. Assuming the leading operator \ttindex{PLUS} is PLUS, the operands, being terms of a polinomial (for instance $3a\ +\ 2b\ +\ 3 {b^2} c (3a\ +\ 2b){(c\ +\ d)^2}$), can either be primitive or composite. A primitive term is an integer, an identifier or the product of an integer and an identifier. Hence the primitive terms of a sum form an (eventually empty) linear expression ($3a\ +\ 2b$). Composite terms are products, which cannot be qualified as a primitive term ($3 {b^2} c (3a\ +\ 2b) {(c\ +\ d)}^{2}$) Like sums, \ttindex{TIMES} prefix forms with a TIMES-operator, can have a primitive and/or composite part. The primitive part of a product is an (eventually empty) power product(${b^2} c$). The composite part is a product of sums and/or powers of sums ($(3a\ +\ 2b) {(c\ +\ d)^2}$). Observe that our expression-structure discussed so far is still too simple. \ttindex{EXPT} Powers of sums have EXPT as their leading operator (${(c\ +\ d)}^{2}$). Similarly, a product can have a integer coefficient ($3 {b^2} c$). This description suggests, as already indicated in section~\ref{SCOPE:intro}, that we can consider any set of rhs's as being built with linear expressions and power products only. This allows to map such a set onto two incidence matrices: One defining the linear expressions, using the coefficients, and another defining the power products, using the exponents. The rows of these matrices can be associated with the (sub)expressions under consideration and the columns with the identifiers, used to construct these expressions. This is why we need to assume the validity of the commutative and associative law. To be able to retrieve the structure of the assignment statements forming the input set, we need to combine additional information with the rows and columns of these matrices. Essential is, for instance, storage of the exponents of sums and of the coefficients of products. Equally important is storage of the lhs's, which are the rhs-recognizers. Details are given in~\cite{vanHulzen:83}. Example~\ref{ex:2.2.1} on page~\pageref{ex:2.2.1} and example~\ref{ex:2.2.2} on page~\pageref{ex:2.2.2} provide illustrations of these data structures. When introducing kernels, i.e. when assuming the set of OTHER-operators to be not empty, we have to store lists of non-commutable arguments. Therefore a function table of pairs is made, formed by the kernels and their internally created names. These names are entered in the matrices as new identifiers. The arguments of such a kernel can be arbitrary {\REDUCE}-expressions, which also have to be incorporated in the matrices. Hence the function table is created recursively. \index{cse (common subexpressions)} What is a cse and how do we locate its occurrences? A (sub)expression is common when it occurs repeatedly in the input. The occurrences are, as part of the input, distributed over the matrices, and shown as equivalent integer (sub)patterns. In fact, we repeatedly search for completely dense (sub)matrices of rank 1. The expression $2a\ +\ 3c$ is a cse of ${e_1} \ =\ 2a\ +\ 4b\ +\ 3c$ and ${e_2}\ =\ 4a\ +\ 6c\ +\ 5d$, representable by (2,4,3,0) and (4,0,6,5), respectively. We indeed have to assume commutativity, so as to be able to produce new patterns (2,0,3,0,0), (0,4,0,0,1) and (0,0,0,5,2), representing $s\ =\ 2a\ +\ 3c$, ${e_1}\ =\ 4b\ +\ s$ and ${e_2}\ =\ 5d\ +\ 2s$, respectivily, and thus saving one addition and one multiplication. Such an additive cse can be a factor in a composite (sub)product, which in turn can be reduced to a primitive product, when the cse is replaced by a new symbol. Therefore an essential part of an optimization step is regrouping of information. This migration of information between the matrices is performed if the Breuer-searches are temporarily completed. After this regrouping the distributive law is applied, eventually also leading to a further regrouping. If at least one of these actions leads to a rearrangement of information the function ${\rm T} _{\beta}$ is again applied. Observe that this ${{\rm T}}_{\beta}$ is also a composite function. In view of the iterative character of the optimization process we always accept minimal profits. A similar search is performed to detect multiplicative cse's, for instance occuring in ${e_1}\ =\ {a^2} {b^4} {c^3}$ and ${e_2}\ =\ {a^4} {c^6} {d^5}$. However, given a power product $\prod_{i=1}^m {x_i}^{{a}_i}$, any product $\prod_{i=1}^m {x_i}^{{b}_i}$, such that some ${b_i}\ \ {a_i}$, for i = 1(1)m, can function as a cse. We therefore extend the search for multiplicative cse's by employing this property, and as indicated in~\cite{vanHulzen:83}. The function F -defining the finishing touch- performs one-row and/or one-column searches. Once the extended Breuer-searches do not lead to further reduction in the arithmetic complexity we try -applying it- to improve what is left. The integer coefficients in (sub)sums can have, possibly locally, a gcd, which can be factored out. One-column operations serve to discover and properly replace integer multiples of identifiers. As part of the output-process we subject all exponentiations left - at most one for each identifier - to an addition chain algorithm. Another action, covered by F is therefore replacement by a new symbol of those (sub)sums, which are raised to some integer power. \subsection{The Facilities} {\REDUCE} allows, roughly speaking, two modes of operation: {\tt ON EXP} or {\tt OFF EXP}. The first alternative is the default setting leading to expanded forms. The latter gives unexpanded forms, as discussed by Hearn in some detail~\cite{Hearn:85,Hearn:86}. It is obvious that the {\tt OFF EXP} setting is in \index{EXP switch} general preferable over the {\tt ON EXP} setting when attempting to optimize the description of a set of assignment statements. Starting a {\REDUCE} session gives the initial state. All switches have their initial value: {\tt ON EXP, PERIOD} and {\tt OFF FORT}, for instance. When loading SCOPE we create a new operating environment, without disturbing the current state of the system. The result of an application of SCOPE can be influenced by the use of certain {\REDUCE}- or SCOPE-switches. The influence of {\tt EXP} is obvious. \index{ACINFO switch} \index{echo ! in SCOPE} By default the switch {\tt ACINFO} is turned on. This guarantees an echo of the form in which the assignment statements are consumed by SCOPE. It also guarantees tables with the numbers of arithmetic operations, occuring in ${{{\rm E}}_0}$ and ${{\rm E}}_{\lambda}$, respectively, to be printed. Some switches are available to obtain information about the process itself. They were introduced to assist in debugging \index{tracing ! SCOPE package} \index{PRIMAT switch} and testing. {\tt PRIMAT} can be used to visualize both ${{\rm D}}_{0}$ and \index{PRIALL switch} $D_{\lambda}$. {\tt PRIALL} is a switch which combines not only the effect of {\tt ACINFO} and {\tt PRIMAT}, but also allows to obtain timings of the different sub-algorithms of SCOPE. Output is by default given in {\REDUCE} syntax, but FORTRAN syntax is \index{PREFIX switch} possible in the usual way. The switch {\tt PREFIX} can be used to obtain the prefixlist itself as output. \index{OPTIMIZE command} A SCOPE action is easily performed. Either the command ``{\bf optimize} $<$ object$>$;'' or the command ``{\bf optimize} $<$object$>$ {\bf iname} $<$cse-prefix$>$;'' suffices. The $<$object$>$ to be elaborated is either one assignment statement or a list of such statements, all obeying the GENTRAN rules. The $<$cse-prefix$>$ is an identifier, used to generate the cse-names, by extending it with an integer part. The {\bf gensym}-function is applied when the {\bf iname}-extension is omitted. We now illustrate the use of SCOPE through some small examples, by showing parts of {\REDUCE} sessions. \example\label{ex:2.2.1} \index{SCOPE package ! example} The multivariate polynomial Z is a sum of 6 composite terms. These terms, monomials, are constant multiples of primitive products. A picture of ${{\rm D}}_{0}$ is shown after the input echo. The sums-matrix consists of only one row, identifiable by its Fa(the)r Z, the lhs. Its exponent is given in the E(xponent or )C(oefficient) field. The 6 monomials are stored in the products-matrix. The coefficients are stored in the EC-fields and the predecessor row index, 0, is given in the Far-field. Before the $D_{\lambda}$ picture is given the effect of the optimization process, the output and the operator counts are shown. The optimized form of Z is obtained by applying the distributive law. The output also shows applications of an addition chain algorithm (\cite{Knuth:80} 441-466) as part of ${{\rm R}}^{{-1}}$, although its use in example~\ref{ex:2.2.3} is more apparent. Observe that the output illustrates the heuristic character of the optimization process: In this particular case the rhs can be written as a polynomial in S3, thus saving one extra multiplication. {\small \begin{verbatim} on primat$ optimize z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+ 2*b^2*m^6+b^2*m^2 iname s; 2 2 2 6 2 2 4 2 6 2 2 Z := A *B + 10*A *M + A *M + 2*A*B*M + 2*B *M + B *M Sumscheme : || EC|Far - ------------ 0|| 1| Z - ------------ Productscheme : | 0 1 2| EC|Far - --------------------- 1| 2 2| 1| 0 2| 6 2| 10| 0 3| 2 2| 1| 0 4| 4 1 1| 2| 0 5| 6 2 | 2| 0 6| 2 2 | 1| 0 - --------------------- 0 : M 1 : B 2 : A Number of operations in the input is: Number of (+,-)-operations : 5 Number of (*)-operations : 10 Number of integer exponentiations : 11 Number of other operations : 0 S0 := B*A S4 := M*M S8 := B*B S1 := S4*S8 S9 := A*A S2 := S4*S9 S3 := S4*S4 Z := S1 + S2 + S0*(2*S3 + S0) + S3*(2*S1 + 10*S2) Number of operations after optimization is: Number of (+,-)-operations : 5 Number of (*)-operations : 12 Number of integer exponentiations : 0 Number of other operations : 0 Sumscheme : | 0 3 4 5| EC|Far - ------------------------ 0| 1 1| 1| Z 15| 2 10| 1| 14 17| 2 1 | 1| 16 - ------------------------ 0 : S3 3 : S0 4 : S1 5 : S2 Productscheme : | 8 9 10 11 17 18 19 20| EC|Far - ------------------------------------ 7| 1 1| 1| S0 8| 1 2 | 1| S1 9| 1 2| 1| S2 10| 2 | 1| S3 11| 2 | 1| S4 14| 1 | 1| 0 16| 1 | 1| 0 - ------------------------------------ 8 : S4 9 : S3 10 : S2 11 : S1 17 : S0 18 : M 19 : B 20 : A \end{verbatim}} \example\label{ex:2.2.2} \index{SCOPE package ! example} The input echo below shows the literal copy of the first assignment, in accordance with the GENTRAN := operator. The second assignment, again in accordance with the GENTRAN operator ::=:, has a rhs in expanded form. \newline The ${{\rm D}}_{0}$ picture shows that during parsing string matching of kernels in prefix form already contributes to optimization : S2 = C*X + D and S3 =SIN(S2) are stored once. Application of the distributive law gives the original structure of A(1,1) back. {\small \begin{verbatim} on primat$ operator a$ k:=j:=1$ u:=c*x+d$ v:=sin(u)$ optimize {a(k,j) := v*(v^2*cos(u)^2+u), a(k,j) ::=:v*(v^2*cos(u)^2+u)} iname s; 2 2 A(K,J) := V*(V *COS(U) + U) 2 3 A(1,1) := COS(C*X + D) *SIN(C*X + D) + SIN(C*X + D)*C*X + SIN(C*X + D)*D \end{verbatim} \newpage \begin{verbatim} Sumscheme : | 7 8| EC|Far - ------------------ 1| 1 | 1| 0 3| | 1| A(1,1) 5| 1| 1| S2 - ------------------ 7 : U 8 : D Productscheme : | 0 1 2 3 4 5 6| EC|Far - --------------------------------- 0| 1| 1| A(K,J) 2| 2 2| 1| 1 4| 3 2 | 1| 3 6| 1 1 | 1| 5 7| 1 1 1 | 1| 3 8| 1 1 | 1| 3 - --------------------------------- 0 : D 1 : S3=SIN(S2) 2 : S1=COS(S2) 3 : X 4 : C 5 : S0=COS(U) 6 : V Number of operations in the input is: Number of (+,-)-operations : 7 Number of (*)-operations : 10 Number of integer exponentiations : 4 Number of other operations : 5 S6 := COS(U)*V S9 := S6*S6 A(K,J) := V*(U + S9) S2 := D + X*C S3 := SIN(S2) S7 := S3*COS(S2) S8 := S7*S7 A(1,1) := S3*(S2 + S8) Number of operations after optimization is: Number of (+,-)-operations : 3 Number of (*)-operations : 7 Number of integer exponentiations : 0 Number of other operations : 3 Sumscheme : | 2 12 13| EC|Far - --------------------- 1| 1 | 1| 0 3| | 1| A(1,1) 5| 1| 1| S2 11| 1 | 1| 10 - --------------------- 2 : S2 12 : U 13 : D Productscheme : | 0 1 5 6 7 8 9 10 11| EC|Far - --------------------------------------- 0| 1| 1| A(K,J) 2| 2 | 1| 1 4| 2 | 1| 11 9| 1 1 | 1| 5 10| 1 | 1| 3 13| 1 1| 1| S6 14| 1 1 | 1| S7 - --------------------------------------- 0 : S7 1 : S6 5 : D 6 : S3=SIN(S2) 7 : COS(S2) 8 : X 9 : C 10 : COS(U) 11 : V \end{verbatim}} \example\label{ex:2.2.3} \index{SCOPE package ! example} The effect is shown of a finishing touch application, in combination with FORTRAN output. During output preparation {\tt S0} is rewritten, using the earlier mentioned addition chain algorithm. {\small \begin{verbatim} on fort$ off acinfo,period$ optimize z:=96*a+18*b+9*c+3*d+6*e+18*f+6*g+5*h+5*k+3)^13 iname s; S0=5*(H+K)+3*(3*C+D+1+6*(B+F)+2*(A+E+G)) S4=S0*S0 S3=S0*S4 S2=S3*S3 S1=S2*S2 Z=S0*S1 \end{verbatim}} \example\label{ex:2.2.4} \index{SCOPE package ! example} Recovery of repeatedly occurring integer multiples of identifiers, as part of the finishing touch, is illustrated. The switch {\tt ACINFO} is turned off. \begin{verbatim} optimize {x:=3*a*p, y:=3*a*q, z:=6*a*r+2*b*p, u:=6*a*d+2*b*q, v:=9*a*c+4*b*d, w:=4*b} iname s; S1 := 3*A X := S1*P Y := S1*Q S2 := 6*A S3 := 2*B Z := S3*P + S2*R U := S3*Q + S2*D S0 := 4*B V := S0*D + 9*A*C W := S0 \end{verbatim} \example\label{ex:2.2.5} \index{SCOPE package ! example} The effect of {\tt ON EXP} or {\tt OFF EXP} on the result of a SCOPE-application is now shown by optimizing the representation of the determinant of a symmetric (3,3) matrix M. Besides differences in computing time we also observe that the arithmetic complexity of the optimized version of the expanded representation of the determinant is about the same as the not optimized form of the unexpanded representation. {\small \begin{verbatim} matrix M(3,3)$ m(1,1):=18*cos(q3)*cos(q2)*m30*p^2-sin(q3)^2*j30y+sin(q3)^2*j30z- 9*sin(q3)^2*m30*p^2+j1oy+j30y+m10*p^2+18*m30*p^2$ m(2,1):= m(1,2):=9*cos(q3)*cos(q2)*m30*p^2-sin(q3)^2*j30y+sin(q3)^2*j30z- 9*sin(q3)^2*m30*p^2+j30y+9*m30*p^2$ m(3,1):= m(1,3):=-9*sin(q3)*sin(q2)*m30*p^2$ m(2,2):=-sin(q3)^2*j30y+sin(q3)^2*j30z-9*sin(q3)^2*m30*p^2+j30y+ 9*m30*p^2$ m(3,2):= m(2,3):=0$ m(3,3):=9*m30*p^2+j30x$ optimize detm:=:det(M) iname s; 4 2 6 3 4 2 4 2 DETM := 729*SIN(Q3) *SIN(Q2) *P *M30 + 81*SIN(Q3) *SIN(Q2) *P *M30 * 4 2 4 2 2 2 6 J30Y - 81*SIN(Q3) *SIN(Q2) *P *M30 *J30Z - 729*SIN(Q3) *SIN(Q2) *P * 3 2 2 4 2 2 6 3 M30 - 81*SIN(Q3) *SIN(Q2) *P *M30 *J30Y - 729*SIN(Q3) *P *M30 - 81* 2 6 2 2 4 2 2 4 2 SIN(Q3) *P *M30 *M10 - 81*SIN(Q3) *P *M30 *J30Y + 81*SIN(Q3) *P *M30 2 4 2 2 4 2 *J30Z - 81*SIN(Q3) *P *M30 *J1OY - 81*SIN(Q3) *P *M30 *J30X - 9* 2 4 2 4 2 4 SIN(Q3) *P *M30*J30Y*M10 + 9*SIN(Q3) *P *M30*J30Z*M10 - 9*SIN(Q3) *P 2 2 2 2 *M30*M10*J30X - 9*SIN(Q3) *P *M30*J30Y*J1OY - 9*SIN(Q3) *P *M30*J30Y* 2 2 2 J30X + 9*SIN(Q3) *P *M30*J30Z*J1OY + 9*SIN(Q3) *P *M30*J30Z*J30X - 9* 2 2 2 2 2 2 SIN(Q3) *P *M30*J1OY*J30X - SIN(Q3) *P *J30Y*M10*J30X + SIN(Q3) *P * 2 2 J30Z*M10*J30X - SIN(Q3) *J30Y*J1OY*J30X + SIN(Q3) *J30Z*J1OY*J30X - 2 2 6 3 2 2 4 2 729*COS(Q3) *COS(Q2) *P *M30 - 81*COS(Q3) *COS(Q2) *P *M30 *J30X + 6 3 6 2 4 2 4 2 729*P *M30 + 81*P *M30 *M10 + 81*P *M30 *J30Y + 81*P *M30 *J1OY + 81 4 2 4 4 2 *P *M30 *J30X + 9*P *M30*J30Y*M10 + 9*P *M30*M10*J30X + 9*P *M30*J30Y 2 2 2 *J1OY + 9*P *M30*J30Y*J30X + 9*P *M30*J1OY*J30X + P *J30Y*M10*J30X + J30Y*J1OY*J30X Number of operations in the input is: Number of (+,-)-operations : 36 Number of (*)-operations : 148 Number of integer exponentiations : 84 Number of other operations : 32 S0 := SIN(Q3) S30 := S0*S0 S1 := SIN(Q2) S34 := S1*S1 S35 := P*P S7 := S35*M30 S33 := S7*S7 S5 := S33*J30Y S6 := S30*S7 S8 := S30*M10 S49 := COS(Q2)*COS(Q3) S9 := S49*S49 S11 := S34*S30*S30 S22 := S35*S7 S14 := S30*J30Z S19 := S35*J30X S23 := J30X*J10Y S31 := S33*S7 S47 := 81*S33*J30X S39 := - S47 - S23*J30Y - 81*S33*J1OY S40 := - 81*S30*S5 - 729*S33*S6 S45 := 9*S6*J30Z S46 := 9*S6 S48 := 81*S5 DETM := S48 + S40 - S39 + 729*S31 + ( - J1OY - J30X)*(9*(S6*J30Y - S7 *J30Y) - S45) + (J30Z - J30Y)*(9*S22*S8 + S19*S8) + 9*(M10 - S8 )*(S22*J30X + 9*S22*S7) + M10*J30Y*(9*S22 + S19) + S23*(S14 + 9*S7 - S46) + S39*S30 + S31*(729*(S11 - S9)) + S34*(S40 - S46*S45) - S47*S9 + 81*S33*S14 + S48*S11 Number of operations after optimization is: Number of (+,-)-operations : 29 Number of (*)-operations : 58 Number of integer exponentiations : 0 Number of other operations : 4 off exp$ optimize detm:=:det(M) iname s; 2 2 2 DETM := ((9*P *M30 + J30Y - J30Z)*SIN(Q3) - (18*M30 + M10)*P - 18 2 2 *COS(Q3)*COS(Q2)*P *M30 - J30Y - J1OY)*((9*P *M30 + J30Y - 2 2 2 J30Z)*SIN(Q3) - 9*P *M30 - J30Y)*(9*P *M30 + J30X) - 2 2 2 ((9*P *M30 + J30Y - J30Z)*SIN(Q3) - 9*COS(Q3)*COS(Q2)*P *M30 - 2 2 2 2 9*P * M30 - J30Y) *(9*P *M30 +J30X) + 81*((9*P *M30+J30Y - J30Z)* 2 2 2 2 4 2 SIN(Q3) - 9*P *M30 - J30Y)*SIN(Q3) *SIN(Q2) *P *M30 Number of operations in the input is: Number of (+,-)-operations : 24 Number of (*)-operations : 42 Number of integer exponentiations : 21 Number of other operations : 10 S0 := SIN(Q3) S9 := S0*S0 S8 := P*P S5 := S8*M30 S6 := S5*COS(Q2)*COS(Q3) S15 := 9*S5 S13 := (S15 + J30Y - J30Z)*S9 S14 := S13 - S15 - J30Y S3 := S14 - 9*S6 S4 := SIN(Q2) DETM := (S15 + J30X)*(S14*(S13 - 18*S6 - J30Y - J1OY - S8*(18*M30 + M10)) - S3*S3) + 9*S15*S14*S9*S5*S4*S4 Number of operations after optimization is: Number of (+,-)-operations : 13 Number of (*)-operations : 20 Number of integer exponentiations : 0 Number of other operations : 4 \end{verbatim}} We can also use this example to show that correctness of the results \index{NAT switch} can easily be verified. When turning off the switch {\tt NAT} and storing the result of a SCOPE application in a file, it is of course possible to read the result in again. But we then operate in a normal {\REDUCE}-like way. This implies that all cse-names are automatically replaced by their values. We show the ``correctness'' of SCOPE by scoring the optimized version of the expanded form of the determinant of M, called detm1 in file out1 and the result of a SCOPE-application on the unexpanded form, detm2, in file out2, followed by reading both files and by subtracting detm2 from detm1, resulting in the value 0. This is of course an ad hoc correctness-proof for one specific example. It is in fact another way of testing the code of the package. So, assuming SCOPE is loaded and the matrix M is known to the system, all we have to do is: {\small \begin{verbatim} 2: off acinfo,nat$ 3: out out1$ 4: optimize detm1:=:det(M) iname s; 5: write "end$"$ 6: shut "out1"$ 7: off exp$ 8: out out2$ 9: optimize detm2:=:det(M) iname t; 10: write "end$"$ 11: shut out2$ 12: on nat$ 13: in out1; S0 := SIN(Q3)$ S30 := S0*S0$ S1 := SIN(Q2)$ S34 := S1*S1$ S35 := P*P$ S7 := S35*M30$ S33 := S7*S7$ S5 := S33*J30Y$ S6 := S30*S7$ S8 := S30*M10$ S49 := COS(Q2)*COS(Q3)$ S9 := S49*S49$ S11 := S34*S30*S30$ S22 := S35*S7$ S14 := S30*J30Z$ S19 := S35*J30X$ S23 := J30X*J1OY$ S31 := S33*S7$ S47 := 81*S33*J30X$ S39 := - S47 - S23*J30Y - 81*S33*J1OY$ S40 := - 81*S30*S5 - 729*S33*S6$ S45 := 9*S6*J30Z$ S46 := 9*S6$ S48 := 81*S5$ DETM1 := S48 + S40 - S39 + 729*S31 + ( - J1OY - J30X)*(9*(S6*J30Y - S7*J30Y) - S45) + (J30Z - J30Y)*(9*S22*S8 + S19*S8) + 9*(M10 - S8)*(S22*J30X + 9 *S22*S7) + M10*J30Y*(9*S22 + S19) + S23*(S14 + 9*S7 - S46) + S39*S30 + S31*(729*(S11 - S9)) + S34*(S40 - S46*S45) - S47*S9 + 81*S33*S14 + S48*S11$ end$ 14: in out2; T0 := SIN(Q3)$ T9 := T0*T0$ T8 := P*P$ T5 := T8*M30$ T6 := T5*COS(Q2)*COS(Q3)$ T15 := 9*T5$ T13 := (T15 + J30Y - J30Z)*T9$ T14 := T13 - T15 - J30Y$ T3 := T14 - 9*T6$ T4 := SIN(Q2)$ DETM2 := (T15 + J30X)*(T14*(T13 - 18*T6 - J30Y - J1OY - T8*(18*M30 + M10)) - T3*T3) + 9*T15*T14*T9*T5*T4*T4$ end$ 15: detm1-detm2; 0 \end{verbatim} } \example\label{ex:2.2.6} \index{SCOPE package ! example} This example serves to show how SCOPE deals with rational exponents. All rational exponents of a variable are collected. The least common multiple lcm of the denominators of these rational exponents is computed and the variable is replaced by a possibly newly selected variable name, denoting the variable raised to the power 1/lcm. This facility is only efficient for what we believe to be problems occurring in computational practice. This is easily verified by extending the sum we are elaborating here with some extra terms. Producing FORTRAN-output shows an implied danger, due to a shortcoming in GENTRAN. This rational exponent will in practice act as if it were 0. This example is also used to show the effect of turning on the switch {\tt PRIALL}. {\small \begin{verbatim} on fort,priall$ optimize z:=:for j:=2:6 sum q^(1/j) iname s; 1/6 1/5 1/4 1/3 Z := Q + Q + Q + Q + SQRT(Q) Sumscheme : || EC|Far - ------------ 0|| 1| Z - ------------ Productscheme : | 0| EC|Far - --------------- 1| 10| 1| 0 2| 12| 1| 0 3| 15| 1| 0 4| 20| 1| 0 5| 30| 1| 0 - --------------- 0 : Q Number of operations in the input is: Number of (+,-)-operations : 4 Number of (*)-operations : 0 Number of integer exponentiations : 0 Number of other operations : 5 Time: 2992 ms Breuer search : Time: 867 ms Removal of different names for identical cse's : Time: 17 ms Change Scheme : Time: 0 ms Local Factorization : Time: 34 ms Breuer search : Time: 204 ms Removal of different names for identical cse's : Time: 0 ms Change Scheme : Time: 17 ms Local Factorization : Time: 0 ms Breuer search : Time: 187 ms Removal of different names for identical cse's : Time: 0 ms Change Scheme : Time: 17 ms Local Factorization : Time: 0 ms Breuer search : Time: 119 ms Removal of different names for identical cse's : Time: 0 ms Change Scheme : Time: 17 ms Local Factorization : Time: 0 ms Additional optimization during finishing touch : Time: 34 ms Q=Q**(1/60) S7=Q*Q S6=S7*Q S4=S7*S6 S2=S4*S4 S1=S7*S2 S0=S6*S1 S3=S4*S0 Z=S3+S0+S1+S2+S3*S2 Number of operations after optimization is: Number of (+,-)-operations : 4 Number of (*)-operations : 8 Number of integer exponentiations : 0 Number of other operations : 1 \end{verbatim} \newpage \begin{verbatim} Sumscheme : | 3 4 5 6| EC|Far - ------------------------ 0| 1 1 1 1| 1| Z - ------------------------ 3 : S3 4 : S0 5 : S1 6 : S2 Productscheme : | 9 10 12 13 14 15 16 22| EC|Far - ------------------------------------ 5| 1 1 | 1| 0 6| 1 1 | 1| S0 7| 1 1 | 1| S1 8| 2 | 1| S2 9| 1 1 | 1| S3 10| 1 1 | 1| S4 12| 1 1| 1| S6 13| 2| 1| S7 - ------------------------------------ 9 : S7 10 : S6 12 : S4 13 : S3 14 : S2 15 : S1 16 : S0 22 : Q Time: 459 ms \end{verbatim} } \section{Preprocessing Possibilities}\label{SCOPE:pre} It may happen that structure is obviously visible in the rhs's of a set of assignment statements, which we want to optimize. One can think of a set of partial derivatives of products. Or one may consider the application of Horner-rules. Such facilities may be attractive, independent of the question if a SCOPE-application will be performed on its result. Therefore we first discuss these facilities and show their effect, again by using simple examples, before we continue with a combined use of SCOPE and these possibilities. The first alternative demands a generalized {\bf structr}-command. We implemented such a facility. Its syntax is straightforward: ``{\bf \index{GSTRUCTR command} gstructr} $<$object$>$ {\bf name} $<$id$>$;'' The $<$object$>$ to be elaborated is one assignment statement or a set of such statements, separated by semicolons and grouped together between the special symbols $<<$ and $>>$. Instead of a statement a matrix name is also allowed. Then all non-zero matrix elements are incorporated in the search for obvious cse's. The $<$id$>$ of the optional {\bf name}-part, being an identifier, is used to identify the subexpressions, produced via the application of a {\bf gstructr} command. When the switch \index{ALGPRI switch} {\tt ALGPRI} is on -the default setting- the output is given in {\REDUCE} syntax, while turning it off leads to output in prefix form. The latter is employed by the function R, used to store SCOPE-input in ${{\rm D}}_{0}$. It is also possible to get FORTRAN-output by turning \index{PERIOD switch} \index{FORTRAN switch} off the switch {\tt PERIOD} and turning on the switch {\tt FORTRAN}. The input \index{EXP switch} remains unchanged when the switch {\tt EXP} is on. \example\label{ex:3.1} \index{SCOPE package ! example} We show part of a {\REDUCE} session. {\small \begin{verbatim} off exp$ matrix a(2,2)$ a(1,1) := x+y+z$ a(1,2) := x*y$ a(2,1) := (x+y)*x*y$ a(2,2) := (x+2*y+3)^3-x$ on fort$ off period$ load struct$ gstructr << a; b:=(x+y)^2; c:=(x+y)*(y+z); d:=(x+2*y)*(y+z)*(z+x)^2 >> name v; V1=X+Y+Z A(1,1)=V1 A(1,2)=X*Y V2=X+Y A(2,1)=V2*X*Y V3=X+2*Y+3 V4=V3**3-X A(2,2)=V4 B=V2**2 V5=Y+Z C=V2*V5 V6=X+2*Y V7=X+Z D=V6*V7**2*V5 \end{verbatim} } Observe that V1, V3, V4, V6 and V7 only occur once in this result of a {\bf gstructr}-application. When applied as part of a SCOPE-operation these redundancies will be removed before the actual optimization process is performed, as shown in example~\ref{ex:3.3}. \index{GHORNER command} \index{Horner's Rule} The syntax for the {\bf ghorner}-command is very similar. The application of a Horner-rule assumes an ordering of the identifiers. We allow instead of the {\bf name}-part of the {gstructr} command an optional {\bf vorder} $<$list of id.s$>$ extension. The $<$list of id.s$>$ consists of at least one identifier. This list overrules, in the order given, the current identifier ordering of the system. The rhs's are considered as polynomials in the leftmost element of the {\bf vorder}-list. The thus created coefficients are in turn considered as polynomials in the second element of this list. And so on. When the {\bf vorder}-extension is omitted the current system identifier ordering is applied. The internal switch {\tt ALGPRI} is again \index{ALGPRI switch} applicable and has the same meaning as for {\bf gstructr}. Some optimizing compilers apply Horner-rules when possible. Our optimization strategy is based on an all levels, all expressions search. This contradicts the Horner-mechanism. To avoid destabilizing side-effects of Horner-rule applications we decided to bring such a facility under user-control. \example\label{ex:3.2} \index{SCOPE package ! example} Some Taylor-expansions are shown. \newpage {\small \begin{verbatim} algebraic procedure taylor(fx,x,x0,n); sub(x=x0,fx)+for k:=1:n sum (sub(x=x0,df(fx,x,k))*(x-x0)^k/ (if k<3 then k else for j:=2:k product j))$ let x^4=0,y^7=0$ f1:=(taylor(e^x,x,0,4)*taylor(cos y,y,0,6))^2; 3 6 3 4 3 2 3 2 6 2 F1 := - (8*X *Y - 60*X *Y + 180*X *Y - 180*X + 12*X *Y - 90*X * 4 2 2 2 6 4 2 Y + 270*X *Y - 270*X + 12*X*Y - 90*X*Y + 270*X*Y - 6 4 2 270*X + 6*Y - 45*Y + 135*Y - 135)/135 load horner$ ghorner << f1:=f1; g1:=taylor(e^x,x,0,4); h1:=taylor(cos y,y,0,6); f1:=(g1*h1)^2 >> vorder y,x; 2 F1 := ((135 + X*(270 + X*(270 + X*180))) + Y *(( - 135 + X*( - 270 + 2 X*( - 270 + X*(-180)))) + Y *((45 + X*(90 + X*(90 + X 2 *60))) + Y *( - 6 + X*( - 12 + X*( - 12 + X*(-8 )))))))/135 6 + X*(6 + X*(3 + X)) G1 := ----------------------- 6 2 2 2 720 + Y *( - 360 + Y *(30 + Y *(-1))) H1 := --------------------------------------- 720 2 2 2 2 2 (6 + X*(6 + X*(3 + X))) * (-720 + Y *(360 + Y ( - 30 + Y ))) F1 := --------------------------------------------------------------- 18662400 \end{verbatim} } Both commands can be used inside an {\bf optimize}-command. We advise to compile both facilities and SCOPE separately (see also section~\ref{SCOPE:install} on page~\pageref{SCOPE:install}). To be able to order the application of either a {\bf gstructr}-command or a {\bf ghorner}-rewrite instruction inside the definition of a SCOPE-operation we have to extend the rules given in section~\label{SCOPE:2.2}. The permissible structures for the $<$object$>$'s to be elaborated by SCOPE are simply extended with syntactically correct {\bf ghorner}-and {\bf gstructr}-commands. Hence the structure of an {\bf optimize}-command is not altered, as is shown by the following two examples. \example\label{ex:3.3} \index{SCOPE package ! example} We show the effect of an application of the {\bf optimize}-command on the {\bf gstructr}-command of example~\ref{ex:3.1}. Observe that the cse-names produced during optimization begin with an S, while {\bf gstructr} created names start with a V. {\small \begin{verbatim} on fort,acinfo$ off exp,period$ optimize gstructr << a; b:=(x+y)^2; c:=(x+y)*(y+z); d:=(x+2*y)*(y+z)*(z+x)^2 >> name v iname s; A(1,1) := X + Y + Z A(1,2) := X*Y V2 := X + Y A(2,1) := V2*X*Y 3 A(2,2) := (X + 2*Y + 3) - X 2 B := V2 V5 := Y + Z C := V2*V5 2 D := (X + 2*Y)*(X + Z) *V5 Number of operations in the input is: Number of (+,-)-operations : 9 Number of (*)-operations : 8 Number of integer exponentiations : 3 Number of other operations : 0 S5=X+Z A(1,1)=S5+Y S8=Y*X A(1,2)=S8 V2=X+Y A(2,1)=S8*V2 S6=X+2*Y S4=S6+3 A(2,2)=S4*S4*S4-X B=V2*V2 V5=Y+Z C=V5*V2 D=S6*S5*S5*V5 Number of operations after optimization is: Number of (+,-)-operations : 7 Number of (*)-operations : 10 Number of integer exponentiations : 0 Number of other operations : 0 \end{verbatim} } \example\label{ex:3.4} \index{SCOPE package ! example} For completeness we also show how to use the Horner facilities inside an {\bf optimize} command. Due to the structure of the method, we operate internally on expanded forms, both representations of h1, and thus also of the corresponding prefix representations used to built ${{\rm D}}_{0}$ slightly differ. The consequences are visualized in the results of the SCOPE application. {\small \begin{verbatim} load scope$ optimize ghorner <<h1:=taylor(cos y,y,0,6); f1:=(taylor(e^x,x,0,4)*h1)^2>> vorder y,x iname s; 2 2 2 720 + Y *( - 360 + Y *(30 + Y *(-1))) H1 := --------------------------------------- 720 2 2 2 2 2 (6+X*(6 + X*(3+X))) *(-720+Y *(360 + Y *( - 30 + Y ))) F1 := ------------------------------------------------------- 18662400 Number of operations in the input is: Number of (+,-)-operations : 9 Number of (*)-operations : 8 Number of integer exponentiations : 8 Number of other operations : 2 S6 := Y*Y 720 + S6*(S6*(30 - 1*S6) - 360) H1 := --------------------------------- 720 S7 := (S6*(360 + S6*(S6 - 30)) - 720)*(6 + X*(6 + X*(3 + X))) S7*S7 F1 := ---------- 18662400 Number of operations after optimization is: Number of (+,-)-operations : 9 Number of (*)-operations : 10 Number of integer exponentiations : 0 Number of other operations : 2 \end{verbatim} } \section{Generation of Declarations}\label{SCOPE:decl} The GENTRAN {\bf declare}-statement can also be used as an optional extension of the {\bf optimize}-command. An illustration of this facility is given in example~\ref{ex:4.1}. The syntax of such a statement is in accordance with the GENTRAN-rules~\cite{Gates:85} % (see page~\pageref{explicit:type}. We also use the symbol table of GENTRAN. During parsing, the declared identifiers and/or array- and matrix names are entered in the symbol table. Once optimization is finished all relevant information for completing the declarations is known, and collected in the prefixlist, which is used for output-production. This prefixlist is employed to decide which not yet typed identifiers and system selected cse-names have to be entered in the symbol table. We make use of already known information, expression-structure and the normal hierarchy in data types. The strategy to achieve this is essentially based on chapter 6 of~\cite{Aho:86}. Once this table is completed a list of declarations is produced if the \index{OPTDECS switch} switch {\tt OPTDECS} is turned on. SCOPE-output is by default given in {\REDUCE} syntax. Alternative output is obtained by assigning a \ttindex{Optlang*} relevant value to the global identifier {\tt Optlang!*}. This causes GENTRAN to take over the output preparation, as shown in: \example\label{ex:4.1} \index{SCOPE package ! example} {\small \begin{verbatim} on optdecs$ off acinfo$ optlang!*:='fortran$ optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s declare << a(4,4),x(4),y(5):real; b(5):integer >>; INTEGER B(5),I,S1,S3 DOUBLE PRECISION A(4,4),S4,X(4),Y(5) S1=I+1 S3=I-1 S4=B(I) X(S1)=A(S1,S3)+S4 Y(S3)=A(S3,S1)-S4 optlang!*:='c$ optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s declare << a(4,4),x(4),y(5):real; b(5):integer >>; LONG B[6],I,S1,S3; DOUBLE A[5][5],S4,X[5],Y[6]; { S1=I+1; S3=I-1; S4=B[I]; X[S1]=A[S1][S3]+S4; Y[S3]=A[S3][S1]-S4; } optlang!*:='pascal$ optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s declare << a(4,4),x(4),y(5):real; b(5):integer >>; VAR B[0..5],I,S1,S3: INTEGER; A[0..4,0..4],S4,X[0..4],Y[0..5]: REAL; BEGIN S1:=I+1; S3:=I-1; S4:=B[I]; X[S1]:=A[S1,S3]+S4; Y[S3]:=A[S3,S1]-S4 END; optlang!*:='ratfor$ optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s declare << a(4,4),x(4),y(5):real; b(5):integer >>; INTEGER B(5),I,S1,S3 DOUBLE PRECISION A(4,4),S4,X(4),Y(5) { S1=I+1 S3=I-1 S4=B(I) X(S1)=A(S1,S3)+S4 Y(S3)=A(S3,S1)-S4 } %%% The following command restores the initial situation. %%% optlang!*:='nil$ \end{verbatim} } \section{File Management and Optimization Strategies}\label{SCOPE:files} Another alternative for the $<$object$>$'s to be optimized is formed by the sequence {\bf in} ${{\rm file}}_{1}$, ${{\rm file}}_{2}$, ..., ${{\rm file}}_{n}$, $n\ \ge\ 1$. Each of these files is assumed to contain one or a list of more assignment statements, obeying the GENTRAN-assignment rules. A SCOPE application results in a unified sequence of assignment statements in the target language. This is illustrated by the following example, where each file $f_i$ contains one assignment statement of the form $e_i$ := some expression. \example\label{ex:5.1} \index{SCOPE package ! example} {\small \begin{verbatim} 3: optimize in f1,f2,f3 iname s; 2 2 (X + Y) 8 2 2 2*(SIN(X) - COS(E )+3*COS(X)) *(X+Y) + 4*Y + 4*Y E1 := --------------------------------------------------------- 3*X + 2*Y \end{verbatim} \newpage \begin{verbatim} E2 := (4* 2 2 (X + Y) 2 3 2 (SIN(X) - COS(E )+2*COS(X)) *(X+Y) +(4*X - 4*Y) 2 - 6*X)/(8*X + 3*Y - 2*X) 2 (X + Y) E3 := (4*SIN(COS(E )) + SIN(X + Y) + 2 2 (4*X - X + 2*Y) )/(3*Y + F(X,G( - COS(X)))) Number of operations in the input is: Number of (+,-)-operations : 21 Number of (*)-operations : 20 Number of integer exponentiations : 12 Number of other operations : 16 S3 := SIN(X) S7 := X + Y S6 := S7*S7 S6 S4 := COS(E ) S8 := COS(X) S28 := S3*S3 - S4 S2 := S28 + 3*S8 S36 := S2*S2 S35 := S36*S36 S30 := 2*Y S9 := S30 + 3*X 2*(2*Y + S30*Y + S6*S35*S35) E1 := ------------------------------ S9 S12 := S28 + 2*S8 S29 := 4*X*X S27 := S29 - X S31 := 3*Y S29 - 2*S9 + 4*S6*S12*S12*S7 E2 := ------------------------------ S31 + 2*S27 S18 := S30 + S27 4*SIN(S4) + SIN(S7) + S18*S18 E3 := ------------------------------- S31 + F(X,G( - S8)) Number of operations after optimization is: Number of (+,-)-operations : 15 Number of (*)-operations : 24 Number of integer exponentiations : 0 Number of other operations : 11 \end{verbatim} } However a switch is available for stepwise performing the optimization of a set of assignment statements, distributed over different files. When turning on this {\tt AGAIN} switch the finishing touch is not \index{AGAIN switch} done. Moreover, the system is instructed to save relevant internal information in combination with the result of the present optimization run. The thus extended output is assumed to be stored in a file. When the optimization task is continued during another session this file is assumed to be read before all other remaining files. This mode of operation is illustrated in \example\label{ex:5.2} \index{SCOPE package ! example} {\small \begin{verbatim} 2: off acinfo$ 3: in again$ 4: out f5$ 5: optimize in f1,f2 iname s; 6: write "end$"$ 7: shut f5$ 8: off again$ 9: on acinfo$ 10: optimize in f5,f3 iname t; S7 := X + Y \end{verbatim} \newpage \begin{verbatim} 2 S6 := S7 S8 := COS(X) 2 S6 S18 := SIN(X) - COS(E ) S9 := 3*X + 2*Y 2 8 4*Y + 4*Y + 2*S6*(S18 + 3*S8) E1 := --------------------------------- S9 2 S15 := X 2 4*S15 - 2*S9 + 4*S6*(S18 + 2*S8) *S7 E2 := -------------------------------------- 8*S15 - 2*X + 3*Y 2 (X + Y) E3 := (4*SIN(COS(E )) + SIN(X + Y) + 2 2 (4*X - X + 2*Y) )/(3*Y + F(X,G( - COS(X)))) Number of operations in the total input, i.e. in the 2 input sets is: Number of (+,-)-operations : 22 Number of (*)-operations : 20 Number of integer exponentiations : 13 Number of other operations : 17 T17 := X + Y T16 := T17*T17 S8 := COS(X) T1 := SIN(X) T16 T2 := COS(E ) S18 := T1*T1 - T2 T28 := 2*Y S9 := T28 + 3*X T6 := S18 + 3*S8 T36 := T6*T6 T35 := T36*T36 2*(2*Y + T28*Y + T35*T35*T16) E1 := ------------------------------- S9 S15 := X*X T9 := S18 + 2*S8 T30 := 4*S15 T26 := T30 - X T29 := 3*Y T30 - 2*S9 + 4*T17*T9*T9*T16 E2 := ------------------------------ T29 + 2*T26 T19 := T28 + T26 4*SIN(T2) + SIN(T17) + T19*T19 E3 := -------------------------------- T29 + F(X,G( - S8)) Number of operations after optimization is: Number of (+,-)-operations : 15 Number of (*)-operations : 24 Number of integer exponentiations : 0 Number of other operations : 11 \end{verbatim} } Since the construction of declarations in combination with some optimization activity is based on a quite specific use of GENTRAN's symbol table, one has to operate carefully when optimizing input in different sessions. A correct list of declarations is only guaranteed, when the last optimization-command is extended with the required declaration-information. \section{Some Possible Shortcomings and Future Versions}\label{SCOPE:future} The present version of SCOPE may have some shortcomings and possibly also some inefficiencies. However, since we are working on a second version, as stated in~\cite{vanHulzen:90}, we do not have the intention to largely modify the present version. However, we intend to improve one special aspect of the present SCOPE-version: The combined use of SCOPE and GENTRAN. This preliminary version of the manual will shortly be extended with the description of these combined features. Bugs and obvious deficiencies will of course be removed. \section*{Acknowledgements} The many discussions I had over the past years with Barbara L. Gates, Victor V. Goldman, Anthony C. Hearn, Jaap Smit and Paul S. Wang about the symbolic-numeric aspects of computer algebra have been very stimulating and valuable. They also contributed to the present status of SCOPE. Completion of the code would have been impossible without the dedicated assistance of my students and the frequent discussions we had. I certainly want to mention Ben Hulshof, Pim van den Heuvel, Marcel van Heerwaarden, Anco Smit, Johan de Boer and Jan Verheul. \section*{How to install the Code}\label{SCOPE:install} \index{SCOPE package ! installation} The code consists of a number of modules, collected in five files. Two of these modules play a special role and can best be compiled separately: gstructr, defining the {\bf gstructr} facilities, and ghorner, containing the code for the Horner-rules. The other modules form SCOPE. Since ${{\rm D}}_{0}$ and all operations on it and on its later versions ${{\rm D}}_{i}$ are defined using {\bf smacros's} it is essential to read in the module cosmac, containing these {\bf smacro's}, first. Since we also use part of the GENTRAN code care have to be taken that GENTRAN is loaded when compiling the code. \bibliography{scope} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/sl.bib version [7a9ae19f9c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @String{SPE="Software---Practice and Experience"} @ARTICLE{Hearn:69, AUTHOR = "A. C. Hearn", TITLE = "Standard {LISP}", JOURNAL = "SIGPLAN Notices", YEAR = 1969, VOLUME = 4, PAGES = "28-49", NOTE = "Reprinted in {SIGSAM} Bulletin, ACM, Vol. 13, 1969, p. 28-49"} @ARTICLE{PLC, AUTHOR="M. L. Griss and A. C. Hearn", TITLE = "A Portable {LISP} Compiler", JOURNAL=SPE, MONTH = "June", YEAR=1981, VOLUME=11, PAGES="541-605", ANNOTE="Also as UUCS-79-113, and UCP-76"} @MANUAL{CDC-LISP, KEY = "CDC", TITLE = "{LISP} Reference Manual, CDC-6000", AUTHOR = "Computation Center", ORGANIZATION= "The University of Texas at Austin"} @MANUAL{LISP/360, KEY = "LISP/360", TITLE = "{LISP/360} Reference Manual", AUTHOR = "Stanford Center for Information Processing", ORGANIZATION = "Stanford University"} @BOOK{LISP1.5, AUTHOR = "John McCarthy and Paul W. Abrahams and Daniel J. Edwards and Timothy P. Hart and Michael I. Levin", TITLE = "{LISP} 1.5 Programmers Manual", ORGANIZATION = "The Computation Center and Research Laboratory of Electronics, Massachusettes Institute of Technology", PUBLISHER = "The {M.I.T.} Press", ADDRESS = "Cambridge, Massachusettes", YEAR = 1965} @MANUAL{MACLISP, KEY = "MACLISP", TITLE = "{MACLISP} Reference Manual", MONTH = "March", YEAR = 1976} @MANUAL{LISPF1, AUTHOR = "Mats Nordstrom and Erik Sandewall and Diz Breslow", TITLE = "{LISP F1}: A {FORTRAN} Implementation of {LISP} 1.5", ORGANIZATION = "Uppsala University, Department of Computer Sciences"} @MANUAL{LISP1.6, AUTHOR = "Lynn H. Quam and Whitfield Diffie", TITLE = "Stanford {LISP} 1.6 Manual", ORGANIZATION = "Stanford Artificial Intelligence Laboratory", EDITION ="Operating Note 28.7"} @TECHREPORT{REDUCE3.3, AUTHOR = "A. C. Hearn", TITLE = "{REDUCE} User's Manual: Version 3.3", INSTITUTION = "{RAND}", TYPE = "Publication", NUMBER = "CP78 (Rev 1/88)", YEAR = 1988} @MANUAL{Interlisp, AUTHOR = "Warren Teitelman", TITLE = "{INTERLISP} Reference Manual", ORGANIZATION = "{XEROX}", ADDRESS = "Palo Alto Research Centers, 3333 Coyote Road, Palo Alto, California 94304", YEAR = 1978} |
Added r34.1/doc/sl.tex version [1b7e99234c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{The Standard Lisp Report} \date{} \author{Jed Marti \\ A. C. Hearn \\ M. L. Griss \\ C. Griss} %%% Function/method definition. %%% de{fname}{arglist}{type}{text} For short arg lists. %%% DE{fname}{arglist}{type}{text} For long arg lists. \newlength{\argwidth} % Width of argument box. \setlength{\argwidth}{4in} \newlength{\dewidth} \setlength{\dewidth}{4.5in} % Width of text box. \newcommand{\de}[4] {\vspace{.25in} \noindent \begin{minipage}[t]{\textwidth} \index{#1} {\f{#1}}{#2}\hfill{\em #3} \\ \hspace*{.25in}\begin{minipage}[t]{\dewidth} #4 \end{minipage} \end{minipage} } %%% Global/fluid variable description. %%% variable{name}{initial value}{type}{text} \newcommand{\variable}[4] {\vspace{.25in} \noindent \begin{minipage}[t]{\textwidth} \index{#1 (#3)} {\bf #1} = #2 \hfill {\em #3} \\ \hspace*{.25in} \ \begin{minipage}[t]{\dewidth} #4 \end{minipage} \end{minipage}} %%% Command to display an error or warning message in teletype format. Also %%% leaves blank vertical space around it. \newcommand{\errormessage}[1] {\vspace{.1in} \noindent {\tt #1} \\ \vspace{.1in}} %%% \p is a parameter name (or argument). Just do this as bf. \newcommand{\p}[1] {{\bf #1}} %%% \ty is a type - do as italics. \newcommand{\ty}[1] {{\em #1}} \begin{document} \maketitle \section{Introduction} Although the programming language LISP was first formulated in 1960~\cite{LISP1.5}, a widely accepted standard has never appeared. As a result, various dialects of LISP were produced~\cite{CDC-LISP,LISP/360,MACLISP,Interlisp,LISPF1,LISP1.6} in some cases several on the same machine! Consequently, a user often faces considerable difficulty in moving programs from one system to another. In addition, it is difficult to write and use programs which depend on the structure of the source code such as translators, editors and cross-reference programs. In 1969, a model for such a standard was produced~\cite{Hearn:69} as part of a general effort to make a large LISP based algebraic manipulation program, REDUCE~\cite{REDUCE3.3}, as portable as possible. The goal of this work was to define a uniform subset of LISP 1.5 and its variants so that programs written in this subset could run on any reasonable LISP system. In the intervening years, two deficiencies in the approach taken in Ref.~\cite{Hearn:69} have emerged. First in order to be as general as possible, the specific semantics and values of several key functions were left undefined. Consequently, programs built on this subset could not make any assumptions about the form of the values of such functions. The second deficiency related to the proposed method of implementation of this language. The model considered in effect two versions of LISP on any given machine, namely Standard LISP and the LISP of the host machine (which we shall refer to as Target LISP). This meant that if any definition was stored in interpretive form, it would vary from implementation to implementation, and consequently one could not write programs in Standard LISP which needed to assume any knowledge about the structure of such forms. This deficiency became apparent during recent work on the development of a portable compiler for LISP~\cite{PLC}. Clearly a compiler has to know precisely the structure of its source code; we concluded that the appropriate source was Standard LISP and not Target LISP. With these thoughts in mind we decided to attempt again a definition of Standard LISP. However, our approach this time is more aggressive. In this document we define a standard for a reasonably large subset of LISP with as precise as possible a statement about the semantics of each function. Secondly, we now require that the target machine interpreter be modified or written to support this standard, rather than mapping Standard LISP onto Target LISP as previously. We have spent countless hours in discussion over many of the definitions given in this report. We have also drawn on the help and advice of a lot of friends whose names are given in the Acknowledgements. Wherever possible, we have used the definition of a function as given in the LISP 1.5 Programmer's Manual~\cite{LISP1.5} and have only deviated where we felt it desirable in the light of LISP programming experience since that time. In particular, we have given considerable thought to the question of variable bindings and the definition of the evaluator functions EVAL and APPLY. We have also abandoned the previous definition of LISP arrays in favor of the more accepted idea of a vector which most modern LISP systems support. These are the places where we have strayed furthest from the conventional definitions, but we feel that the consistency which results from our approach is worth the redefinition. We have avoided entirely in this report problems which arise from environment passing, such as those represented by the FUNARG problem. We do not necessarily exclude these considerations from our standard, but in this report have decided to avoid the controversy which they create. The semantic differences between compiled and interpreted functions is the topic of another paper~\cite{PLC}. Only functions which affect the compiler in a general way make reference to it. This document is not intended as an introduction to LISP rather it is assumed that the reader is already familiar with some version. The document is thus intended as an arbiter of the syntax and semantics of Standard LISP. However, since it is not intended as an implementation description, we deliberately leave unspecified many of the details on which an actual implementation depends. For example, while we assume the existence of a symbol table for atoms (the "object list" in LISP terminology), we do not specify its structure, since conventional LISP programming does not require this information. Our ultimate goal, however, is to remedy this by defining an interpreter for Standard LISP which is sufficiently complete that its implementation on any given computer will be straightforward and precise. At that time, we shall produce an implementation level specification for Standard LISP which will extend the description of the primitive functions defined herein by introducing a new set of lower level primitive functions in which the structure of the symbol table, heap and so on may be defined. The plan of this chapter is as follows. In Section~\ref{dtypes} we describe the various data types used in Standard LISP. In Section~\ref{slfns}, a description of all Standard LISP functions is presented, organized by type. These functions are defined in an RLISP syntax which is easier to read than LISP S-expressions. Section~\ref{slglobals} describes global variables which control the operation of Standard LISP. \section{Preliminaries} \label{dtypes} \subsection{Primitive Data Types} \label{pdat} \begin{description} \item[integer] Integers are also called "fixed" numbers. The magnitude of an integer is unrestricted. Integers in the LISP input stream are \index{integer ! input} \index{integer ! magnitude} recognized by the grammar: \begin{tabbing} \s{digit} ::= 0$\mid$1$\mid$2$\mid$3$\mid$4$\mid$5$\mid$6$\mid$7$\mid$8$\mid$9 \\ \s{unsigned-integer} ::= \s{digit}$\mid$\s{unsigned-integer}\s{digit} \\ \s{integer} ::= \= \s{unsigned-integer} $\mid$ \\ \> +\s{unsigned-integer} $\mid$ \\ \> ---\s{unsigned-integer} \end{tabbing} \item[floating] - Any floating point number. The precision of floating point \index{floating ! input} numbers is determined solely by the implementation. In BNF floating point numbers are recognized by the grammar: \begin{tabbing} \s{base} ::= \= \s{unsigned-integer}.$\mid$.\s{unsigned-integer}$\mid$ \\ \> \s{unsigned-integer}.\s{unsigned-integer} \\ \> \s{unsigned-floating} ::= \s{base}$\mid$ \\ \> \s{base}E\s{unsigned-integer}$\mid$ \\ \> \s{base}E-\s{unsigned-integer}$\mid$ \\ \> \s{base}E+\s{unsigned-integer} \\ \s{floating} ::= \= \s{unsigned-floating}$\mid$ \\ \> +\s{unsigned-floating}$\mid$-\s{unsigned-floating} \end{tabbing} \item[id] An identifier is a string of characters which may have the \index{id ! input} \index{identifier (see id)} following items associated with it. \begin{description} \item[print name] \index{print name} The characters of the identifier. \item[flags] An identifier may be tagged with a flag. Access is by the FLAG, REMFLAG, and FLAGP functions defined in section~\ref{plist} on page~\pageref{plist}. \index{FLAG} \index{REMFLAG} \index{FLAGP} \item[properties] \index{properties} An identifier may have an indicator-value pair associated with it. Access is by the PUT, GET, and REMPROP functions defined in section~\ref{plist} on page~\pageref{plist}. \index{PUT} \index{GET} \index{REMPROP} \item[values/functions] An identifier may have a value associated with \index{values} \index{functions} it. Access to values is by SET and SETQ defined in \index{SET} \index{SETQ} section~\ref{varsandbinds} on page~\pageref{varsandbinds}. The method by which the value is attached to the identifier is known as the binding type, being one of LOCAL, GLOBAL, or FLUID. Access to the binding type is by the GLOBAL, GLOBALP, FLUID, FLUIDP, and UNFLUID functions. \index{GLOBAL} \index{GLOBALP} \index{FLUID} \index{FUIDP} \index{UNFLUID} An identifier may have a function or macro associated with it. Access is by the PUTD, GETD, and REMD functions (see ``Function Definition'', section~\ref{fdef}, on page~\pageref{fdef}). \index{PUTD} \index{GETD} \index{REMD} An identifier may not have both a function and a value associated with it. \item[OBLIST entry] \index{OBLIST entry} An identifier may be entered and removed from a structure called the OBLIST. Its presence on the OBLIST does not directly affect the other properties. Access to the OBLIST is by the INTERN, REMOB, and READ functions. \index{INTERN} \index{REMOB} \index{READ} \end{description} The maximum length of a Standard LISP identifier is 24 characters \index{id ! maximum length} (excluding occurrences of the escape character !) but an \index{id ! escape character} implementation may allow more. Special characters (digits in the first position and punctuation) must be prefixed with an escape character, an ! in Standard LISP. In BNF identifiers are recognized by the grammar: \begin{tabbing} \s{special-character} ::= !\s{any-character} \\ \s{alphabetic} ::= \\ \hspace*{.25in} \= A$\mid$B$\mid$C$\mid$D$\mid$E$\mid$F$\mid$G$\mid$H$ \mid$I$\mid$J$\mid$K$\mid$L$\mid$M$\mid$N$\mid$O$\mid$P$\mid$Q$\mid$R$ \mid$S$\mid$T$\mid$U$\mid$V$\mid$W$\mid$X$\mid$Y$\mid$Z$\mid$ \\ \> a$\mid$b$\mid$c$\mid$d$\mid$e$\mid$f$\mid$g$\mid$h$\mid$i$\mid$j$ \mid$k$\mid$l$\mid$m$\mid$n$\mid$o$\mid$p$\mid$q$\mid$r$\mid$s$\mid$t$ \mid$u$\mid$v$\mid$w$\mid$x$\mid$y$\mid$z \\ \s{lead-character} ::= \s{special-character}$\mid$\s{alphabetic} \\ \s{regular-character} ::= \s{lead-character}$\mid$\s{digit} \\ \s{last-part} ::= \= \s{regular-character} $\mid$ \\ \> \s{last-part}\s{regular-character} \\ \s{id} ::= \s{lead-character}$\mid$\s{lead-character}\s{last-part} \end{tabbing} Note: Using lower case letters in identifiers may cause portability problems. Lower case letters are automatically converted to upper case when the !*RAISE flag is T. \index{*RAISE (global)} \item[string] \index{string} A set of characters enclosed in double quotes as in "THIS IS A STRING". A quote is included by doubling it as in "HE SAID, ""LISP""". The maximum size of strings is 80 characters but an implementation may allow more. Strings are not part of the OBLIST and are considered constants like numbers, vectors, and function-pointers. \item[dotted-pair] A primitive structure which has a left and right part. \index{dotted-pair} \index{dot-notation} A notation called {\em dot-notation} is used for dotted pairs and takes the form: \begin{tabbing} (\s{left-part} . \s{right-part}) \end{tabbing} The \s{left-part} is known as the CAR portion and the \s{right-part} as the CDR portion. The left and right parts may be of any type. Spaces are used to resolve ambiguity with floating point numbers. \item[vector] \index{vector} A primitive uniform structure in which an integer index is used to access random values in the structure. The individual elements of a vector may be of any type. Access to vectors is restricted to functions defined in ``Vectors'' section~\ref{vectors} on page~\pageref{vectors}. A notation for vectors, {\em vector-notation}, has the elements of a vector surrounded \index{vector-notation} by square brackets\footnote{Vector elements are not separated by commas as in the published version of this document.} \begin{tabbing} \s{elements} ::= \s{any}$\mid$\s{any} \s{elements} \\ \s{vector} ::= [\s{elements}] \end{tabbing} \item[function-pointer] \index{function-pointer} An implementation may have functions which deal with specific data types other than those listed. The use of these entities is to be avoided with the exception of a restricted use of the function-pointer, an access method to compiled EXPRs and FEXPRs. A particular function-pointer must remain valid \index{EXPR} \index{FEXPR} throughout execution. Systems which change the location of a function must use either an indirect reference or change all occurrences of the associated value. There are two classes of use of function-pointers, those which are supported by Standard LISP but are not well defined, and those which are well defined. \begin{description} \item[Not well defined] Function pointers may be displayed by the print functions or expanded by EXPLODE. \index{EXPLODE} The value appears in the convention of the implementation site. The value is not defined in Standard LISP. Function pointers may be created by COMPRESS \index{COMPRESS} in the format used for printing but the value used is not defined in Standard LISP. Function pointers may be created by functions which deal with compiled function loading. Again, the values created are not well defined in Standard LISP. \item[Well defined] The function pointer associated with an EXPR or FEXPR may be retrieved by GETD \index{GETD} and is valid as long as Standard LISP is in execution. Function pointers may be stored using \index{PUTD} \index{PUT} \index{SETQ} PUTD, PUT, SETQ and the like or by being bound to variables. Function pointers may be checked for equivalence by EQ. \index{EQ ! of function-pointers} The value may be checked for being a function pointer by the CODEP function. \index{CODEP} \end{description} \end{description} \subsection{Classes of Primitive Data Types} \label{pclasses} The classes of primitive types are a notational convenience for describing the properties of functions. \begin{description} \item[boolean] \index{boolean} The set of global variables \{T,NIL\}, or their respective values, \{T, NIL\}. \index{T (global)} \index{NIL (global)} \item[extra-boolean] \index{extra-boolean} Any value in the system. Anything that is not NIL \index{NIL (global)} has the boolean interpretation T. \index{T (global)} \item[ftype] \index{ftype} The class of definable function types. The set of ids \{EXPR, FEXPR, MACRO\}. \index{EXPR} \index{FEXPR} \index{MACRO} \item[number] \index{number} The set of \{integer, floating\}. \item[constant] \index{constant} The set of \{integer, floating, string, vector, function-pointer\}. Constants evaluate to themselves (see the definition of EVAL in ``The Interpreter'', section~\ref{interpreter} on page~\pageref{interpreter}). \index{EVAL ! of constants} \item[any] \index{any} The set of \{integer, floating, string, id, dotted-pair, vector, function-pointer\}. An S-expression is another term for any. All Standard LISP entities have some value unless an ERROR occurs during evaluation or the function causes transfer of control (such as GO and RETURN). \item[atom] \index{atom} The set \{any\}-\{dotted-pair\}. \end{description} \subsection{Structures} \index{data structures} \index{structures} Structures are entities created out of the primitive types by the use of dotted-pairs. Lists are structures very commonly required as actual parameters to functions. Where a list of homogeneous entities is required by a function this class will be denoted by \s{{\bf xxx}-list} where {\bf \em xxx} is the name of a class of primitives or structures. Thus a list of ids is an {\em id-list}, a list of integers an {\em integer-list} and so on. \index{id-list} \index{integer-list} \index{-list} \begin{description} \item[list] \index{list} A list is recursively defined as NIL or the \index{list-notation} \index{NIL (global)} dotted-pair (any~.~list). A special notation called {\em list-notation} is used to represent lists. List-notation eliminates extra parentheses and dots. The list (a . (b . (c . NIL))) in list notation is (a b c). \index{dot-notation} List-notation and dot-notation may be mixed as in (a b . c) or (a (b . c) d) which are (a . (b . c)) and (a . ((b . c) . (d . NIL))). In BNF lists are recognized by the grammar: \begin{tabbing} \s{left-part} ::= ( $\mid$ \s{left-part} \s{any} \\ \s{list} ::= \s{left-part}) $\mid$ \s{left-part} . \s{any}) \end{tabbing} Note: () is an alternate input representation of NIL. \index{()} \item[alist] \index{alist} An association list; each element of the list is a dotted-pair, the CAR part being a key associated with the value in the CDR part. \index{association list} \item[cond-form] \index{cond-form} A cond-form is a list of 2 element lists of the form: (\p{ANTECEDENT}:{\em any} \p{CONSEQUENT}:{\em any}) The first element will henceforth be known as the antecedent and \index{antecedent (cond-form)} \index{consequent (cond-form)} the second as the consequent. The antecedent must have a value. The consequent may have a value or an occurrence of GO or RETURN \index{GO} \index{RETURN} as described in the ``Program Feature Functions'', section~\ref{prog} on page~\pageref{prog}. \item[lambda] \index{LAMBDA} A LAMBDA expression which must have the form (in list notation): (LAMBDA parameters body). ``parameters'' is a list of formal parameters for ``body'' an S-expression to be evaluated. The semantics of the evaluation are defined with the EVAL function (see ``The Interpreter'', section~\ref{interpreter} on \index{EVAL ! lambda expressions} page~\pageref{interpreter}). \index{lambda expression} \item[function] \index{function} A LAMBDA expression or a function-pointer to a function. A function is always evaluated as an EVAL, SPREAD form. \index{EVAL ! function} \end{description} \subsection{Function Descriptions} Each function is provided with a prototypical header line. Each formal parameter is given a name and suffixed with its allowed type. Lower case, italic tokens are names of classes and upper case, bold face, tokens are parameter names referred to in the definition. The type of the value returned by the function (if any) is suffixed to the parameter list. If it is not commonly used the parameter type may be a specific set enclosed in brackets \{\ldots\}. \index{\{\ldots\} ! as syntax} For example: \vspace{.1in} \noindent \f{PUTD}(\p{FNAME}:\ty{id}, \p{TYPE}:\ty{ftype}, \p{BODY}:\{\ty{lambda, function-pointer}\}):\ty{id} \vspace{.1in} PUTD is a function with three parameters. The parameter FNAME is an id to be the name of the function being defined. TYPE is the type of the function being defined and BODY is a lambda expression or a function-pointer. PUTD returns the name of the function being defined. Functions which accept formal parameter lists of arbitrary length have the type class and parameter enclosed in square brackets indicating that zero or more occurrences of that argument are permitted. \index{[\ldots] syntax} For example: \vspace{.1in} \noindent \f{AND}([\p{U}:\ty{any}]):\ty{extra-boolean} \vspace{.1in} AND is a function which accepts zero or more arguments which may be of any type. \subsection{Function Types} EVAL type functions are those which are invoked with evaluated \index{EVAL ! function type} arguments. NOEVAL functions are invoked with unevaluated arguments. \index{NOEVAL ! function type} SPREAD type functions have their arguments passed in one-to-one \index{SPREAD ! function type} correspondence with their formal parameters. NOSPREAD functions \index{NOSPREAD ! function type} receive their arguments as a single list. EVAL, SPREAD functions are \index{FEXPR} associated with EXPRs and NO\-EVAL, NO\-SPREAD functions with FEXPRs. EVAL, NO\-SPREAD and NOEVAL, SPREAD functions can be simulated using NOEVAL, NO\-SPREAD functions or MACROs. \index{MACRO} EVAL, SPREAD type functions may have a maximum of 15 parameters. \index{formal parameter limit} There is no limit on the number of parameters a NOEVAL, NOSPREAD function or MACRO may have. In the context of the description of an EVAL, SPREAD function, then we speak of the formal parameters we mean their actual values. However, in a NOEVAL, NOSPREAD function it is the unevaluated actual parameters. A third function type, the MACRO, implements functions which \index{MACRO} create S-expressions based on actual parameters. When a macro invocation is encountered, the body of the macro, a lambda expression, is invoked as a NOEVAL, NOSPREAD function with the macro's invocation bound as a list to the macros single formal parameter. When the macro has been evaluated the resulting S-expression is reevaluated. The description of the EVAL and EXPAND \index{EVAL ! MACRO functions} functions provide precise details. \subsection{Error and Warning Messages} \index{error messages} Many functions detect errors. The description of such functions will include these error conditions and suggested formats for display \index{ERROR} of the generated error messages. A call on the ERROR function is implied but the error number is not specified by Standard LISP. In some cases a warning message is sufficient. To distinguish between \index{warning messages} \index{***** (error message)} \index{*** (warning message)} errors and warnings, errors are prefixed with five asterisks and warnings with only three. Primitive functions check arguments that must be of a certain primitive type for being of that type and display an error message if the argument is not correct. The type mismatch error always takes the form: \index{error ! type mismatch error} \errormessage{***** PARAMETER not TYPE for FN} Here PARAMETER is the unacceptable actual parameter, TYPE is the type that PARAMETER was supposed to be. FN is the name of the function that detected the error. \subsection{Comments} \index{comments} \index{\%} The character \% signals the start of a comment, text to be ignored during parsing. A comment is terminated by the end of the line it \index{READCH} \index{READ} is on. The function READCH must be able to read a comment one character at a time. Comments are transparent to the function READ. \% may occur as a character in identifiers by preceding it with the \index{escape character} escape character !. \section{Functions} \label{slfns} \subsection{Elementary Predicates} \label{elpreds} \index{predicate !} \index{T (global)} \index{NIL (global)} Functions in this section return T when the condition defined is met and NIL when it is not. Defined are type checking functions and elementary comparisons. \de{ATOM}{(\p{U}:\ty{any}):{\ty boolean}}{eval, spread} {Returns T if U is not a pair. {\tt \begin{tabbing} EXPR PROCEDURE ATOM(U); \\ \hspace*{1em} NULL PAIRP U; \end{tabbing}}} \de{CODEP}{(\p{U}:\f{any}):{\ty boolean}}{eval, spread} {Returns T if U is a function-pointer.} \de{CONSTANTP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a constant (a number, string, function-pointer, or vector). {\tt \begin{tabbing} EXPR PROCEDURE CONSTANTP(U); \\ \hspace*{1em} NULL OR(PAIRP U, IDP U); \end{tabbing}} } \de{EQ}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U points to the same object as V. EQ is \underline{not} a reliable comparison between numeric arguments. } \de{EQN}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U and V are EQ or if U and V are numbers and have the same value and type. } \de{EQUAL}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U and V are the same. Dotted-pairs are compared recursively to the bottom levels of their trees. Vectors must have identical dimensions and EQUAL values in all positions. Strings must \index{EQ ! of function-pointers} \index{EQN} have identical characters. Function pointers must have EQ values. Other atoms must be EQN equal. } \de{FIXP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is an integer (a fixed number).} \de{FLOATP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a floating point number. } \de{IDP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is an id.} \de{MINUSP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a number and less than 0. If U is not a number or is a positive number, NIL is returned. {\tt \begin{tabbing} EXPR PROCEDURE MINUSP(U); \\ \hspace*{1em} IF NUMBERP U THEN LESSP(U, 0) ELSE NIL; \end{tabbing}}} \de{NULL}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is NIL. {\tt \begin{tabbing} EXPR PROCEDURE NULL(U); \\ \hspace*{1em} U EQ NIL; \end{tabbing}}} \de{NUMBERP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a number (integer or floating). {\tt \begin{tabbing} EXPR PROCEDURE NUMBERP(U); \\ \hspace*{1em} IF OR(FIXP U, FLOATP U) THEN T ELSE NIL; \end{tabbing}}} \de{ONEP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread.} {Returns T if U is a number and has the value 1 or 1.0. Returns NIL otherwise. \footnote{The definition in the published report is incorrect as it does not return T for \p{U} of 1.0.} {\tt \begin{tabbing} EXPR PROCEDURE ONEP(U); \\ \hspace*{1em} OR(EQN(U, 1), EQN(U, 1.0)); \end{tabbing}}} \de{PAIRP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a dotted-pair. } \de{STRINGP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a string. } \de{VECTORP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a vector. } \de{ZEROP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread.} {Returns T if U is a number and has the value 0 or 0.0. Returns NIL otherwise.\footnote{The definition in the published report is incorrect as it does not return T for \p{U} of 0.0.} {\tt \begin{tabbing} EXPR PROCEDURE ZEROP(U); \\ \hspace*{1em} OR(EQN(U, 0), EQN(U, 0.0)); \end{tabbing}}} \subsection{Functions on Dotted-Pairs} \index{dotted-pair} The following are elementary functions on dotted-pairs. All functions in this section which require dotted-pairs as parameters detect a type mismatch error if the actual parameter is not a dotted-pair. \de{CAR}{(\p{U}:\ty{dotted-pair}):\ty{any}}{eval, spread} {CAR(CONS(a, b)) $\rightarrow$ a. The left part of U is returned. The type \index{CONS} mismatch error occurs if U is not a dotted-pair.} \de{CDR}{(\p{U}:\ty{dotted-pair}):\ty{any}}{eval, spread} {CDR(CONS(a, b)) $\rightarrow$ b. The right part of U is returned. The type \index{CONS} mismatch error occurs if U is not a dotted-pair.} The composites of CAR and CDR are supported up to 4 levels, namely: \index{CAR ! composite forms} \index{CDR ! composite forms} \hspace*{1in}\begin{tabular}{l l l} CAAAAR & CAAAR & CAAR \\ CAAADR & CAADR & CADR \\ CAADAR & CADAR & CDAR \\ CAADDR & CADDR & CDDR \\ CADAAR & CDAAR & \\ CADADR & CDADR & \\ CADDAR & CDDAR & \\ CADDDR & CDDDR & \\ CDAAAR & & \\ CDAADR & & \\ CDADAR & & \\ CDADDR & & \\ CDDAAR & & \\ CDDADR & & \\ CDDDAR & & \\ CDDDDR & & \end{tabular} \de{CONS}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{dotted-pair}}{eval, spread} {Returns a dotted-pair which is not EQ to anything and has U as its \index{EQ ! of dotted-pairs} \index{dotted-pair} CAR part and V as its CDR part.} \de{LIST}{([\p{U}:\ty{any}]):\ty{list}}{noeval, nospread, or macro} {A list of the evaluation of each element of U is returned. The order of evaluation need not be first to last as the following definition implies.\footnote{The published report's definition implies a specific ordering.} {\tt \begin{tabbing} FEXPR PROCEDURE LIST(U); \\ \hspace*{1em} EVLIS U; \end{tabbing}}} \de{RPLACA}{(\p{U}:\ty{dotted-pair}, \p{V}:\ty{any}):\ty{dotted-pair}}{eval, spread} {The CAR portion of the dotted-pair U is replaced by V. If dotted-pair U is (a . b) then (V . b) is returned. The type mismatch error occurs if U is not a dotted-pair. } \de{RPLACD}{(\p{U}:\ty{dotted-pair}, \p{V}:\ty{any}):\ty{dotted-pair}}{eval, spread} {The CDR portion of the dotted-pair U is replaced by V. If dotted-pair U is (a . b) then (a . V) is returned. The type mismatch error occurs if U is not a dotted-pair.} \subsection{Identifiers} \label{identifiers} The following functions deal with identifiers and the OBLIST, \index{OBLIST} the structure of which is not defined. The function of the OBLIST is to provide a symbol table for identifiers created during input. Identifiers created by READ which have the same characters will \index{READ} \index{EQ ! of identifiers} therefore refer to the same object (see the EQ function in ``Elementary Predicates'', section~\ref{elpreds} on page~\pageref{elpreds}). \de{COMPRESS}{(\p{U}:\ty{id-list}):\{\ty{atom}-\ty{vector}\}}{eval, spread} {U is a list of single character identifiers which is built into a Standard LISP entity and returned. Recognized are numbers, strings, and identifiers with the escape character prefixing special characters. The formats of these items appear in ``Primitive Data Types'' section~\ref{pdat} on page~\pageref{pdat}. Identifiers are not interned on the OBLIST. Function pointers may be compressed but this is an undefined use. If an entity cannot be parsed out of U or characters are left over after parsing an error occurs: \errormessage{***** Poorly formed atom in COMPRESS} } \de{EXPLODE}{(\p{U}:\{\ty{atom}\}-\{\ty{vector}\}):\ty{id-list}}{eval, spread} {Returned is a list of interned characters representing the characters to print of the value of U. The primitive data types have these formats: \begin{description} \item[integer] \index{integer ! output} Leading zeroes are suppressed and a minus sign prefixes the digits if the integer is negative. \item[floating] \index{floating ! output} The value appears in the format [-]0.nn...nnE[-]mm if the magnitude of the number is too large or small to display in [-]nnnn.nnnn format. The crossover point is determined by the implementation. \item[id] \index{id ! output} The characters of the print name of the identifier are produced with special characters prefixed with the escape character. \item[string] \index{string ! output} The characters of the string are produced surrounded by double quotes "\ldots". \item[function-pointer] \index{function-pointer ! output} The value of the function-pointer is created as a list of characters conforming to the conventions of the system site. \end{description} The type mismatch error occurs if U is not a number, identifier, string, or function-pointer. } \de{GENSYM}{():\ty{identifier}}{eval, spread} {Creates an identifier which is not interned on the OBLIST and consequently not EQ to anything else. \index{OBLIST entry} \index{EQ ! of GENSYMs}} \de{INTERN}{(\p{U}:\{\ty{id,string}\}):\ty{id}}{eval, spread} {INTERN searches the OBLIST for an identifier with the same print name \index{OBLIST entry} as U and returns the identifier on the OBLIST if a match is found. Any properties and global values associated with U may be lost. If U does not match any entry, a new one is created and returned. If U has more than the maximum number of characters permitted by the implementation (the minimum number is 24) an error occurs: \index{id ! minimum size} \errormessage{***** Too many characters to INTERN} } \de{REMOB}{(\p{U}:\ty{id}):\ty{id}}{eval, spread} {If U is present on the OBLIST it is removed. This does not affect U \index{OBLIST entry} having properties, flags, functions and the like. U is returned.} \subsection{Property List Functions} \label{plist} \index{property list} With each id in the system is a ``property list'', a set of entities which are associated with the id for fast access. These entities are called ``flags'' if their use gives the id a single valued \index{flags} property, and ``properties'' if the id is to have a multivalued \index{properties} attribute: an indicator with a property. Flags and indicators may clash, consequently care should be taken to avoid this occurrence. Flagging X with an id which already is an indicator for X may result in that indicator and associated property being lost. Likewise, adding an indicator which is the same id as a flag may result in the flag being destroyed. \de{FLAG}{(\p{U}:\ty{id-list}, \p{V}:\ty{id}):\ty{NIL}}{eval, spread} {U is a list of ids which are flagged with V. The effect of FLAG is that FLAGP will have the value T for those ids of U which were flagged. Both V and all the elements of U must be identifiers or the type mismatch error occurs.} \de{FLAGP}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U has been previously flagged with V, else NIL. Returns NIL if either U or V is not an id.} \de{GET}{(\p{U}:\ty{any}, \p{IND}:\ty{any}):\ty{any}}{eval, spread} {Returns the property associated with indicator IND from the property list of U. If U does not have indicator IND, NIL is returned. GET cannot be used to access functions (use GETD instead). \index{GET ! not for functions}} \de{PUT}{(\p{U}:\ty{id}, \p{IND}:\ty{id}, \p{PROP}:\ty{any}):\ty{any}}{eval, spread} {The indicator IND with the property PROP is placed on the property list of the id U. If the action of PUT occurs, the value of PROP is returned. If either of U and IND are not ids the type mismatch error will occur and no property will be placed. PUT cannot be used to define functions (use PUTD instead). \index{PUT ! not for functions}} \de{REMFLAG}{(\p{U}:\ty{any-list}, \p{V}:\ty{id}):\ty{NIL}}{eval, spread} {Removes the flag V from the property list of each member of the list U. Both V and all the elements of U must be ids or the type mismatch error will occur.} \de{REMPROP}{(\p{U}:\ty{any}, \p{IND}:\ty{any}):\ty{any}}{eval, spread} {Removes the property with indicator IND from the property list of U. Returns the removed property or NIL if there was no such indicator.} \subsection{Function Definition} \label{fdef} Functions in Standard LISP are global entities. To avoid function-variable naming clashes no variable may have the same name as a function. \index{function ! as GLOBAL} \de{DE}{(\p{FNAME}:\ty{id}, \p{PARAMS}:\ty{id-list}, \p{FN}:\ty{any}):\ty{id}}{noeval, nospread} {The function FN with the formal parameter list PARAMS is added to the set of defined functions with the name FNAME. Any previous definitions of the function are lost. The function created is of type \index{*COMP (fluid)} EXPR. If the !*COMP variable is non-NIL, the EXPR is first \index{EXPR} compiled. The name of the defined function is returned. {\tt \begin{tabbing} FEXPR PROCEDURE DE(U); \\ \hspace*{1em} PUTD(CAR U, 'EXPR, LIST('LAMBDA, CADR U, CADDR U)); \end{tabbing}}} \de{DF}{(\p{FNAME}:\ty{id}, \p{PARAM}:\ty{id-list}, \p{FN}:\ty{any}):\ty{id}}{noeval, nospread} {The function FN with formal parameter PARAM is added to the set of defined functions with the name FNAME. Any previous definitions of the function are lost. The function created is of type FEXPR. \index{*COMP variable} \index{FEXPR} If the !*COMP variable is T the FEXPR is first compiled. The name of the defined function is returned. {\tt \begin{tabbing} FEXPR PROCEDURE DF(U); \\ \hspace*{1em} PUTD(CAR U, 'FEXPR, LIST('LAMBDA, CADR U, CADDR U)); \\ \end{tabbing} }} \de{DM}{(\p{MNAME}:\ty{id}, \p{PARAM}:\ty{id-list}, \p{FN}:\ty{any}):\ty{id}}{noeval, nospread} {The macro FN with the formal parameter PARAM is added to the set of defined functions with the name MNAME. Any previous definitions of the function are overwritten. The function created is of type MACRO. \index{MACRO} The name of the macro is returned. {\tt \begin{tabbing} FEXPR PROCEDURE DM(U); \\ \hspace*{1em} PUTD(CAR U, 'MACRO, LIST('LAMBDA, CADR U, CADDR U)); \end{tabbing} } } \de{GETD}{(\p{FNAME}:\ty{any}):\{NIL, \ty{dotted-pair}\}}{eval, spread} {If FNAME is not the name of a defined function, NIL is returned. If FNAME is a defined function then the dotted-pair \vspace{.15in} (\p{TYPE}:\ty{ftype} . \p{DEF}:\{\ty{function-pointer, lambda}\}) \vspace{.15in} is returned.} \de{PUTD}{(\p{FNAME}:\ty{id}, \p{TYPE}:\ty{ftype}, \p{BODY}:\ty{function}):\ty{id}}{eval, spread} {Creates a function with name FNAME and definition BODY of type TYPE. If PUTD succeeds the name of the defined function is returned. The effect of PUTD is that GETD will return a dotted-pair with the functions type and definition. Likewise the GLOBALP predicate will \index{GLOBALP} \index{function ! as global} return T when queried with the function name. If the function FNAME has already been declared as a GLOBAL or FLUID variable the error: \errormessage{***** FNAME is a non-local variable} occurs and the function will not be defined. If function FNAME already exists a warning message will appear: \errormessage{*** FNAME redefined} The function defined by PUTD will be compiled before definition \index{*COMP (fluid)} if the !*COMP global variable is non-NIL.} \de{REMD}{(\p{FNAME}:\ty{id}):\{NIL, \ty{dotted-pair}\}}{eval, spread} {Removes the function named FNAME from the set of defined functions. Returns the (ftype . function) dotted-pair or NIL as does GETD. The global/function attribute of FNAME is removed and the name may be used subsequently as a variable.} \subsection{Variables and Bindings} \label{varsandbinds} \index{variable scope} \index{scope} A variable is a place holder for a Standard LISP entity which is said to be bound to the variable. The scope of a variable is the range over which the variable has a defined value. There are three different binding mechanisms in Standard LISP. \begin{description} \item[Local Binding] \index{local binding} This type of binding occurs \index{scope ! local} only in compiled functions. Local variables occur as formal parameters in lambda expressions and as PROG form variables. The binding occurs when a lambda expression is evaluated or when a PROG form is executed. The scope of a local variable is the body of the function in which it is defined. \item[Global Binding] \index{global binding} Only one binding of a \index{scope ! global} global variable exists at any time allowing direct access to the value bound to the variable. The scope of a global variable is universal. Variables declared GLOBAL may not appear as parameters in lambda expressions or as PROG form variables. A variable must be declared GLOBAL prior to its use as a global variable since the default type for undeclared variables is FLUID. \item[Fluid Binding] \index{fluid binding} \index{fluid binding ! as default} Fluid variables are global in scope but may occur as \index{scope ! fluid} formal parameters or PROG form variables. In interpreted functions all formal parameters and PROG form variables are considered to have fluid binding until changed to local binding by compilation. When fluid variables are used as parameters they are rebound in such a way that the previous binding may be restored. All references to fluid variables are to the currently active binding. \end{description} \de{FLUID}{(\p{IDLIST}:\ty{id-list}):\p{NIL}}{eval, spread} {The ids in IDLIST are declared as FLUID type variables (ids not previously declared are initialized to NIL). Variables in IDLIST already declared FLUID are ignored. Changing a variable's type from GLOBAL to FLUID is not permissible and results in the error: \errormessage{***** ID cannot be changed to FLUID} } \de{FLUIDP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {If U has been declared FLUID (by declaration only) T is returned, otherwise NIL is returned.} \de{GLOBAL}{(\p{IDLIST}:\ty{id-list}):\p{NIL}}{eval, spread} {The ids of IDLIST are declared global type variables. If an id has not been declared previously it is initialized to NIL. Variables already declared GLOBAL are ignored. Changing a variables type from FLUID to GLOBAL is not permissible and results in the error: \errormessage{***** ID cannot be changed to GLOBAL} } \de{GLOBALP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {If U has been declared GLOBAL or is the name of a defined function, T is returned, else NIL is returned.} \de{SET}{(\p{EXP}:\ty{id}, \p{VALUE}:\ty{any}):\ty{any}}{eval, spread} {EXP must be an identifier or a type mismatch error occurs. The effect of SET is replacement of the item bound to the identifier by VALUE. If the identifier is not a local variable or has not been declared GLOBAL it is automatically declared FLUID with the resulting warning message: \errormessage{*** EXP declared FLUID} EXP must not evaluate to T or NIL or an error occurs: \index{T ! cannot be changed} \index{NIL ! cannot be changed} \errormessage{***** Cannot change T or NIL} } \de{SETQ}{(\p{VARIABLE}:\ty{id}, \p{VALUE}:\ty{any}):\ty{any}}{noeval, nospread} {If VARIABLE is not local or GLOBAL it is by default declared FLUID and the warning message: \errormessage{*** VARIABLE declared FLUID} appears. The value of the current binding of VARIABLE is replaced by the value of VALUE. VARIABLE must not be T or NIL or an error occurs: \index{T ! cannot be changed} \index{NIL ! cannot be changed} \errormessage{***** Cannot change T or NIL} {\tt \begin{tabbing} MACRO PROCEDURE SETQ(X); \\ \hspace*{1em} LIST('SET, LIST('QUOTE, CADR X), CADDR X); \end{tabbing}} } \de{UNFLUID}{(\p{IDLIST}:\ty{id-list}):\ty{NIL}}{eval, spread} {The variables in IDLIST that have been declared as FLUID variables are no longer considered as fluid variables. Others are ignored. This affects only compiled functions as free variables in interpreted functions are automatically considered fluid~\cite{PLC}. \index{scope ! fluid and compiled}} \subsection{Program Feature Functions} \label{prog} These functions provide for explicit control sequencing, and the definition of blocks altering the scope of local variables. \de{GO}{(\p{LABEL}:\ty{id})}{noeval, nospread} {GO alters the normal flow of control within a PROG function. The next statement of a PROG function to be evaluated is immediately preceded by LABEL. A GO may only appear in the following situations: \begin{enumerate} \item At the top level of a PROG referencing a label which also appears at the top level of the same PROG. \item As the consequent of a COND item of a COND appearing on the top level of a PROG. \index{GO ! in COND} \index{RETURN ! in COND} \item As the consequent of a COND item which appears as the consequent of a COND item to any level. \item As the last statement of a PROGN which appears at the top level of a PROG or in a PROGN appearing in the consequent of a COND to any level subject to the restrictions of 2 and 3. \item As the last statement of a PROGN within a PROGN or as the consequent of a COND in a PROGN to any level subject to the restrictions of 2, 3 and 4. \end{enumerate} If LABEL does not appear at the top level of the PROG in which the GO appears, an error occurs: \errormessage{***** LABEL is not a known label} If the GO has been placed in a position not defined by rules 1-5, another error is detected: \errormessage{***** Illegal use of GO to LABEL} } \de{PROG}{(\p{VARS}:\ty{id-list}, [\p{PROGRAM}:\{\ty{id, any}\}]):\ty{any}}{noeval, nospread} {VARS is a list of ids which are considered fluid when the PROG is interpreted and local when compiled (see ``Variables and Bindings'', section~\ref{varsandbinds} on page~\pageref{varsandbinds}). The PROGs variables are allocated space when the PROG form is invoked and are deallocated when the PROG is exited. PROG variables are initialized to \index{PROG ! variables} NIL. The PROGRAM is a set of expressions to be evaluated in order of their appearance in the PROG function. Identifiers appearing in the top level of the PROGRAM are labels which can be referenced by GO. The value returned by the PROG function is determined by a RETURN function \index{PROG ! default value} or NIL if the PROG ``falls through''.} \de{PROGN}{([\p{U}:\ty{any}]):\ty{any}}{noeval, nospread} {U is a set of expressions which are executed sequentially. The value returned is the value of the last expression.} \de{PROG2}{(A:any, B:any)\ty{any}}{eval, spread} {Returns the value of B. {\tt \begin{tabbing} EXPR PROCEDURE PROG2(A, B);\\ \hspace*{1em} B; \end{tabbing}}} \de{RETURN}{(\p{U}:\ty{any})}{eval, spread} {Within a PROG, RETURN terminates the evaluation of a PROG and returns U as the value of the PROG. The restrictions on the placement of RETURN are exactly those of GO. Improper placement of RETURN results in the error: \errormessage{***** Illegal use of RETURN} } \subsection{Error Handling} \label{errors} \de{ERROR}{(\p{NUMBER}:\ty{integer}, \p{MESSAGE}:\ty{any})}{eval, spread} {NUMBER and MESSAGE are passed back to a surrounding ERRORSET (the Standard LISP reader has an ERRORSET). MESSAGE is placed in the \index{EMSG* (global)} global variable EMSG!* and the error number becomes the value of the surrounding ERRORSET. FLUID variables and local bindings are unbound \index{fluid ! unbinding by ERROR} to return to the environment of the ERRORSET. Global variables are not affected by the process.} \de{ERRORSET}{(\p{U}:\ty{any}, \p{MSGP}:\ty{boolean}, \p{TR}:\ty{boolean}):\ty{any}}{eval, spread} {If an error occurs during the evaluation of U, the value of NUMBER from the ERROR call is returned as the value of ERRORSET. In addition, if the value of MSGP is non-NIL, the MESSAGE from the ERROR call is displayed upon both the standard output device and the currently selected output device unless the standard output device is not open. The message appears prefixed with 5 asterisks. The MESSAGE \index{***** (error message)} list is displayed without top level parentheses. The MESSAGE from the \index{EMSG* (global)} ERROR call will be available in the global variable EMSG!*. The exact format of error messages generated by Standard LISP functions described in this document are not fixed and should not be relied upon to be in any particular form. Likewise, error numbers generated by Standard LISP functions are implementation dependent. If no error occurs during the evaluation of U, the value of (LIST (EVAL U)) is returned. If an error has been signaled and the value of TR is non-NIL a traceback sequence will be initiated on the selected output device. The traceback will display information such as unbindings of FLUID \index{fluid ! in traceback} variables, argument lists and so on in an implementation dependent format.} \subsection{Vectors} \label{vectors} \index{vector} Vectors are structured entities in which random elements may be accessed with an integer index. A vector has a single dimension. Its maximum size is determined by the implementation and available space. A suggested input ``vector notation'' is defined in ``Classes of Primitive Data Types'', section~\ref{pclasses} on page~\pageref{pclasses} and output with EXPLODE, ``Identifiers'' section~\ref{identifiers} on page~\pageref{identifiers}. \index{EXPLODE} \de{GETV}{(\p{V}:\ty{vector}, \p{INDEX}:\ty{integer}):\ty{any}}{eval, spread} {Returns the value stored at position INDEX of the vector V. The type mismatch error may occur. An error occurs if the INDEX does not lie within 0\ldots UPBV(V) inclusive: \errormessage{***** INDEX subscript is out of range} } \de{MKVECT}{(\p{UPLIM}:\ty{integer}):\ty{vector}}{eval, spread} {Defines and allocates space for a vector with UPLIM+1 elements accessed as 0\ldots UPLIM. Each element is initialized to NIL. An error will occur if UPLIM is $<$ 0 or there is not enough space for a vector of this size: \errormessage{***** A vector of size UPLIM cannot be allocated} } \de{PUTV}{(\p{V}:\ty{vector}, \p{INDEX}:\ty{integer}, \p{VALUE}:\ty{any}):\ty{any}}{eval, spread} {Stores VALUE into the vector V at position INDEX. VALUE is returned. The type mismatch error may occur. If INDEX does not lie in 0\ldots UPBV(V) an error occurs: \errormessage{***** INDEX subscript is out of range} } \de{UPBV}{(\p{U}:\ty{any}):{NIL,\ty{integer}}}{eval, spread} {Returns the upper limit of U if U is a vector, or NIL if it is not.} \subsection{Boolean Functions and Conditionals} \de{AND}{([\p{U}:\ty{any}]):\ty{extra-boolean}}{noeval, nospread} {AND evaluates each U until a value of NIL is found or the end of the list is encountered. If a non-NIL value is the last value it is returned, or NIL is returned. {\tt \begin{tabbing} FEXPR PROCEDURE AND(U); \\ BEGIN \\ \hspace*{1em} IF NULL U THEN RETURN NIL; \\ LOOP: IF \= NULL CDR U THEN RETURN EVAL CAR U \\ \> ELSE IF NULL EVAL CAR U THEN RETURN NIL; \\ \hspace*{2em} \= U := CDR U; \\ \> GO LOOP \\ END; \end{tabbing} }} \de{COND}{([\p{U}:\ty{cond-form}]):\ty{any}}{noeval, nospread} {The antecedents of all U's are evaluated in order of their appearance until a non-NIL value is encountered. The consequent of the selected U is evaluated and becomes the value of the COND. The consequent may also contain the special functions GO and RETURN subject to the restraints given for these functions in ``Program Feature Functions'', section~\ref{prog} on page~\pageref{prog}. \index{GO ! in COND} \index{RETUNR ! in CODE} In these cases COND does not have a defined value, but rather an effect. If no antecedent is non-NIL the value of COND is NIL. An error is detected if a U is improperly formed: \errormessage{***** Improper cond-form as argument of COND} } \de{NOT}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {If U is NIL, return T else return NIL (same as function NULL). {\tt \begin{tabbing} EXPR PROCEDURE NOT(U); \\ \hspace*{1em} U EQ NIL; \end{tabbing}} } \de{OR}{([\p{U}:\ty{any}]):\ty{extra-boolean}}{noeval, nospread} {U is any number of expressions which are evaluated in order of their appearance. When one is found to be non-NIL it is returned as the value of OR. If all are NIL, NIL is returned. {\tt \begin{tabbing} FEXPR PROCEDURE OR(U); \\ BEGIN SCALAR X; \\ LOOP: IF \= NULL U THEN RETURN NIL \\ \> ELSE IF (X := EVAL CAR U) THEN RETURN X; \\ \hspace*{2em} \= U := CDR U; \\ \> GO LOOP \\ END; \end{tabbing} }} \subsection{Arithmetic Functions} Conversions between numeric types are provided explicitly by the \index{FIX} \index{FLOAT} FIX and FLOAT functions and implicitly by any multi-parameter \index{mixed-mode arithmetic} arithmetic function which receives mixed types of arguments. A conversion from fixed to floating point numbers may result in a loss of precision without a warning message being generated. Since \index{integer ! magnitude} integers may have a greater magnitude that that permitted for floating numbers, an error may be signaled when the attempted conversion cannot be done. Because the magnitude of integers is unlimited the conversion of a floating point number to a fixed number is always possible, the only loss of precision being the digits to the right of the decimal point which are truncated. If a function receives mixed types of arguments the general rule will have the fixed numbers converted to floating before arithmetic operations are performed. In all cases an error occurs if the parameter to an arithmetic function is not a number: \errormessage{***** XXX parameter to FUNCTION is not a number} XXX is the value of the parameter at fault and FUNCTION is the name of the function that detected the error. Exceptions to the rule are noted where they occur. \de{ABS}{(\p{U}:\ty{number}):\ty{number}}{eval, spread} {Returns the absolute value of its argument. {\tt \begin{tabbing} EXPR PROCEDURE ABS(U); \\ \hspace*{1em} IF LESSP(U, 0) THEN MINUS(U) ELSE U; \end{tabbing}}} \de{ADD1}{(\p{U}:\ty{number}):\ty{number}}{eval, spread} {Returns the value of U plus 1 of the same type as U (fixed or floating). {\tt \begin{tabbing} EXPR PROCEDURE ADD1(U); \\ % God knows why, but hspace* isn't accepted here. \hspace{1em} PLUS2(U, 1); \end{tabbing}} } \de{DIFFERENCE}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {The value U - V is returned.} \de{DIVIDE}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{dotted-pair}}{eval, spread} {The dotted-pair (quotient . remainder) is returned. The quotient part is computed the same as by QUOTIENT and the remainder the same as by REMAINDER. An error occurs if division by zero is attempted: \index{division by zero} \errormessage{***** Attempt to divide by 0 in DIVIDE} {\tt \begin{tabbing} EXPR PROCEDURE DIVIDE(U, V); \\ \hspace*{1em} (QUOTIENT(U, V) . REMAINDER(U, V)); \end{tabbing}}} \de{EXPT}{(\p{U}:\ty{number}, \p{V}:\ty{integer}):\ty{number}}{eval, spread} {Returns U raised to the V power. A floating point U to an integer power V does \underline{not} have V changed to a floating number before exponentiation.} \de{FIX}{(\p{U}:\ty{number}):\ty{integer}}{eval, spread} {Returns an integer which corresponds to the truncated value of U. The result of conversion must retain all significant portions of U. If U is an integer it is returned unchanged. } \de{FLOAT}{(\p{U}:\ty{number}):\ty{floating}}{eval, spread} {The floating point number corresponding to the value of the argument U is returned. Some of the least significant digits of an integer may be lost do to the implementation of floating point numbers. FLOAT of a floating point number returns the number unchanged. If U is too large to represent in floating point an error occurs: \errormessage{***** Argument to FLOAT is too large} } \de{GREATERP}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{boolean}}{eval, spread} {Returns T if U is strictly greater than V, otherwise returns NIL.} \de{LESSP}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{boolean}}{eval, spread} {Returns T if U is strictly less than V, otherwise returns NIL. } \de{MAX}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro} {Returns the largest of the values in U. If two or more values are the same the first is returned. {\tt \begin{tabbing} MACRO PROCEDURE MAX(U); \\ \hspace*{1em} EXPAND(CDR U, 'MAX2); \end{tabbing}}} \de{MAX2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {Returns the larger of U and V. If U and V are the same value U is returned (U and V might be of different types). {\tt \begin{tabbing} EXPR PROCEDURE MAX2(U, V); \\ \hspace*{1em} IF LESSP(U, V) THEN V ELSE U; \end{tabbing}}} \de{MIN}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro} {Returns the smallest of the values in U. If two or more values are the same the first of these is returned. {\tt \begin{tabbing} MACRO PROCEDURE MIN(U); \\ \hspace*{1em} EXPAND(CDR U, 'MIN2); \end{tabbing}}} \de{MIN2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {Returns the smaller of its arguments. If U and V are the same value, U is returned (U and V might be of different types). {\tt \begin{tabbing} EXPR PROCEDURE MIN2(U, V); \\ \hspace*{1em} IF GREATERP(U, V) THEN V ELSE U; \end{tabbing}}} \de{MINUS}{(\p{U}:\ty{number}):\ty{number}}{eval, spread} {Returns -U. {\tt \begin{tabbing} EXPR PROCEDURE MINUS(U); \\ \hspace*{1em} DIFFERENCE(0, U); \end{tabbing}}} \de{PLUS}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro} {Forms the sum of all its arguments. {\tt \begin{tabbing} MACRO PROCEDURE PLUS(U); \\ \hspace*{1em} EXPAND(CDR U, 'PLUS2); \end{tabbing}}} \de{PLUS2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {Returns the sum of U and V.} \de{QUOTIENT}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {The quotient of U divided by V is returned. Division of two positive or two negative integers is conventional. When both U and V are integers and exactly one of them is negative the value returned is the negative truncation of the absolute value of U divided by the absolute value of V. An error occurs if division by zero is attempted: \index{division by zero} \errormessage{***** Attempt to divide by 0 in QUOTIENT} } \de{REMAINDER}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {If both U and V are integers the result is the integer remainder of U divided by V. If either parameter is floating point, the result is the difference between U and V*(U/V) all in floating point. If either number is negative the remainder is negative. If both are positive or both are negative the remainder is positive. An error occurs if V is zero: \index{division by zero} \errormessage{***** Attempt to divide by 0 in REMAINDER} {\tt \begin{tabbing} EXPR PROCEDURE REMAINDER(U, V); \\ \hspace*{1em} DIFFERENCE(U, TIMES2(QUOTIENT(U, V), V)); \end{tabbing}}} \de{SUB1}{(\p{U}:\ty{number}):\ty{number}}{eval, spread} {Returns the value of U less 1. If U is a FLOAT type number, the value returned is U less 1.0. {\tt \begin{tabbing} EXPR PROCEDURE SUB1(U); \\ \hspace*{1em} DIFFERENCE(U, 1); \end{tabbing}}} \de{TIMES}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro} {Returns the product of all its arguments. {\tt \begin{tabbing} MACRO PROCEDURE TIMES(U); \\ \hspace*{1em} EXPAND(CDR U, 'TIMES2); \end{tabbing}}} \de{TIMES2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread} {Returns the product of U and V.} \subsection{MAP Composite Functions} \de{MAP}{(\p{X}:\ty{list}, F\p{N}:\ty{function}):\ty{any}}{eval, spread} {Applies FN to successive CDR segments of X. NIL is returned. {\tt \begin{tabbing} EXPR PROCEDURE MAP(X, FN); \\ \hspace*{1em} WHILE X DO $<<$ FN X; X := CDR X $>>$; \end{tabbing}}} \de{MAPC}{(X:list, FN:function):\ty{any}}{eval, spread} {FN is applied to successive CAR segments of list X. NIL is returned. {\tt \begin{tabbing} EXPR PROCEDURE MAPC(X, FN); \\ \hspace*{1em} WHILE X DO $<<$ FN CAR X; X := CDR X $>>$; \end{tabbing}}} \de{MAPCAN}{(X:list, FN:function):\ty{any}}{eval, spread} {A concatenated list of FN applied to successive CAR elements of X is returned. {\tt \begin{tabbing} EXPR PROCEDURE MAPCAN(X, FN); \\ \hspace*{1em} IF\= NULL X THEN NIL \\ \> ELSE NCONC(FN CAR X, MAPCAN(CDR X, FN)); \end{tabbing}}} \de{MAPCAR}{(X:list, FN:function):\ty{any}}{eval, spread} {Returned is a constructed list of FN applied to each CAR of list X. {\tt \begin{tabbing} EXPR PROCEDURE MAPCAR(X, FN); \\ \hspace*{1em} IF\= NULL X THEN NIL \\ \> ELSE FN CAR X . MAPCAR(CDR X, FN); \end{tabbing}}} \de{MAPCON}{(X:list, FN:function):\ty{any}}{eval, spread} {Returned is a concatenated list of FN applied to successive CDR segments of X. {\tt \begin{tabbing} EXPR PROCEDURE MAPCON(X, FN); \\ \hspace*{1em} IF\= NULL X THEN NIL \\ \> ELSE NCONC(FN X, MAPCON(CDR X, FN)); \end{tabbing}}} \de{MAPLIST}{(X:list, FN:function):\ty{any}}{eval, spread} {Returns a constructed list of FN applied to successive CDR segments of X. {\tt \begin{tabbing} EXPR PROCEDURE MAPLIST(X, FN); \\ \hspace*{1em} IF\= NULL X THEN NIL \\ \> ELSE FN X . MAPLIST(CDR X, FN); \end{tabbing}}} \subsection{Composite Functions} \de{APPEND}{(\p{U}:\ty{list}, \p{V}:\ty{list}):\ty{list}}{eval, spread} {Returns a constructed list in which the last element of U is followed by the first element of V. The list U is copied, V is not. {\tt \begin{tabbing} EXPR PROCEDURE APPEND(U, V); \\ \hspace*{1em} IF\= NULL U THEN V \\ \> ELSE CAR U . APPEND(CDR U, V); \end{tabbing}}} \de{ASSOC}{(\p{U}:\ty{any}, \p{V}:\ty{alist}):\{\ty{dotted-pair}, NIL\}}{eval, spread} {If U occurs as the CAR portion of an element of the alist V, the dotted-pair in which U occurred is returned, else NIL is returned. ASSOC might not detect a poorly formed alist so an invalid \index{EQUAL ! in ASSOC} \index{alist ! in ASSOC} construction may be detected by CAR or CDR. {\tt \begin{tabbing} EXPR PROCEDURE ASSOC(U, V); \\ \hspace*{1em} IF \= NULL V THEN NIL \\ \> ELSE \= IF ATOM CAR V THEN \\ \> \> ERROR(000, LIST(V, "is a poorly formed alist")) \\ \> ELSE IF U = CAAR V THEN CAR V \\ \> ELSE ASSOC(U, CDR V); \end{tabbing}} } \de{DEFLIST}{(\p{U}:\ty{dlist}, \p{IND}:\ty{id}):\ty{list}}{eval, spread} {A "dlist" is a list in which each element is a two element list: \index{dlist} (ID:id PROP:any). Each ID in U has the indicator IND with property PROP placed on its property list by the PUT function. The value of DEFLIST is a list of the first elements of each two element list. Like PUT, DEFLIST may not be used to define functions. {\tt \begin{tabbing} EXPR PROCEDURE DEFLIST(U, IND); \\ \hspace*{1em} IF NULL U THEN NIL \\ \hspace*{2em} ELSE $<<$ \= PUT(CAAR U, IND, CADAR U); \\ \> CAAR U $>>$ . DEFLIST(CDR U, IND); \end{tabbing}} } \de{DELETE}{(\p{U}:\ty{any}, \p{V}:\ty{list}):\ty{list}}{eval, spread} {Returns V with the first top level occurrence of U removed from it. \index{EQUAL ! in DELETE} {\tt \begin{tabbing} EXPR PROCEDURE DELETE(U, V); \\ \hspace*{1em} IF NULL V THEN NIL \\ \hspace*{2em} ELSE IF CAR V = U THEN CDR V \\ \hspace*{2em} ELSE CAR V . DELETE(U, CDR V); \end{tabbing}}} \de{DIGIT}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a digit, otherwise NIL. {\tt \begin{tabbing} EXPR PROCEDURE DIGIT(U); \\ \hspace*{1em} IF MEMQ(U, '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) \\ \hspace*{2em} THEN T ELSE NIL; \end{tabbing}}} \de{LENGTH}{(\p{X}:\ty{any}):\ty{integer}}{eval, spread} {The top level length of the list X is returned. {\tt \begin{tabbing} EXPR PROCEDURE LENGTH(X); \\ \hspace*{1em} IF ATOM X THEN 0 \\ \hspace*{2em} ELSE PLUS(1, LENGTH CDR X); \end{tabbing}}} \de{LITER}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread} {Returns T if U is a character of the alphabet, NIL otherwise.\footnote{The published report omits escape characters. These are required for both upper and lower case as some systems default to lower.} {\tt \begin{tabbing} EXPR PROCEDURE LITER(U); \\ \hspace*{1em} IF \= MEMQ(U, '(\=!A !B !C !D !E !F !G !H !I !J !K !L !M \\ \> \> !N !O !P !Q !R !S !T !U !V !W !X !Y !Z \\ \> \> !a !b !c !d !e !f !g !h !i !j !k !l !m \\ \> \> !n !o !p !q !r !s !t !u !v !w !x !y !z)) \\ \> THEN T ELSE NIL; \end{tabbing}}} \de{MEMBER}{(\p{A}:\ty{any}, \p{B}:\ty{list}):\ty{extra-boolean}}{eval, spread} {Returns NIL if A is not a member of list B, returns the remainder of B whose first element is A. \index{EQUAL ! in MEMBER} {\tt \begin{tabbing} EXPR PROCEDURE MEMBER(A, B); \\ \hspace*{1em} IF NULL B THEN NIL \\ \hspace*{2em} ELSE IF A = CAR B THEN B \\ \hspace*{2em} ELSE MEMBER(A, CDR B); \end{tabbing}}} \de{MEMQ}{(\p{A}:\ty{any}, \p{B}:\ty{list}):\ty{extra-boolean}}{eval, spread} {Same as MEMBER but an EQ check is used for comparison. \index{EQ ! in MEMQ} {\tt \begin{tabbing} EXPR PROCEDURE MEMQ(A, B); \\ \hspace*{1em} IF \= NULL B THEN NIL \\ \> ELSE IF A EQ CAR B THEN B \\ \> ELSE MEMQ(A, CDR B); \end{tabbing}}} \de{NCONC}{(\p{U}:\ty{list}, \p{V}:\ty{list}):\ty{list}}{eval, spread} {Concatenates V to U without copying U. The last CDR of U is modified to point to V. {\tt \begin{tabbing} EXPR PROCEDURE NCONC(U, V); \\ BEGIN SCALAR W; \\ \hspace*{2em} \= IF NULL U THEN RETURN V; \\ \> W := U; \\ \> WHILE CDR W DO W := CDR W; \\ \> RPLACD(W, V); \\ \> RETURN U \\ END; \end{tabbing}}} \de{PAIR}{(\p{U}:\ty{list}, \p{V}:\ty{list}):\ty{alist}}{eval, spread} {U and V are lists which must have an identical number of elements. If not, an error occurs (the 000 used in the ERROR call is arbitrary and need not be adhered to). Returned is a list where each element is a dotted-pair, the CAR of the pair being from U, and the CDR the corresponding element from V. {\tt \begin{tabbing} EXPR PROCEDURE PAIR(U, V); \\ \hspace*{1em} IF AND(U, V) THEN (CAR U . CAR V) . PAIR(CDR U, CDR V) \\ \hspace*{2em} \= ELSE IF OR(U, V) THEN ERROR(000, \\ \hspace*{4em} "Different length lists in PAIR") \\ \> ELSE NIL; \end{tabbing}}} \de{REVERSE}{(\p{U}:\ty{list}):\ty{list}}{eval, spread} {Returns a copy of the top level of U in reverse order. {\tt \begin{tabbing} EXPR PROCEDURE REVERSE(U); \\ BEGIN SCALAR W; \\ \hspace*{2em} \= WHILE U DO $<<$ \= W := CAR U . W; \\ \> \> U := CDR U $>>$; \\ \> RETURN W \\ END; \end{tabbing}}} \de{SASSOC}{(\p{U}:\ty{any}, \p{V}:\ty{alist}, \p{FN}:\ty{function}):\ty{any}}{eval, spread} {Searches the alist V for an occurrence of U. If U is not in the alist the evaluation of function FN is returned. \index{EQUAL ! in SASSOC} \index{alist ! in SASSOC} {\tt \begin{tabbing} EXPR PROCEDURE SASSOC(U, V, FN); \\ \hspace*{1em} IF NULL V THEN FN() \\ \hspace*{2em} \= ELSE IF U = CAAR V THEN CAR V \\ \> ELSE SASSOC(U, CDR V, FN); \end{tabbing}}} \de{SUBLIS}{(\p{X}:\ty{alist}, \p{Y}:\ty{any}):\ty{any}}{eval, spread} {The value returned is the result of substituting the CDR of each element of the alist X for every occurrence of the CAR part of that element in Y. \index{alist ! in SUBLIS} {\tt \begin{tabbing} EXPR PROCEDURE SUBLIS(X, Y); \\ \hspace*{1em}IF NULL X THEN Y \\ \hspace*{2em} ELSE BEGIN \= SCALAR U; \\ \> U := ASSOC(Y, X); \\ \> RETURN \= IF U THEN CDR U \\ \> \> ELSE IF ATOM Y THEN Y \\ \> \> ELSE \= SUBLIS(X, CAR Y) . \\ \> \> \> SUBLIS(X, CDR Y) \\ \> END; \end{tabbing}}} \de{SUBST}{(\p{U}:\ty{any}, \p{V}:\ty{any}, \p{W}:\ty{any}):\ty{any}}{eval, spread} {The value returned is the result of substituting U for all occurrences of V in W. \index{EQUAL ! in SUBST} {\tt \begin{tabbing} EXPR PROCEDURE SUBST(U, V, W); \\ \hspace*{1em} IF NULL W THEN NIL \\ \hspace*{2em} \= ELSE IF V = W THEN U \\ \> ELSE IF ATOM W THEN W \\ \> ELSE SUBST(U, V, CAR W) . SUBST(U, V, CDR W); \end{tabbing}}} \subsection{The Interpreter} \label{interpreter} \de{APPLY}{(\p{FN}:\{\ty{id,function}\}, \p{ARGS}:\ty{any-list}):\ty{any}}{eval, spread} {APPLY returns the value of FN with actual parameters ARGS. The actual parameters in ARGS are already in the form required for binding to the formal parameters of FN. Implementation specific portions described in English are enclosed in boxes. {\tt \begin{tabbing} EXPR PROCEDURE APPLY(FN, ARGS); \\ BEGIN SCALAR DEFN; \\ \hspace*{2em}\= IF CODEP FN THEN RETURN \\ \> \hspace{1em} \framebox[3.25in]{\parbox{3.25in}{Spread the actual parameters in ARGS following the conventions: for calling functions, transfer to the entry point of the function, and return the value returned by the function.}}; \\ \> IF \= IDP FN THEN RETURN \\ \> \> IF \= NULL(DEFN := GETD FN) THEN \\ \> \> \> ERROR(000, LIST(FN, "is an undefined function")) \\ \> \> ELSE IF CAR DEFN EQ 'EXPR THEN \\ \> \> \> APPLY(CDR DEFN, ARGS) \\ \> \> ELSE ERROR(000, \\ \> \> \> LIST(FN, "cannot be evaluated by APPLY")); \\ \> IF OR(ATOM FN, NOT(CAR FN EQ 'LAMBDA)) THEN \\ \> \> ERROR(000, \\ \> \> LIST(FN, "cannot be evaluated by APPLY")); \\ \> RETURN \\ \> \> \framebox[3.25in]{\parbox{3.25in}{Bind the actual parameters in ARGS to the formal parameters of the lambda expression. If the two lists are not of equal length then ERROR(000, "Number of parameters do not match"); The value returned is EVAL CADDR FN.}} \\ END; \end{tabbing}}} \de{EVAL}{(\p{U}:\ty{any}):\ty{any}}{eval, spread} {The value of the expression U is computed. Error numbers are arbitrary. Portions of EVAL involving machine specific coding are expressed in English enclosed in boxes. {\tt \begin{tabbing} EXPR PROCEDURE EVAL(U); \\ BEGIN SCALAR FN; \\ \hspace*{2em} \= IF CONSTANTP U THEN RETURN U; \\ \> IF IDP U THEN RETURN \\ \> \hspace{1em} \framebox[3.25in]{\parbox{3.25in}{U is an id. Return the value most currently bound to U or if there is no such binding: ERROR(000, LIST("Unbound:", U));}} \\ \> IF \= PAIRP CAR U THEN RETURN \\ \> \> IF CAAR U EQ 'LAMBDA THEN APPLY(CAR U, EVLIS CDR U) \\ \> \> ELSE ERROR(\= 000, LIST(CAR U, \\ \> \> \> "improperly formed LAMBDA expression")) \\ \> \> ELSE IF CODEP CAR U THEN \\ \> \> \> RETURN APPLY(CAR U, EVLIS CDR U); \\ \> FN := GETD CAR U; \\ \> IF NULL FN THEN \\ \> \> ERROR(000, LIST(CAR U, "is an undefined function")) \\ \> ELSE IF CAR FN EQ 'EXPR THEN \\ \> \> RETURN APPLY(CDR FN, EVLIS CDR U) \\ \> ELSE IF CAR FN EQ 'FEXPR THEN \\ \> \> RETURN APPLY(CDR FN, LIST CDR U) \\ \> ELSE IF CAR FN EQ 'MACRO THEN \\ \> \> RETURN EVAL APPLY(CDR FN, LIST U) \\ END; \end{tabbing}}} \de{EVLIS}{(\p{U}:\ty{any-list}):\ty{any-list}}{eval, spread} {EVLIS returns a list of the evaluation of each element of U. {\tt \begin{tabbing} EXPR PROCEDURE EVLIS(U); \\ \hspace*{1em} IF NULL U THEN NIL \\ \hspace*{2em} ELSE EVAL CAR U . EVLIS CDR U; \end{tabbing}}} \de{EXPAND}{(\p{L}:\ty{list}, \p{FN}:\ty{function}):\ty{list}}{eval, spread} {FN is a defined function of two arguments to be used in the expansion of a MACRO. EXPAND returns a list in the form: \vspace{.15in} (FN L$_0$ (FN L$_1$ \ldots (FN L$_{n-1}$ L$_n$) \ldots )) \vspace{.15in} where $n$ is the number of elements in L, L$_i$ is the $i$th element of L. {\tt \begin{tabbing} EXPR PROCEDURE EXPAND(L,FN); \\ \hspace*{1em} IF NULL CDR L THEN CAR L \\ \hspace*{2em} ELSE LIST(FN, CAR L, EXPAND(CDR L, FN)); \end{tabbing}}} \de{FUNCTION}{(\p{FN}:\ty{function}):\ty{function}}{noeval, nospread} {The function FN is to be passed to another function. If FN is to have side effects its free variables must be fluid or global. FUNCTION is like QUOTE but its argument may be affected by compilation. We do not \index{FUNARGs not supported} consider FUNARGs in this report.} \de{QUOTE}{(U:any):\ty{any}}{noeval, nospread} {Stops evaluation and returns U unevaluated. {\tt \begin{tabbing} FEXPR PROCEDURE QUOTE(U); \\ \hspace*{2em}CAR U; \end{tabbing}}} \subsection{Input and Output} \label{IO} The user normally communicates with Standard LISP through \index{standard devices} ``standard devices''. The default devices are selected in accordance with the conventions of the implementation site. Other input and output devices or files may be selected for reading and writing using the functions described herein. \de{CLOSE}{(\p{FILEHANDLE}:\ty{any}):\ty{any}}{eval, spread} {Closes the file with the internal name FILEHANDLE writing any necessary end of file marks and such. The value of FILEHANDLE is that returned by the corresponding OPEN. \index{OPEN} The value returned is the value of FILEHANDLE. An error occurs if the file can not be \index{file handle} \index{files} closed. \errormessage{ ***** FILEHANDLE could not be closed} } \de{EJECT}{():NIL}{eval, spread} {Skip to the top of the next output page. Automatic EJECTs are executed by the print functions when the length set by the PAGELENGTH \index{PAGELENGTH} function is exceeded.} \de{LINELENGTH}{(\p{LEN}:\{\ty{integer}, NIL\}):\ty{integer}}{eval, spread} {If LEN is an integer the maximum line length to be printed before the print functions initiate an automatic TERPRI is set to the value LEN. \index{TERPRI} No initial Standard LISP line length is assumed. The previous line length is returned except when LEN is NIL. This special case returns the current line length and does not cause it to be reset. An error occurs if the requested line length is too large for the currently selected output file or LEN is negative or zero. \errormessage{ ***** LEN is an invalid line length} } \de{LPOSN}{():\ty{integer}}{eval, spread} {Returns the number of lines printed on the current page. At the top of a page, 0 is returned. } \de{OPEN}{(\p{FILE}:\ty{any}, \p{HOW}:\ty{id}):\ty{any}}{eval, spread} {Open the file with the system dependent name FILE for output if HOW is EQ to OUTPUT, or input if HOW is EQ to INPUT. If the file is \index{file handle} \index{files} \index{OUTPUT} \index{INPUT} opened successfully, a value which is internally associated with the file is returned. This value must be saved for use by RDS and WRS. An error occurs if HOW is something other than INPUT or OUTPUT or the file can't be opened. \errormessage{***** HOW is not option for OPEN} \errormessage{***** FILE could not be opened} } \de{PAGELENGTH}{(\p{LEN}:\{\ty{integer}, NIL\}):\ty{integer}}{eval, spread} {Sets the vertical length (in lines) of an output page. Automatic page EJECTs are executed by the print functions when this length is \index{EJECT} reached. The initial vertical length is implementation specific. The previous page length is returned. If LEN is 0, no automatic page ejects will occur. } \de{POSN}{():\ty{integer}}{eval, spread} {Returns the number of characters in the output buffer. When the buffer is empty, 0 is returned.} \de{PRINC}{(\p{U}:\ty{id}):\ty{id}}{eval, spread} {U must be a single character id such as produced by EXPLODE or read by READCH or the value of !\$EOL!\$. The effect is the character U \index{\$EOL\$ (global)} displayed upon the currently selected output device. The value of !\$EOL!\$ causes termination of the current line like a call to TERPRI.} \de{PRINT}{(\p{U}:\ty{any}):\ty{any}}{eval, spread} {Displays U in READ readable format and terminates the print line. The value of U is returned. {\tt \begin{tabbing} EXPR PROCEDURE PRINT(U); \\ \hspace*{2em} $<<$ PRIN1 U; TERPRI(); U $>>$; \end{tabbing}}} \de{PRIN1}{(\p{U}:\ty{any}):\ty{any}}{eval, spread} {U is displayed in a READ readable form. The format of display is the result of EXPLODE expansion; special characters are prefixed with the escape character !, and strings are enclosed in "\ldots ". Lists are displayed in list-notation and vectors in vector-notation. } \de{PRIN2}{(\p{U}:\ty{any}):\ty{any}}{eval, spread} {U is displayed upon the currently selected print device but output is not READ readable. The value of U is returned. Items are displayed as described in the EXPLODE function with the exceptions that the escape character does not prefix special characters and strings are not enclosed in "\ldots ". Lists are displayed in list-notation and vectors in vector-notation. The value of U is returned. } \de{RDS}{(\p{FILEHANDLE}:\ty{any}):\ty{any}}{eval, spread} {Input from the currently selected input file is suspended and further input comes from the file named. FILEHANDLE is a system dependent \index{file handle} internal name which is a value returned by OPEN. If FILEHANDLE is NIL the standard input device is selected. When end of file is reached on a non-standard input device, the standard input device is reselected. When end of file occurs on the standard input device the Standard LISP reader terminates. RDS returns the internal name of the previously selected input file. \index{standard input} \errormessage{***** FILEHANDLE could not be selected for input} } \de{READ}{():\ty{any}}{} {The next expression from the file currently selected for input. Valid input forms are: vector-notation, dot-notation, list-notation, numbers, function-pointers, strings, and identifiers with escape characters. Identifiers are interned onW the OBLIST (see \index{INTERN} \index{OBLIST entry} the INTERN function in "Identifiers", section~\ref{identifiers} on page~\pageref{identifiers}). READ returns the \index{\$EOF\$ (global)} value of !\$EOF!\$ when the end of the currently selected input file is reached. } \de{READCH}{():\ty{id}}{} {Returns the next interned character from the file currently selected for input. Two special cases occur. If all the characters in an input \index{\$EOL\$ (global)} \index{\$EOF\$ (global)} record have been read, the value of !\$EOL!\$ is returned. If the file selected for input has all been read the value of !\$EOF!\$ is returned. Comments delimited by \% and end-of-line are not transparent to READCH. \index{\% ! read by READCH} } \de{TERPRI}{():\p{NIL}}{} {The current print line is terminated.} \de{WRS}{(\p{FILEHANDLE}:\ty{any}):\ty{any}}{eval, spread} {Output to the currently active output file is suspended and further output is directed to the file named. FILEHANDLE is an internal name which is returned by OPEN. The file named must have been opened for output. If FILEHANDLE is NIL the standard output device is selected. \index{file handle} \index{standard output} WRS returns the internal name of the previously selected output file. \errormessage{***** FILEHANDLE could not be selected for output} } \subsection{LISP Reader} An EVAL read loop has been chosen to drive a Standard LISP system to provide a continuity in functional syntax. Choices of messages and the amount of extra information displayed are decisions left to the implementor. \index{STANDARD-LISP} {\tt \begin{tabbing} EXPR PROCEDURE STANDARD!-LISP(); \\ BEGIN SCALAR VALUE; \\ \hspace*{2em} \= RDS NIL; WRS NIL; \\ \> PRIN2 "Standard LISP"; TERPRI(); \\ \> WHILE T DO \\ \> \hspace*{1em} $<<$ \= PRIN2 "EVAL:"; TERPRI(); \\ \> \> VALUE := ERRORSET(QUOTE EVAL READ(), T, T); \\ \> \> IF NOT ATOM VALUE THEN PRINT CAR VALUE; \\ \> \> TERPRI() $>>$; \\ END; \end{tabbing}} \de{QUIT}{()}{} {Causes termination of the LISP reader and control to be transferred to the operating system.} \section{System GLOBAL Variables} \label{slglobals} These variables provide global control of the LISP system, or implement values which are constant throughout execution.\footnote{The published document does not specify that all these are GLOBAL.} \variable{*COMP}{NIL}{global} {The value of !*COMP controls whether or not PUTD compiles the function defined in its arguments before defining it. If !*COMP is NIL the function is defined as an xEXPR. If !*COMP is something else the function is first compiled. Compilation will produce certain changes in the semantics of functions particularly FLUID type access.} \variable{EMSG*}{NIL}{global} {Will contain the MESSAGE generated by the last ERROR call (see \index{ERROR} ``Error Handling'' section~\ref{errors} on page~\pageref{errors}).} \variable{\$EOF\$}{\s{an uninterned identifier}}{global} {The value of !\$EOF!\$ is returned by all input functions when the end \index{end of file} of the currently selected input file is reached.} \variable{\$EOL\$}{\s{an uninterned identifier}}{global} {The value of !\$EOL!\$ is returned by READCH when it reaches the end of \index{READCH} \index{end of line} \index{PRINC} a logical input record. Likewise PRINC will terminate its current line (like a call to TERPRI) when !\$EOL!\$ is its argument.} \variable{*GC}{NIL}{global} {!*GC controls the printing of garbage collector messages. If NIL no \index{garbage collector} indication of garbage collection may occur. If non-NIL various system dependent messages may be displayed.} \variable{NIL}{NIL}{global} {NIL is a special global variable. It is protected from being modified by SET or SETQ. \index{NIL ! cannot be changed}} \variable{*RAISE}{NIL}{global} {If !*RAISE is non-NIL all characters input through Standard LISP input/output functions will be raised to upper case. If !*RAISE is NIL characters will be input as is.} \variable{T}{T}{global} {T is a special global variable. It is protected from being modified by SET or SETQ. \index{T ! cannot be changed}} \section{The Extended Syntax} Whenever it is possible to define Standard LISP functions in LISP the text of the function will appear in an extended syntax. These definitions are supplied as an aid to understanding the behavior of functions and not as a strict implementation guide. A formal scheme for the translation of extended syntax to Standard LISP is presented to eliminate misinterpretation of the definitions. \subsection{Definition} The goal of the transformation scheme is to produce a PUTD invocation which has the function translated from the extended syntax as its actual parameter. A rule has a name in brackets \s{\ldots} by which it is known and is defined by what follows the meta symbol ::=. Each rule of the set consists of one or more ``alternatives'' separated by the $\mid$ meta symbol, being the different ways in which the rule will be matched by source text. Each alternative is composed of a ``recognizer'' and a ``generator'' separated by the $\Longrightarrow$ meta symbol. The recognizer is a concatenation of any of three different forms. 1) Terminals - Upper case lexemes and punctuation which is not part of the meta syntax represent items which must appear as is in the source text for the rule to succeed. 2) Rules - Lower case lexemes enclosed in \s{\ldots} are names of other rules. The source text is matched if the named rule succeeds. 3) Primitives - Lower case singletons not in brackets are names of primitives or primitive classes of Standard LISP. The syntax and semantics of the primitives are given in Part I. The recognizer portion of the following rule matches an extended syntax procedure: \s{function} ::= ftype PROCEDURE id (\s{id list}); \\ \hspace*{2em} \s{statement}; $\Longrightarrow$ A function is recognized as an ``ftype'' (one of the tokens EXPR, FEXPR, etc.) followed by the keyword PROCEDURE, followed by an ``id'' (the name of the function), followed by an \s{id list} (the formal parameter names) enclosed in parentheses. A semicolon terminates the title line. The body of the function is a \s{statement} followed by a semicolon. For example: \begin{verbatim} EXPR PROCEDURE NULL(X); EQ(X, NIL); \end{verbatim} \noindent satisfies the recognizer, causes the generator to be activated and the rule to be matched successfully. The generator is a template into which generated items are substituted. The three syntactic entities have corresponding meanings when they appear in the generator portion. 1) Terminals - These lexemes are copied as is to the generated text. 2) Rules - If a rule has succeeded in the recognizer section then the value of the rule is the result of the generator portion of that rule. 3) Primitives - When primitives are matched the primitive lexeme replaces its occurrence in the generator. If more than one occurrence of an item would cause ambiguity in the generator portion this entity appears with a bracketed subscript. Thus: \begin{tabbing} \s{conditional} ::= \\ \hspace*{2em} IF \s{expression} \= THEN \s{statement$_1$} \\ \> ELSE \s{statement$_2$} \ldots \end{tabbing} \noindent has occurrences of two different \s{statement}s. The generator portion uses the subscripted entities to reference the proper generated value. The \s{function} rule appears in its entirety as: \begin{tabbing} \s{function} ::= ftype PROCEDURE id (\s{id list});\s{statement}; $\Longrightarrow$ \\ \hspace*{2em} \=(PUTD \= (QUOTE id) \\ \> \> (QUOTE ftype) \\ \> \>(QUOTE (LAMBDA (\s{id list}) \s{statement}))) \end{tabbing} If the recognizer succeeds (as it would in the case of the NULL procedure example) the generator returns: \begin{verbatim} (PUTD (QUOTE NULL) (QUOTE EXPR) (QUOTE (LAMBDA (X) (EQ X NIL)))) \end{verbatim} The identifier in the template is replaced by the procedure name NULL, \s{id list} by the single formal parameter X, the \s{statement} by (EQ X NIL) which is the result of the \s{statement} generator. EXPR replaces ftype, the type of the defined procedure. \subsection{The Extended Syntax Rules} \begin{tabbing} \s{function} ::= ftype \k{PROCEDURE} id (\s{id list}); \s{statement}; $\Longrightarrow$ \\ \hspace*{2em} \= (PUTD \= (QUOTE id) \\ \> \> (QUOTE ftype) \\ \> \> (QUOTE (LAMBDA (\s{id list}) \s{statement}))) \\ \\ \s{id list} ::= id $\Longrightarrow$ id $\mid$ \\ \> id, \s{id list} $\Longrightarrow$ id \s{id list} $\mid$ \\ \> $\Longrightarrow$ NIL \\ \s{statement} ::= \s{expression} $\Longrightarrow$ \s{expression} $\mid$ \\ \> \s{proper statement} $\Longrightarrow$ \s{proper statement} \\ \\ \s{proper statement} ::= \\ \> \s{assignment statement} $\Longrightarrow$ \s{assignment statement} $\mid$ \\ \> \s{conditional statement} $\Longrightarrow$ \s{conditional statement} $\mid$ \\ \> \s{while statement} $\Longrightarrow$ \s{while statement} $\mid$ \\ \> \s{compound statement} $\Longrightarrow$ \s{compound statement} \\ \\ \s{assignment statement} ::= id := \s{expression} $\Longrightarrow$ \\ \> \> (SETQ id \s{expression}) \\ \\ \s{conditional statement} ::= \\ \> \k{IF} \s{expression} \k{THEN} \s{statement$_1$} \k{ELSE} \s{statement$_2$} $\Longrightarrow$ \\ \> \hspace{2em} \= (COND (\s{expression} \s{statement$_1$})(T \s{statement$_2$})) $\mid$ \\ \> \k{IF} \s{expression} \k{THEN} \s{statement} $\Longrightarrow$ \\ \> \> (COND (\s{expression} \s{statement})) \\ \\ \s{while statement} ::= \k{WHILE} \s{expression} \k{DO} \s{statement} $\Longrightarrow$ \\ \> \> (PROG NIL \\ \> \> LBL \= (COND ((NULL \s{expression}) (RETURN NIL))) \\ \> \> \> \s{statement} \\ \> \> \> (GO LBL)) \\ \\ \s{compound statement} ::= \\ \> \k{BEGIN} \k{SCALAR} \s{id list}; \s{program list} \k{END} $\Longrightarrow$ \\ \> \> (PROG (\s{id list}) \s{program list}) $\mid$ \\ \> \k{BEGIN} \s{program list} \k{END} $\Longrightarrow$ \\ \> \> (PROG NIL \s{program list}) $\mid$ \\ \> \k{$<<$} \s{statement list} \k{$>>$} $\Longrightarrow$ (PROGN \s{statement list}) \\ \\ \s{program list} ::= \s{full statement} $\Longrightarrow$ \s{full statement} $\mid$ \\ \> \s{full statement} \s{program list} $\Longrightarrow$ \\ \> \> \s{full statement} \s{program list} \\ \\ \s{full statement} ::= \s{statement} $\Longrightarrow$ \s{statement} $\mid$ id: $\Longrightarrow$ id \\ \\ \s{statement list} ::= \s{statement} $\Longrightarrow$ \s{statement} $\mid$ \\ \> \s{statement}; \s{statement list} $\Longrightarrow$ \\ \> \> \s{statement} \s{statement list} \\ \\ \s{expression} ::= \\ \> \s{expression$_1$} \k{.} \s{expression$_2$} $\Longrightarrow$ \\ \> \> (CONS \s{expression$_1$} \s{expression$_2$} $\mid$ \\ \> \s{expression$_1$} \k{=} \s{expression$_2$} $\Longrightarrow$ \\ \> \> (EQUAL \s{expression$_1$} \s{expression$_2$}) $\mid$ \\ \> \s{expression$_1$} \k{EQ} \s{expression$_2$} $\Longrightarrow$ \\ \> \> (EQ \s{expression$_1$} \s{expression$_2$}) $\mid$ \\ \> '\s{expression} $\Longrightarrow$ (QUOTE \s{expression}) $\mid$ \\ \> function \s{expression} $\Longrightarrow$ (function \s{expression}) $\mid$ \\ \> function(\s{argument list}) $\Longrightarrow$ (function \s{argument list}) $\mid$ \\ \> number $\Longrightarrow$ number $\mid$ \\ \> id $\Longrightarrow$ id \\ \\ \s{argument list} ::= () $\Longrightarrow$ $\mid$ \\ \> \s{expression} $\Longrightarrow$ \s{expression} $\mid$ \\ \> \s{expression}, \s{argument list} $\Longrightarrow$ \s{expression} \s{argument list} \end{tabbing} Notice the three infix operators . EQ and = which are translated into calls on CONS, EQ, and EQUAL respectively. Note also that a call on a function which has no formal parameters must have () as an argument list. The QUOTE function is abbreviated by '. \bibliography{sl} \bibliographystyle{plain} \end{document} |
Added r34.1/doc/spde.tex version [5db21286ea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{The Package SPDE for Determining Symmetries of Partial Differential Equations} \date{} \author{Fritz Schwarz \\ GMD, Institut F1 \\ Postfach 1240 \\ 5205 St. Augustin \\ GERMANY \\[0.05in] Telephone: +49-2241-142782 \\ Email: gf1002@dbngmd21.bitnet} \begin{document} \maketitle The package SPDE provides a set of functions which may be applied to determine the symmetry group of Lie-or point-symmetries of a given system of partial differential equations. Preferably it is used interactively on a computer terminal. In many cases the determining system is solved completely automatically. In some other cases the user has to provide some additional input information for the solution algorithm to terminate. The package should only be used in compiled form. For all theoretical questions, a description of the algorithm and numerous examples the following articles should be consulted: ``Automatically Determining Symmetries of Partial Differential Equations'', Computing vol. 34, page 91-106(1985) and vol. 36, page 279-280(1986), ``Symmetries of Differential Equations: From Sophus Lie to Computer Algebra'', SIAM Review, to appear, and Chapter 2 of the Lecture Notes ``Computer Algebra and Differential Equations of Mathematical Physics'', to appear. \section{Description of the System Functions and Variables} The symmetry analysis of partial differential equations logically falls into three parts. Accordingly the most important functions provided by the package are: \begin{table} \begin{center} \begin{tabular}{| c | c | }\hline Function name & Operation \\ \hline \hline \ttindex{CRESYS} CRESYS(\s{arguments}) & Constructs determining system \\ \hline \ttindex{SIMPSYS} SIMPSYS() & Solves determining system \\ \hline \ttindex{RESULT} RESULT() & Prints infinitesimal generators \\ & and commutator table \\ \hline \end{tabular} \end{center} \caption{SPDE Functions} \end{table} Some other useful functions for obtaining various kinds of output are: \begin{table} \begin{center} \begin{tabular}{| c | c |} \hline Function name & Operation \\ \hline \hline \ttindex{PRSYS} PRSYS() & Prints determining system \\ \hline \ttindex{PRGEN} PRGEN() & Prints infinitesimal generators \\ \hline \ttindex{COMM} COMM(U,V) & Prints commutator of generators U and V \\ \hline \end{tabular} \end{center} \caption{SPDE Useful Output Functions}\label{spde:useful} \end{table} There are several global variables defined by the system which should not be used for any other purpose than that given in Table~\ref{spde:intt} and~\ref{spde:op}. The three globals of the type integer are: \begin{table} \begin{center} \begin{tabular}{| c | c |}\hline Variable name & Meaning \\ \hline \hline \ttindex{NN} NN & Number of independent variables \\ \hline \ttindex{MM} MM & Number of dependent variables \\ \hline \ttindex{PCLASS} PCLASS=0, 1 or 2 & Controls amount of output \\ \hline \end{tabular} \end{center} \caption{SPDE Integer valued globals}\label{spde:intt} \end{table} In addition there are the following global variables of type operator: \begin{table} \begin{center} \begin{tabular}{| c | c |}\hline Variable name & Meaning \\ \hline \hline \ttindex{X(I)} X(I) & Independent variable $x_i$ \\ \hline \ttindex{U(ALFA)} U(ALFA) & Dependent variable $u^{alfa}$ \\ \hline \ttindex{U(ALFA,I)} U(ALFA,I) & Derivative of $u^{alfa}$ w.r.t. $x_i$ \\ \hline \ttindex{DEQ(I)} DEQ(I) & i-th differential equation \\ \hline \ttindex{SDER(I)} SDER(I) & Derivative w.r.t. which DEQ(I) is resolved \\ \hline \ttindex{GL(I)} GL(I) & i-th equation of determining system \\ \hline \ttindex{GEN(I)} GEN(I) & i-th infinitesimal generator \\ \hline \ttindex{XI(I)} \ttindex{ETA(ALFA)} \ttindex{ZETA(ALFA,I)} XI(I), ETA(ALFA) & See definition given in the \\ ZETA(ALFA,I) & references quoted in the introduction. \\ \hline \ttindex{C(I)} C(I) & i-th function used for substitution \\ \hline \end{tabular} \end{center} \caption{SPDE Operator type global variables}\label{spde:op} \end{table} The differential equations of the system at issue have to be assigned as values to the operator deq i applying the notation which is defined in Table~\ref{spde:op}. The entries in the third and the last line of that Table have obvious extensions to higher derivatives. The derivative w.r.t. which the i-th differential equation deq i is resolved has to be assigned to sder i. Exception: If there is a single differential equation and no assignment has been made by the user, the highest derivative is taken by default. When the appropriate assignments are made to the variable deq, the values of NN and MM (Table~\ref{spde:useful}) are determined automatically, i.e. they have not to be assigned by the user. \ttindex{CRESYS} The function CRESYS may be called with any number of arguments, i.e. \begin{verbatim} CRESYS(); or CRESYS(deq 1,deq 2,... ); \end{verbatim} are legal calls. If it is called without any argument, all current assignments to deq are taken into account. Example: If deq 1, deq 2 and deq 3 have been assigned a differential equation and the symmetry group of the full system comprising all three equations is desired, equivalent calls are \begin{verbatim} CRESYS(); or CRESYS(deq 1,deq 2,deq 3); \end{verbatim} The first alternative saves some typing. If later in the session the symmetry group of deq 1 alone has to be determined, the correct call is \begin{verbatim} CRESYS deq 1; \end{verbatim} \ttindex{SIMPSYS} After the determining system has bee created, SIMPSYS which has no arguments may be called for solving it. The amount of intermediate output produced by SIMPSYS is controlled by the global variable PCLASS with the default value 0. \ttindex{PCLASS} With PCLASS equal to 0, no intermediate steps are shown. With PCLASS equal to 1, all intermediate steps are displayed so that the solution algorithm may be followed \index{tracing ! SPDE package} through in detail. Each time the algorithm passes through the top of the main solution loop the message \begin{verbatim} Entering main loop \end{verbatim} is written. PCLASS equal 2 produces a lot of LISP output and is of no interest for the normal user. If with PCLASS=0 the procedure SIMPSYS terminates without any response, the determining system is completely solved. In some cases SIMPSYS does not solve the determining system completely in a single run. In general this is true if there are only genuine differential equations left which the algorithm cannot handle at present. If a case like this occurs, SIMPSYS returns the remaining equations of the determining system. To proceed with the solution algorithm, appropriate assignments have to be transmitted by the user, e.g. the explicit solution for one of the returned differential equations. Any new functions which are introduced thereby must be operators of the form c(k) with the correct dependencies generated by a depend statement (see the ``REDUCE User's Guide''). Its enumeration has to be chosen in agreement with the current number of functions which have alreday been introduced. This value is returned by SIMPSYS too. After the determining system has been solved, the procedure RESULT, which has no arguments, may be called. It displays the infinitesimal generators and its non-vanishing commutators. \section{How to Use the Package} In this Section it is explained by way of several examples how the package SPDE is used interactively to determine the symmetry group of partial differential equations. Consider first the diffusion equation which in the notation given above may be written as \begin{verbatim} deq 1:=u(1,1)+u(1,2,2); \end{verbatim} It has been assigned as the value of deq 1 by this statement. There is no need to assign a value to sder 1 here because the system comprises only a single equation. The determining system is constructed by calling \begin{verbatim} CRESYS(); or CRESYS deq 1; \end{verbatim} The latter call is compulsory if there are other assignments to the operator deq i than for i=1. The error message \begin{verbatim} ***** Differential equations not defined \end{verbatim} appears if there are no differential equations assigned to any deq. If the user wants the determining system displayed for inspection before starting the solution algorithm he may call \ttindex{PRSYS} \begin{verbatim} PRSYS(); \end{verbatim} and gets the answer \begin{verbatim} GL(1):=2*DF(ETA(1),U(1),X(2)) - DF(XI(2),X(2),2) - DF(XI(2),X(1)) GL(2):=DF(ETA(1),U(1),2) - 2*DF(XI(2),U(1),X(2)) GL(3):=DF(ETA(1),X(2),2) + DF(ETA(1),X(1)) GL(4):=DF(XI(2),U(1),2) GL(5):=DF(XI(2),U(1)) - DF(XI(1),U(1),X(2)) GL(6):=2*DF(XI(2),X(2)) - DF(XI(1),X(2),2) - DF(XI(1),X(1)) GL(7):=DF(XI(1),U(1),2) GL(8):=DF(XI(1),U(1)) GL(9):=DF(XI(1),X(2)) The remaining dependencies XI(2) depends on U(1),X(2),X(1) XI(1) depends on U(1),X(2),X(1) ETA(1) depends on U(1),X(2),X(1) \end{verbatim} The last message means that all three functions XI(1), XI(2) and ETA(1) depend on X(1), X(2) and U(1). Without this information the nine equations GL(1) to GL(9) forming the determining system are meaningless. Now the solution algorithm may be activated by calling \ttindex{SIMPSYS} \begin{verbatim} SIMPSYS(); \end{verbatim} \ttindex{PCLASS} If the print flag PCLASS has its default value which is 0 no intermediate output is produced and the answer is \begin{verbatim} Determining system is not completely solved The remaining equations are GL(1):=DF(C(1),X(2),2) + DF(C(1),X(1)) Number of functions is 16 The remaining dependencies C(1) depends on X(2),X(1) \end{verbatim} With PCLASS equal to 1 about 6 pages of intermediate output are obtained. It allows the user to follow through each step of the solution algorithm. In this example the algorithm did not solve the determining system completely as it is shown by the last message. This was to be expected because the diffusion equation is linear and therefore the symmetry group contains a generator depending on a function which solves the original differential equation. In cases like this the user has to provide some additional information to the system so that the solution algorithm may continue. In the example under consideration the appropriate input is \begin{verbatim} DF(C(1),X(1)) := - DF(C(1),X(2),2); \end{verbatim} If now the solution algorithm is activated again by \begin{verbatim} SIMPSYS(); \end{verbatim} the solution algorithm terminates without any further message, i.e. there are no equations of the determining system left unsolved. To obtain the symmetry generators one has to say finally \begin{verbatim} RESULT(); \end{verbatim} and obtains the answer \begin{verbatim} The differential equation DEQ(1):=U(1,2,2) + U(1,1) The symmetry generators are GEN(1):= DX(1) GEN(2):= DX(2) GEN(3):= 2*DX(2)*X(1) + DU(1)*U(1)*X(2) GEN(4):= DU(1)*U(1) GEN(5):= 2*DX(1)*X(1) + DX(2)*X(2) 2 GEN(6):= 4*DX(1)*X(1) + 4*DX(2)*X(2)*X(1) 2 + DU(1)*U(1)*(X(2) - 2*X(1)) GEN(7):= DU(1)*C(1) The remaining dependencies C(1) depends on X(2),X(1) Constraints DF(C(1),X(1)):= - DF(C(1),X(2),2) The non-vanishing commutators of the finite subgroup COMM(1,3):= 2*DX(2) COMM(1,5):= 2*DX(1) COMM(1,6):= 8*DX(1)*X(1) + 4*DX(2)*X(2) - 2*DU(1)*U(1) COMM(2,3):= DU(1)*U(1) COMM(2,5):= DX(2) COMM(2,6):= 4*DX(2)*X(1) + 2*DU(1)*U(1)*X(2) COMM(3,5):= - (2*DX(2)*X(1) + DU(1)*U(1)*X(2)) 2 COMM(5,6):= 8*DX(1)*X(1) + 8*DX(2)*X(2)*X(1) 2 + 2*DU(1)*U(1)*(X(2) - 2*X(1)) \end{verbatim} The message ``Constraints'' which appears after the symmetry generators are displayed means that the function c(1) depends on x(1) and x(2) and satisfies the diffusion equation. More examples which may used for test runs are given in the final section. \index{ansatz of symmetry generator} If the user wants to test a certain ansatz of a symmetry generator for given differential equations, the correct proceeding is as follows. Create the determining system as described above. Make the appropriate assignments for the generator and call PRSYS() after that. The determining system with this ansatz substituted is returned. Example: Assume again that the determining system for the diffusion equation has been created. To check the correctness for example of generator GEN 3 which has been obtained above, the assignments \begin{verbatim} XI(1):=0; XI(2):=2*X(1); ETA(1):=X(2)*U(1); \end{verbatim} have to be made. If now PRSYS() is called all GL(K) are zero proving the correctness of this generator. Sometimes a user only wants to know some of the functions ZETA for for various values of its possible arguments and given values of MM and NN. In these cases the user has to assign the desired values of MM and NN and may call the ZETA's after that. Example: \begin{verbatim} MM:=1; NN:=2; FACTOR U(1,2),U(1,1),U(1,1,2),U(1,1,1); ON LIST; ZETA(1,1); -U(1,2)*U(1,1)*DF(XI(2),U(1)) -U(1,2)*DF(XI(2),X(1)) 2 -U(1,1) *DF(XI(1),U(1)) +U(1,1)*(DF(ETA(1),U(1)) -DF(XI(1),X(1))) +DF(ETA(1),X(1)) ZETA(1,1,1); -2*U(1,1,2)*U(1,1)*DF(XI(2),U(1)) -2*U(1,1,2)*DF(XI(2),X(1)) -U(1,1,1)*U(1,2)*DF(XI(2),U(1)) -3*U(1,1,1)*U(1,1)*DF(XI(1),U(1)) +U(1,1,1)*(DF(ETA(1),U(1)) -2*DF(XI(1),X(1))) 2 -U(1,2)*U(1,1) *DF(XI(2),U(1),2) -2*U(1,2)*U(1,1)*DF(XI(2),U(1),X(1)) -U(1,2)*DF(XI(2),X(1),2) 3 -U(1,1) *DF(XI(1),U(1),2) 2 +U(1,1) *(DF(ETA(1),U(1),2) -2*DF(XI(1),U(1),X(1))) +U(1,1)*(2*DF(ETA(1),U(1),X(1)) -DF(XI(1),X(1),2)) +DF(ETA(1),X(1),2) \end{verbatim} If by error no values to MM or NN and have been assigned the message \begin{verbatim} ***** Number of variables not defined \end{verbatim} is returned. Often the functions ZETA are desired for special values of its arguments ETA(ALFA) and XI(K). To this end they have to be assigned first to some other variable. After that they may be evaluated for the special arguments. In the previous example this may be achieved by \begin{verbatim} Z11:=ZETA(1,1)$ Z111:=ZETA(1,1,1)$ \end{verbatim} Now assign the following values to XI 1, XI 2 and ETA 1: \begin{verbatim} XI 1:=4*X(1)**2; XI 2:=4*X(2)*X(1); ETA 1:=U(1)*(X(2)**2 - 2*X(1)); \end{verbatim} They correspond to the generator GEN 6 of the diffusion equation which has been obtained above. Now the desired expressions are obtained by calling \begin{verbatim} Z11; 2 - (4*U(1,2)*X(2) - U(1,1)*X(2) + 10*U(1,1)*X(1) + 2*U(1)) Z111; 2 - (8*U(1,1,2)*X(2) - U(1,1,1)*X(2) + 18*U(1,1,1)*X(1) + 12*U(1,1)) \end{verbatim} \section{Test File} This appendix is a test file. The symmetry groups for various equations or systems of equations are determined. The variable PCLASS has the default value 0 and may be changed by the user before running it. The output may be compared with the results which are given in the references. \begin{verbatim} %The Burgers equations deq 1:=u(1,1)+u 1*u(1,2)+u(1,2,2)$ cresys deq 1$ simpsys()$ result()$ %The Kadomtsev-Petviashvili equation deq 1:=3*u(1,3,3)+u(1,2,2,2,2)+6*u(1,2,2)*u 1 +6*u(1,2)**2+4*u(1,1,2)$ cresys deq 1$ simpsys()$ result()$ %The modified Kadomtsev-Petviashvili equation deq 1:=u(1,1,2)-u(1,2,2,2,2)-3*u(1,3,3) +6*u(1,2)**2*u(1,2,2)+6*u(1,3)*u(1,2,2)$ cresys deq 1$ simpsys()$ result()$ %The real- and the imaginary part of the nonlinear %Schroedinger equation deq 1:= u(1,1)+u(2,2,2)+2*u 1**2*u 2+2*u 2**3$ deq 2:=-u(2,1)+u(1,2,2)+2*u 1*u 2**2+2*u 1**3$ %Because this is not a single equation the two assignments sder 1:=u(2,2,2)$ sder 2:=u(1,2,2)$ %are necessary. cresys()$ simpsys()$ result()$ %The symmetries of the system comprising the four equations deq 1:=u(1,1)+u 1*u(1,2)+u(1,2,2)$ deq 2:=u(2,1)+u(2,2,2)$ deq 3:=u 1*u 2-2*u(2,2)$ deq 4:=4*u(2,1)+u 2*(u 1**2+2*u(1,2))$ sder 1:=u(1,2,2)$ sder 2:=u(2,2,2)$ sder 3:=u(2,2)$ sder 4:=u(2,1)$ %is obtained by calling cresys()$ simpsys()$ df(c 5,x 1):=-df(c 5,x 2,2)$ df(c 5,x 2,x 1):=-df(c 5,x 2,3)$ simpsys()$ result()$ % The symmetries of the subsystem comprising equation 1 % and 3 are obtained by cresys(deq 1,deq 3)$ simpsys()$ result()$ % The result for all possible subsystems is discussed in % detail in ``Symmetries and Involution Systems: Some % Experiments in Computer Algebra'', contribution to the % Proceedings of the Oberwolfach Meeting on Nonlinear % Evolution Equations, Summer 1986, to appear. \end{verbatim} \end{document} |
Added r34.1/doc/sum.tex version [e1895bb9f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{The REDUCE Sum Package \\ Ver 1.0 9 Oct 1989} \date{} \author{Fujio Kako \\ Department of Mathematics \\ Faculty of Science \\ Hiroshima University \\ Hiroshima 730, JAPAN \\ E-mail: kako@kako.math.sci.hiroshima-u.ac.jp \\ or \\ D52789@JPNKUDPC.BITNET} \begin{document} \maketitle \index{Gosper's Algorithm} \index{SUM operator} \index{PROD operator} This package implements the Gosper algorithm for the summation of series. It defines operators SUM and PROD. The operator SUM returns the indefinite or definite summation of a given expression, and the operator PROD returns the product of the given expression. These are used with the syntax: \vspace{.1in} \noindent {\tt SUM}(EXPR:{\em expression}, K:{\em kernel}, [LOLIM:{\em expression} [, UPLIM:{\em expression}]]) \vspace{.1in} \noindent {\tt PROD}(EXPR:{\em expression}, K:{\em kernel}, [LOLIM:{\em expression} [, UPLIM:{\em expression}]]) If there is no closed form solution, these operators return the input unchanged. UPLIM and LOLIM are optional parameters specifying the lower limit and upper limit of the summation (or product), respectively. If UPLIM is not supplied, the upper limit is taken as K (the summation variable itself). For example: \begin{verbatim} sum(n**3,n); sum(a+k*r,k,0,n-1); sum(1/((p+(k-1)*q)*(p+k*q)),k,1,n+1); prod(k/(k-2),k); \end{verbatim} Gosper's algorithm succeeds whenever the ratio of \[ \frac{\sum_{k=n_0}^n f(k)}{\sum_{k=n_0}^{n-1} f(k)} \] \noindent is a rational function of $n$. The function SUM!-SQ handles basic functions such as polynomials, rational functions and exponentials. \ttindex{SUM-SQ} The trigonometric functions sin, cos, etc. are converted to exponentials and then Gosper's algorithm is applied. The result is converted back into sin, cos, sinh and cosh. Summations of logarithms or products of exponentials are treated by the formula: \vspace{.1in} \hspace*{2em} \[ \sum_{k=n_0}^{n} \log f(k) = \log \prod_{k=n_0}^n f(k) \] \vspace{.1in} \hspace*{2em} \[ \prod_{k=n_0}^n \exp f(k) = \exp \sum_{k=n_0}^n f(k) \] \vspace{.1in} Other functions, as shown in the test file for the case of binomials and formal products, can be summed by providing LET rules which must relate the functions evaluated at $k$ and $k - 1$ ($k$ being the summation variable). \index{tracing ! SUM package} \ttindex{TRSUM} There is a switch TRSUM (default OFF). If this switch is on, trace messages are printed out during the course of Gosper's algorithm. \end{document} |
Added r34.1/doc/taylor.tex version [c59d58e114].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \newcommand{\MACSYMA}{{\sf MACSYMA}} \newcommand{\MAPLE}{{\sf MAPLE}} \newcommand{\Mathematica}{{\sf Mathematica}} \newcommand{\PSL}{{\sf PSL}} \title{A \REDUCE{} package for manipulation of Taylor series} \date{} \author{Rainer Sch\"opf\\ Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin\\ Heilbronner Str.\ 10\\ W-1000 Berlin 31\\ Federal Republic of Germany\\ Email: {\tt Schoepf@sc.ZIB-Berlin.de}} \begin{document} \maketitle \index{Taylor Series} \index{TAYLOR package} \index{Laurent series} This short note describes a package of \REDUCE{} procedures that allow Taylor expansion in one or more variables and efficient manipulation of the resulting Taylor series. Capabilities include basic operations (addition, subtraction, multiplication and division) and also application of certain algebraic and transcendental functions. To a certain extent, Laurent expansion can be performed as well. \section{Introduction} The Taylor package was written to provide \REDUCE{} with some of the facilities that \MACSYMA's \verb+TAYLOR+ function offers, but most of all I needed it to be faster and more space-efficient. Especially I wanted procedures that would return the logarithm or arc tangent of a Taylor series, again as a Taylor series. This turned out be more work than expected. The features absolutely required were (as usual) those that were hardest to implement, e.g., arc tangent applied to a Taylor expansion in more than one variable. This package is still undergoing development. I'll be happy if it is of any use for you. Tell me if you think that there is something missing. I invite everybody to criticize and comment and will eagerly try to correct any errors found. \section{How to use it} The most important operator is `\verb+TAYLOR+'. \index{TAYLOR operator} It is used as follows: \noindent {\tt TAYLOR}(EXP:{\em exprn}[,VAR:{\em kernel}, VAR$_0$:{\em exprn},ORDER:{\em integer}]\ldots):{\em exprn} where EXP is the expression to be expanded. It can be any \REDUCE{} object, even an expression containing other Taylor kernels. VAR is the kernel with respect to which EXP is to be expanded. VAR$_0$ denotes the point about which and ORDER the order up to which expansion is to take place. If more than one (VAR, VAR0, ORDER) triple is specified {\tt TAYLOR} will expand its first argument independently with respect to all the variables. For example, \begin{verbatim} taylor(e^(x^2+y^2),x,0,2,y,0,2); \end{verbatim} will calculate the Taylor expansion up to order $X^{2}*Y^{2}$. Note that once the expansion has been done it is not possible to calculate higher orders. Instead of a kernel, VAR may also be a list of kernels. In this case expansion will take place in a way so that the {\em sum\/} of the degrees of the kernels does not exceed ORDER. If VAR$_0$ evaluates to the special identifier \verb|INFINITY| {\tt TAYLOR} tries to expand EXP in a series in 1/VAR. The expansion is performed variable per variable, i.e.\ in the example above by first expanding $\exp(x^{2}+y^{2})$ with respect to $x$ and then expanding every coefficient with respect to $y$. \index{TAYLORPRINTTERMS variable} Only a certain number of (non-zero) coefficients are printed. If there are more, \verb|...| is printed as part of the expression to indicate this. The number of terms printed is given by the value of the shared algebraic variable \verb|TAYLORPRINTTERMS|. Allowed values are integers and the special identifier \verb|ALL|. The latter setting specifies that all terms are to be printed. The default setting is $5$. \index{TAYLORKEEPORIGINAL switch} If the switch \verb|TAYLORKEEPORIGINAL| is set to \verb|ON| the original expression EXP is kept for later reference. It can be recovered by means of the operator \hspace*{2em} {\tt TAYLORORIGINAL}(EXP:{\em exprn}):{\em exprn} An error is signalled if EXP is not a Taylor kernel or if the original expression was not kept, i.e.\ if \verb|TAYLORKEEPORIGINAL| was \verb|OFF| during expansion. The template of a Taylor kernel, i.e.\ the list of all variables with respect to which expansion took place together with expansion point and order can be extracted using \ttindex{TAYLORTEMPLATE} \hspace*{2em} {\tt TAYLORTEMPLATE}(EXP:{\em exprn}):{\em list} This returns a list of lists with the three elements (VAR,VAR0,ORDER) as with \verb|TAYLORORIGINAL|, an error is signalled if EXP is not a Taylor kernel. \hspace*{2em} {\tt TAYLORTOSTANDARD}(EXP:{\em exprn}):{\em exprn} converts all Taylor kernels in EXP into standard form and \ttindex{TAYLORTOSTANDARD} resimplifies the result. \hspace*{2em} {\tt TAYLORSERIESP}(EXP:{\em exprn}):{\em boolean} may be used to determine if EXP is a Taylor kernel. \ttindex{TAYLORSERIESP} Note that this operator is subject to the same restrictions as, e.g., ORDP or NUMBERP, i.e.\ it may only be used in boolean expressions in \verb|IF| or \verb|LET| statements. Finally there is \hspace*{2em} {\tt TAYLORCOMBINE}(EXP:{\em exprn}):{\em exprn} which tries to combine all Taylor kernels found in EXP into one. \ttindex{TAYLORCOMBINE} Operations currently possible are: \index{Taylor series ! arithmetic} \begin{itemize} \item Addition, subtraction, multiplication, and division. \item Roots, exponentials, and logarithms. \item Trigonometric and hyperbolic functions and their inverses. \end{itemize} Application of unary operators like \verb|LOG| and \verb|ATAN| will nearly always succeed. For binary operations their arguments have to be Taylor kernels with the same template. This means that the expansion variable and the expansion point must match. Expansion order is not so important, different order usually means that one of them is truncated before doing the operation. \ttindex{TAYLORKEEPORIGINAL} \ttindex{TAYLORCOMBINE} If \verb|TAYLORKEEPORIGINAL| is set to \verb|ON| and if all Taylor kernels in \verb|exp| have their original expressions kept \verb|TAYLORCOMBINE| will also combine these and store the result as the original expression of the resulting Taylor kernel. \index{TAYLORAUTOEXPAND switch} There is also the switch \verb|TAYLORAUTOEXPAND| (see below). There are a few restrictions to avoid mathematically undefined expressions: it is not possible to take the logarithm of a Taylor kernel whose constant term is zero, or to divide by a Taylor kernel that consists only of the constant zero. There are, however, some provisions made to detect singularities during expansion: poles that arise because the denominator has zeros at the expansion point are detected and properly treated, i.e.\ the Taylor kernel will start with a negative power. (This is accomplished by expanding numerator and denominator separately and combining the results.) It has been observed, however, that this does {\em not\/} work if the \verb|MCD| switch is set to \verb|OFF|. This seems to be a limitation of \REDUCE{} version 3.4. Essential singularities are not handled at all which means that usually some sort of error will be signalled. Maybe I can improve this later. \index{Taylor series ! differentiation} Differentiation of a Taylor expression is possible. If you differentiate with respect to one of the Taylor variables the order will decrease by one. \index{Taylor series ! substitution} Substitution is a bit restricted: Taylor variables can only be replaced by other kernels. There is one exception to this rule: you can always substitute a Taylor variable by an expression that evaluates to a constant. Note that \REDUCE{} will not always be able to determine that an expression is constant: an example is \verb|SIN(ACOS(4))|. \index{Taylor series ! integration} Only simple taylor kernels can be integrated. More complicated expressions that contain Taylor kernels as parts of themselves are automatically converted into a standard representation by means of the TAYLORTOSTANDARD operator. In this case a suitable warning is printed. \index{Taylor series ! reversion} It is possible to revert a Taylor series of a function $f$, i.e., to compute the first terms of the expansion of the inverse of $f$ from the expansion of $f$. This is done by the operator \hspace*{2em} {\tt TAYLORREVERT}(EXP:{\em exprn},OLDVAR:{\em kernel}, NEWVAR:{\em kernel}):{\em exprn} EXP must evaluate to a Taylor kernel with OLDVAR being one of its expansion variables. Example: \begin{verbatim} taylor (u - u**2, u, 0, 5); taylorrevert (ws, u, x); \end{verbatim} This packages introduces a number of new switches: \begin{itemize} \index{TAYLORAUTOCOMBINE switch} \item If you set \verb|TAYLORAUTOCOMBINE| to \verb|ON| \REDUCE{} automatically combines Taylor expressions during the simplification process. This is equivalent to applying \verb|TAYLORCOMBINE| to every expression that contains Taylor kernels. Default is \verb|OFF|. \index{TAYLORAUTOEXPAND switch} \item \verb|TAYLORAUTOEXPAND| makes Taylor expressions ``contagious'' in the sense that \verb|TAYLORCOMBINE| tries to Taylor expand all non-Taylor subexpressions and to combine the result with the rest. Default is \verb|OFF|. \index{TAYLORKEEPORIGINAL switch} \item \verb|TAYLORKEEPORIGINAL|, if set to \verb|ON|, forces the package to keep the original expression, i.e.\ the expression that was Taylor expanded. All operations performed on the Taylor kernels are also applied to this expression which can be recovered using the operator \verb|TAYLORORIGINAL|. Default is \verb|OFF|. \index{TAYLORPRINTORDER switch} \item \verb|TAYLORPRINTORDER|, if set to \verb|ON|, causes the remainder to be printed in big-$O$ notation. Otherwise, three dots are printed. Default is \verb|ON|. \index{VERBOSELOAD switch} \item There is also the switch \verb|VERBOSELOAD|. If it is set to \verb|ON| \REDUCE{} will print some information when the Taylor package is loaded. This switch is already present in \PSL{} systems. Default is \verb|OFF|. \end{itemize} \index{defaults ! TAYLOR package} \section{Caveats} \index{caveats ! TAYLOR package} \verb|TAYLOR| does not always detect non-analytical expressions in its first argument. In this case a wrong result will be given that depends on the order of Taylor variables in the call to \verb|TAYLOR|. An example for this behavior is given by the function $xy/(x+y)$ that is not analytical in the neighborhood of $(x,y) = (0,0)$: Trying to calculate \begin{verbatim} taylor(x*y/(x+y),x,0,2,y,0,2); \end{verbatim} we get as result $X-X^{2}/Y$. The reason for this is as follows: \verb|TAYLOR| first expands it with respect to $X$ about $0$ up to order $2$ giving $X - X^{2}/Y$. This has only a simple pole in $Y$ at $0$ and is therefore returned as result. If we interchange \verb|X| and \verb|Y| in the call to \verb|TAYLOR| they are also interchanged in the result. At the moment I don't know a general method to detect non-analytical expressions in the argument to \verb|TAYLOR|. Note that it is not generally possible to apply the standard \REDUCE{} operators to a Taylor kernel. For example, \verb|PART|, \verb|COEFF|, or \verb|COEFFN| cannot be used. Instead, the expression at hand has to be converted to standard form first using the \verb|TAYLORTOSTANDARD| operator. \section{Warnings and error messages} \index{errors ! TAYLOR package} \begin{itemize} \item \verb|Branch point detected in ...|\\ This occurs if you take a rational power of a Taylor kernel and raising the lowest order term of the kernel to this power yields a non analytical term (i.e.\ a fractional power). \item \verb|Cannot expand further... truncation done|\\ You will get this warning if you try to expand a Taylor kernel to a higher order. \item \verb|Converting Taylor kernels to standard representation|\\ This warning appears if you try to integrate an expression that contains Taylor kernels. \item \verb|Error during expansion (possible singularity)|\\ The expression you are trying to expand caused an error. As far as I know this can only happen if it contains a function with a pole or an essential singularity at the expansion point. (But one can never be sure.) \item \verb|Essential singularity in ...|\\ An essential singularity was detected while applying a special function to a Taylor kernel. This error occurs, for example, if you try to take the logarithm of a Taylor kernel that starts with a negative power in one of its variables, i.e.\ that has a pole at the expansion point. \item \verb|Expansion point lies on branch cut in ...|\\ The only functions with branch cuts this package knows of are (natural) logarithm, inverse circular and hyperbolic tangent and cotangent. The branch cut of the logarithm is assumed to lie on the negative real axis. Those of the arc tangent and arc cotangent functions are chosen to be compatible with this: both have essential singularities at the points $\pm i$. The branch cut of arc tangent is the straight line along the imaginary axis connecting $+1$ to $-1$ going through $\infty$ whereas that of arc cotangent goes through the origin. Consequently, the branch cut of the inverse hyperbolic tangent resp.\ cotangent lies on the real axis and goes from $-1$ to $+1$, that of the latter across $0$, the other across $\infty$. The error message can currently only appear when you try to calculate the inverse tangent or cotangent of a Taylor kernel that starts with a negative degree. The case of a logarithm of a Taylor kernel whose constant term is a negative real number is not caught since it is difficult to detect this in general. \item \verb|Integration of Taylor kernel yields non-analytical term|\\ Since it is assumed that a Taylor kernel can be integrated term-wise to yield another Taylor kernel, it is an error if a logarithmic term would appear in the result. \item \verb|Not a unity in ...|\\ This will happen if you try to divide by or take the logarithm of a Taylor series whose constant term vanishes. \item \verb|Not implemented yet (...)|\\ Sorry, but I haven't had the time to implement this feature. Tell me if you really need it, maybe I have already an improved version of the package. \item \verb|Substitution of dependent variables ...|\\ You tried to substitute a variable that is already present in the Taylor kernel or on which one of the Taylor variables depend. \item \verb|Taylor kernel doesn't have an original part|\\ \ttindex{TAYLORORIGINAL} \ttindex{TAYLORKEEPORIGINAL} The Taylor kernel upon which you try to use \verb|TAYLORORIGINAL| was created with the switch \verb|TAYLORKEEPORIGINAL| set to \verb|OFF| and does therefore not keep the original expression. \item \verb|Wrong number of arguments (TAYLOR)|\\ You try to use the operator \verb|TAYLOR| with a wrong number of arguments. \item \verb|Zero divisor in Taylor substitution|\\ That's exactly what the message says. As an example consider the case of a Taylor kernel containing the term \verb|1/x| and you try to substitute \verb|x| by \verb|0|. \item \verb|... invalid as kernel|\\ You tried to expand with respect to an expression that is not a kernel. \item \verb|... invalid as order of expansion|\\ The order parameter you gave to \verb|TAYLOR| is not an integer. \item \verb|... invalid as Taylor kernel|\\ \ttindex{TAYLORORIGINAL} \ttindex{TAYLORTEMPLATE} You tried to apply \verb|TAYLORORIGINAL| or \verb|TAYLORTEMPLATE| to an expression that is not a Taylor kernel. \item \verb|... invalid as Taylor variable|\\ You tried to substitute a Taylor variable by an expression that is not a kernel. \item \verb|... invalid as value of TaylorPrintTerms|\\ \ttindex{TAYLORPRINTTERMS} You have assigned an invalid value to \verb|TAYLORPRINTTERMS|. Allowed values are: an integer or the special identifier \verb|ALL|. \item \verb|TAYLOR PACKAGE (...): this can't happen ...|\\ This message shows that an internal inconsistency was detected. This is not your fault, at least as long as you did not try to work with the internal data structures of \REDUCE. Send input and output to me, together with the version information that is printed out. \end{itemize} \section{Comparison to other packages} At the moment there is only one \REDUCE{} package that I know of: the truncated power series package by Alan Barnes and Julian Padget. In my opinion there are two major differences: \begin{itemize} \item The interface. They use the domain mechanism for their power series, I decided to invent a special kind of kernel. Both approaches have advantages and disadvantages: with domain modes, it is easier to do certain things automatically, e.g., conversions. \item The concept of a truncated series. Their idea is to remember the original expression and to compute more coefficients when more of them are needed. My approach is to truncate at a certain order and forget how the unexpanded expression looked like. I think that their method is more widely usable, whereas mine is more efficient when you know in advance exactly how many terms you need. \end{itemize} \MACSYMA{} has Taylor and power series packages. I don't know much about the general power series package but the Taylor package has some features that are still lacking here, e.g., correct treatment of known essential singularities. In \MACSYMA{} a Taylor series is a special object, a sort of extended rational expression recognized by all simplification functions. They also have a better user interface. E.g., you may define the Taylor expansion of an unknown function. \Mathematica's \verb|series| function can only handle power series of one variable. However, it is better in its handling of singularities. \end{document} |
Added r34.1/doc/tps.tex version [f9c539ba50].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | \documentstyle[11pt,reduce]{article} \title{Truncated Power Series} \date{} \author{Alan Barnes \\ Dept. of Computer Science and Applied Mathematics \\ Aston University, Aston Triangle, \\ Birmingham B4 7ET \\ GREAT BRITAIN \\ Email: barnesa@kirk.aston.ac.uk \\[0.1in] and \\[0.1in] Julian Padget \\ School of Mathematics, University of Bath \\ Claverton Down, Bath, BA2 7AY \\ GREAT BRITAIN \\ Email: jap@maths.bath.ac.uk} \begin{document} \maketitle \index{power series} \index{truncated power series} \index{Barnes, Alan} \index{Padget, Julian} \section{Introduction} \index{Laurent series expansions} This package implements formal Laurent series expansions in one variable using the domain mechanism of REDUCE. This means that power series objects can be added, multiplied, differentiated etc. like other first class objects in the system. A lazy evaluation scheme is used in the package and thus terms of the series are not evaluated until they are required for printing or for use in calculating terms in other power series. The series are extendible giving the user the impression that the full infinite series is being manipulated. The errors that can sometimes occur using series that are truncated at some fixed depth (for example when a term in the required series depends on terms of an intermediate series beyond the truncation depth) are thus avoided. Below we give a brief description of the operators available in the power series package together with some examples of their use. \subsection{PS Operator} Syntax: \noindent{\tt PS}(EXPRN:{\em algebraic},DEPVAR:{\em kernel},ABOUT:{\em algebraic}):{\em ps object} \index{PS operator} The {\tt PS} operator returns a power series object (a tagged domain element) representing the univariate formal power series expansion of EXPRN with respect to the dependent variable DEPVAR about the expansion point ABOUT. EXPRN may itself contain power series objects. The algebraic expression ABOUT should simplify to an expression which is independent of the dependent variable DEPVAR, otherwise an error will result. If ABOUT is the identifier {\tt INFINITY} then the power series expansion about DEPVAR = $\infty$ is obtained in ascending powers of 1/DEPVAR. \index{PSEXPLIM operator} If the command is terminated by a semi-colon, a power series object representing EXPRN is compiled and then a number of terms of the power series expansion are evaluated and printed. The expansion is carried out as far as the value specified by {\tt PSEXPLIM}. If, subsequently, the value of {\tt PSEXPLIM} is increased, sufficient information is stored in the power series object to enable the additional terms to be calculated without recalculating the terms already obtained. If the command is terminated by a dollar symbol, a power series object is compiled, but at most one term is calculated at this stage. If the function has a pole at the expansion point then the correct Laurent series expansion will be produced. \noindent The following examples are valid uses of {\tt PS}: \begin{verbatim} psexplim 6; ps(log x,x,1); ps(e**(sin x),x,0); ps(x/(1+x),x,infinity); ps(sin x/(1-cos x),x,0); \end{verbatim} \index{power series ! of user defined function} New user-defined functions may be expanded provided the user provides LET rules giving \begin{enumerate} \item the value of the function at the expansion point \item a differentiation rule for the new function. \end{enumerate} \noindent For example \begin{verbatim} operator sech; forall x let df(sech x,x)= - sech x * tanh x; let sech 0 = 1; ps(sech(x**2),x,0); \end{verbatim} \index{power series ! of integral} The power series expansion of an integral may also be obtained (even if REDUCE cannot evaluate the integral in closed form). An example of this is \begin{verbatim} ps(int(e**x/x,x),x,1); \end{verbatim} Note that if the integration variable is the same as the expansion variable then REDUCE's integration package is not called; if on the other hand the two variables are different then the integrator is called to integrate each of the coefficients in the power series expansion of the integrand. The constant of integration is zero by default. If another value is desired, then the shared variable {\tt PSINTCONST} should be set to required value. \index{PSINTCONST (shared)} For example in algebraic mode \begin{verbatim} psintconst:=a**2; \end{verbatim} would set the value of this constant to be (the value of) {\tt A**2}. The setting of this constant has no effect on the value returned by the REDUCE integrator. If the expansion and integration variables are the same and {\tt PSINTCONST} depends on this variable an error results. \subsection{PSEXPLIM Operator} \index{PSEXPLIM Operator} Syntax: \hspace*{2em} {\tt PSEXPLIM}(UPTO:{\em integer}):{\em integer} \hspace*{4em} or \hspace*{2em} {\tt PSEXPLIM}():{\em integer} Calling this operator sets an internal variable of the TPS package to the value of UPTO (which should evaluate to an integer). The value returned is the previous value of this variable. The default value is six. If {\tt PSEXPLIM} is called with no argument, the current value for the expansion limit is returned. \subsection{PSORDLIM Operator} \index{PSORDLIM operator} Syntax: \hspace*{2em} {\tt PSORDLIM}(UPTO:{\em integer}):{\em integer} \hspace*{4em} or \hspace*{2em} {\tt PSORDLIM}():{\em integer} An internal variable is set to the value of {\tt UPTO} (which should evaluate to an integer). The value returned is the previous value of the variable. The default value is 15. If {\tt PSORDLIM} is called with no argument, the current value is returned. The significance of this control is that the system attempts to find the order of the power series required, that is the order is the degree of the first non-zero term in the power series. If the order is greater than the value of this variable an error message is given and the computation aborts. This prevents infinite loops in examples such as \begin{verbatim} ps(1 - (sin x)**2 - (cos x)**2,x,0); \end{verbatim} where the expression being expanded is identically zero, but is not recognized as such by REDUCE. \subsection{PSTERM Operator} \index{PSTERM operator} Syntax: \hspace*{2em} {\tt PSTERM}(TPS:{\em power series object},NTH:{\em integer}):{\em algebraic} The operator {\tt PSTERM} returns the NTH term of the existing power series object TPS. If NTH does not evaluate to an integer or TPS to a power series object an error results. It should be noted that an integer is treated as a power series. \subsection{PSORDER Operator} \index{PSORDER operator} Syntax: \hspace*{2em} {\tt PSORDER}(TPS:{\em power series object}):{\em integer} The operator {\tt PSORDER} returns the order, that is the degree of the first non-zero term, of the power series object TPS. TPS should evaluate to a power series object or an error results. If TPS is zero, the identifier {\tt UNDEFINED} is returned. \subsection{PSSETORDER Operator} \index{PSSETORDER operator} Syntax: \hspace*{2em} {\tt PSSETORDER}(TPS:{\em power series object}, ORD:{\em integer}):{\em integer} The operator {\tt PSSETORDER} sets the order of the power series TPS to the value ORD, which should evaluate to an integer. If TPS does not evaluate to a power series object, then an error occurs. The value returned by this operator is the previous order of TPS, or 0 if the order of TPS was undefined. This operator is useful for setting the order of the power series of a function defined by a differential equation in cases where the power series package is inadequate to determine the order automatically. \subsection{PSDEPVAR Operator} \index{PSDEPVAR operator} Syntax: \hspace*{2em} {\tt PSDEPVAR}(TPS:{\em power series object}):{\em identifier} The operator {\tt PSDEPVAR} returns the expansion variable of the power series object TPS. TPS should evaluate to a power series object or an integer, otherwise an error results. If TPS is an integer, the identifier {\tt UNDEFINED} is returned. \subsection{PSEXPANSIONPT operator} \index{PSEXPANSIONPT operator} Syntax: \hspace*{2em} {\tt PSEXPANSIONPT}(TPS:{\em power series object}):{\em algebraic} The operator {\tt PSEXPANSIONPT} returns the expansion point of the power series object TPS. TPS should evaluate to a power series object or an integer, otherwise an error results. If TPS is integer, the identifier {\tt UNDEFINED} is returned. If the expansion is about infinity, the identifier {\tt INFINITY} is returned. \subsection{PSFUNCTION Operator} \index{PSFUNCTION operator} Syntax: \hspace*{2em} {\tt PSFUNCTION}(TPS:{\em power series object}):{\em algebraic} The operator {\tt PSFUNCTION} returns the function whose expansion gave rise to the power series object TPS. TPS should evaluate to a power series object or an integer, otherwise an error results. \subsection{PSCHANGEVAR Operator} \index{PSCHANGEVAR operator} Syntax: \hspace*{2em} {\tt PSCHANGEVAR}(TPS:{\em power series object}, X:{\em kernel}):{\em power series object} The operator {\tt PSCHANGEVAR} changes the dependent variable of the power series object TPS to the variable X. TPS should evaluate to a power series object and X to a kernel, otherwise an error results. Also X should not appear as a parameter in TPS. The power series with the new dependent variable is returned. \subsection{PSREVERSE Operator} \index{PSREVERSE operator} Syntax: \hspace*{2em} {\tt PSREVERSE}(TPS:{\em power series object}):{\em power series} Power series reversion. The power series TPS is functionally inverted. Four cases arise: \begin{enumerate} \item If the order of the series is 1, then the expansion point of the inverted series is 0. \item If the order is 0 {\em and} if the first order term in TPS is non-zero, then the expansion point of the inverted series is taken to be the coefficient of the zeroth order term in TPS. \item If the order is -1 the expansion point of the inverted series is the point at infinity. In all other cases a REDUCE error is reported because the series cannot be inverted as a power series. Puiseux \index{Puiseux expansion} expansion would be required to handle these cases. \item If the expansion point of TPS is finite it becomes the zeroth order term in the inverted series. For expansion about 0 or the point at infinity the order of the inverted series is one. \end{enumerate} If TPS is not a power series object after evaluation an error results. \noindent Here are some examples: \begin{verbatim} ps(sin x,x,0); psreverse(ws); % produces series for asin x about x=0. ps(exp x,x,0); psreverse ws; % produces series for log x about x=1. ps(sin(1/x),x,infinity); psreverse(ws); % produces series for 1/asin(x) about x=0. \end{verbatim} \subsection{PSCOMPOSE Operator} \index{PSCOMPOSE operator} Syntax: \hspace*{2em} {\tt PSCOMPOSE}(TPS1:{\em power series}, TPS2:{\em power series}):{\em power series} \index{power series ! composition} {\tt PSCOMPOSE} performs power series composition. The power series TPS1 and TPS2 are functionally composed. That is to say that TPS2 is substituted for the expansion variable in TPS1 and the result expressed as a power series. The dependent variable and expansion point of the result coincide with those of TPS2. The following conditions apply to power series composition: \begin{enumerate} \item If the expansion point of TPS1 is 0 then the order of the TPS2 must be at least 1. \item If the expansion point of TPS1 is finite, it should coincide with the coefficient of the zeroth order term in TPS2. The order of TPS2 should also be non-negative in this case. \item If the expansion point of TPS1 is the point at infinity then the order of TPS2 must be less than or equal to -1. \end{enumerate} If these conditions do not hold the series cannot be composed (with the current algorithm terms of the inverted series would involve infinite sums) and a REDUCE error occurs. \noindent Examples of power series composition include the following. \begin{verbatim} a:=ps(exp y,y,0); b:=ps(sin x,x,0); pscompose(a,b); % Produces the power series expansion of exp(sin x) % about x=0. a:=ps(exp z,z,1); b:=ps(cos x,x,0); pscompose(a,b); % Produces the power series expansion of exp(cos x) % about x=0. a:=ps(cos(1/x),x,infinity); b:=ps(1/sin x,x,0); pscompose(a,b); % Produces the power series expansion of cos(sin x) % about x=0. \end{verbatim} \subsection{PSSUM Operator} \index{PSSUM operator} Syntax: \begin{tabbing} \hspace*{2em} {\tt PSSUM}(\=J:{\em kernel} = LOWLIM:{\em integer}, COEFF:{\em algebraic}, X:{\em kernel}, \\ \> ABOUT:{\em algebraic}, POWER:{\em algebraic}):{\em power series} \end{tabbing} The formal power series sum for J from LOWLIM to {\tt INFINITY} of \begin{verbatim} COEFF*(X-ABOUT)**POWER \end{verbatim} or if ABOUT is given as {\tt INFINITY} \begin{verbatim} COEFF*(1/X)**POWER \end{verbatim} is constructed and returned. This enables power series whose general term is known to be constructed and manipulated using the other procedures of the power series package. J and X should be distinct simple kernels. The algebraics ABOUT, COEFF and POWER should not depend on the expansion variable X, similarly the algebraic ABOUT should not depend on the summation variable J. The algebraic POWER should be a strictly increasing integer valued function of J for J in the range LOWLIM to {\tt INFINITY}. \begin{verbatim} pssum(n=0,1,x,0,n*n); % Produces the power series summation for n=0 to % infinity of x**(n*n). pssum(m=1,(-1)**(m-1)/(2m-1),y,1,2m-1); % Produces the power series expansion of atan(y-1) % about y=1. pssum(j=1,-1/j,x,infinity,j); % Produces the power series expansion of log(1-1/x) % about the point at infinity. pssum(n=0,1,x,0,2n**2+3n) + pssum(n=1,1,x,0,2n**2-3n); % Produces the power series summation for n=-infinity % to +infinity of x**(2n**2+3n). \end{verbatim} \subsection{Arithmetic Operations} \index{power series ! arithmetic} As power series objects are domain elements they may be combined together in algebraic expressions in algebraic mode of REDUCE in the normal way. For example if A and B are power series objects then the commands such as: \index{+ ! power series} \index{- ! power series} \index{/ ! power series} \index{* ! power series} \index{** ! power series} \begin{verbatim} a*b; a**2+b**2; \end{verbatim} will produce power series objects representing the product and the sum of the squares of the power series objects A and B respectively. \subsection{Differentiation} \index{power series ! differentiation} If A is a power series object depending on X then the input {\tt df(a,x);} will produce the power series expansion of the derivative of A with respect to X. \section{Restrictions and Known Bugs} If A and B are power series objects and X is a variable which evaluates to itself then currently expressions such as {\tt a/b} and {\tt a*x} do not evaluate to a single power series object (although the results are in each case formally valid). Instead use {\tt ps(a/b,x,0)} and {\tt ps(a*x,x,0)} {\em etc.}. The failure of the system to simplify quotients to a single power series is due to an infelicity in the REDUCE simplifier which will be corrected in future releases of REDUCE. Similarly expressions such as {\tt sin(A)} where {\tt A} is a PS object currently will not be expanded. For example: \begin{verbatim} a:=ps(1/(1+x),x,0); b:=sin a; \end{verbatim} will not expand {\tt sin(1/(1+x))} as a power series. In fact \begin{verbatim} SIN(1 - X + X**2 - X**3 + .....) \end{verbatim} will be returned. However, \begin{verbatim} b:=ps(sin(a),x,0); \end{verbatim} or \begin{verbatim} b:=ps(sin(1/(1+x)),x,0); \end{verbatim} should work as intended. The handling of functions with essential singularities is currently erratic: usually an error message \hspace*{2em} {\tt ***** Essential Singularity} or \hspace*{2em} {\tt ***** Logarithmic Singularity} occurs but occasionally a division by zero error or some drastic error like (for PSL) binding stack overflow may occur. Mixed mode arithmetic of power series objects with other domain elements is quite restricted: only integers and floats can currently be converted to power series objects. The printing of power series currently leaves something to be desired: often line-breaks appear in the middle of terms. There is no simple way to write the results of power series calculation to a file and read them back into REDUCE at a later stage. \end{document} |
Added r34.1/lib/Makefile version [fbdfc79beb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # # Makefile for REDUCE User Contributed Library (PSL Version) # # Author: James H. Davenport <jhd@maths.bath.ac.uk>. # # Modified by: Anthony C. Hearn. # # This Makefile may be used to build fast loading versions of all the # PSL REDUCE User Contributed Library packages, or any particular # package. It assumes that the relevant source files are in the # $reduce/lib directory. It is specific to PSL, and of course those # systems (e.g. UNIX) that support a make mechanism. However, it can # be easily used with other systems with a make facility once a # suitable mkfasl script has been written. REDUCE= /reduce FASL = b BINDIR= $(REDUCE)/fasl SRCDIR= $(REDUCE)/lib TSTDIR= $(REDUCE)/lib MKFASL= $(REDUCE)/util/mkfasl PACKAGES= assist camal changevar cvit desir fide gnuplot laplace \ linineq numeric physop pm reacteqn reset rlfi showrules \ symmetry tri wu UNCOMPILEDPACKAGES= odeex TSTPACKAGES= assist camal changevar cvit desir fide laplace linineq \ numeric physop pmrules reacteqn rlfi symmetry tri wu all: $(PACKAGES) assist: $(BINDIR)/assist.$(FASL) $(BINDIR)/assist.$(FASL): $(SRCDIR)/assist.red $(MKFASL) assist lib camal: $(BINDIR)/camal.$(FASL) $(BINDIR)/camal.$(FASL): $(SRCDIR)/camal.red $(MKFASL) camal lib changevar: $(BINDIR)/changevar.$(FASL) $(BINDIR)/changevar.$(FASL): $(SRCDIR)/changevar.red $(MKFASL) changevar lib cvit: $(BINDIR)/cvit.$(FASL) $(BINDIR)/cvit.$(FASL): $(SRCDIR)/cvit.red $(MKFASL) cvit lib desir: $(BINDIR)/desir.$(FASL) $(BINDIR)/desir.$(FASL): $(SRCDIR)/desir.red $(MKFASL) desir lib fide: $(BINDIR)/fide1.$(FASL) $(BINDIR)/fide.$(FASL) $(BINDIR)/fide1.$(FASL): $(SRCDIR)/fide1.red $(MKFASL) fide1 lib $(BINDIR)/fide.$(FASL): $(SRCDIR)/fide.red $(MKFASL) fide lib gnuplot: $(BINDIR)/gnuplot.$(FASL) $(BINDIR)/gnuplot.$(FASL): $(SRCDIR)/gnuplot.red $(MKFASL) gnuplot lib laplace: $(BINDIR)/laplace.$(FASL) $(BINDIR)/laplace.$(FASL): $(SRCDIR)/laplace.red $(MKFASL) laplace lib linineq: $(BINDIR)/linineq.$(FASL) $(BINDIR)/linineq.$(FASL): $(SRCDIR)/linineq.red $(MKFASL) linineq lib numeric: $(BINDIR)/numeric.$(FASL) $(BINDIR)/numeric.$(FASL): $(SRCDIR)/numeric.red $(MKFASL) numeric lib physop: $(BINDIR)/noncom2.$(FASL) $(BINDIR)/physop.$(FASL) $(BINDIR)/noncom2.$(FASL): $(SRCDIR)/noncom2.red $(MKFASL) noncom2 lib $(BINDIR)/physop.$(FASL): $(SRCDIR)/physop.red $(MKFASL) physop lib pm: $(BINDIR)/pm.$(FASL) $(BINDIR)/pmrules.$(FASL) # $(BINDIR)/pmrules2.$(FASL) $(BINDIR)/pm.$(FASL): $(SRCDIR)/pm.red $(MKFASL) pm lib $(BINDIR)/pmrules.$(FASL): $(SRCDIR)/pmrules.red $(MKFASL) pmrules lib # $(BINDIR)/pmrules2.$(FASL): $(SRCDIR)/pmrules2.red # $(MKFASL) pmrules2 lib reacteqn: $(BINDIR)/reacteqn.$(FASL) $(BINDIR)/reacteqn.$(FASL): $(SRCDIR)/reacteqn.red $(MKFASL) reacteqn lib reset: $(BINDIR)/reset.$(FASL) $(BINDIR)/reset.$(FASL): $(SRCDIR)/reset.red $(MKFASL) reset lib rlfi: $(BINDIR)/rlfi.$(FASL) $(BINDIR)/rlfi.$(FASL): $(SRCDIR)/rlfi.red $(MKFASL) rlfi lib showrules: $(BINDIR)/showrules.$(FASL) $(BINDIR)/showrules.$(FASL): $(SRCDIR)/showrules.red $(MKFASL) showrules lib symmetry: $(BINDIR)/symmetry.$(FASL) $(BINDIR)/symmetry.$(FASL): $(SRCDIR)/symmetry.red $(MKFASL) symmetry lib tri: $(BINDIR)/tri.$(FASL) $(BINDIR)/tri.$(FASL): $(SRCDIR)/tri.red $(MKFASL) tri lib wu: $(BINDIR)/wu.$(FASL) $(BINDIR)/wu.$(FASL): $(SRCDIR)/wu.red $(MKFASL) wu lib test: $(PACKAGES) for i in $(TSTPACKAGES) ; do \ rm -f $(REDUCE)/log/$$i.log ; \ echo \ 'load_package '$$i';on errcont;in"'$(TSTDIR)/$$i'.tst";showtime;bye;' \ | reduce > $(REDUCE)/log/$$i.log ; \ done check: $(PACKAGES) - for i in $(TSTPACKAGES) ; do \ echo 'comparing '$$i'...' ; \ diff $(REDUCE)/log/$$i.log $(TSTDIR) ; \ done |
Added r34.1/lib/Makefile.tmp version [208266a87d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # # Makefile for REDUCE User Contributed Library (PSL Version) # # Author: James H. Davenport <jhd@maths.bath.ac.uk>. # # Modified by: Anthony C. Hearn. # # This Makefile may be used to build fast loading versions of all the # PSL REDUCE User Contributed Library packages, or any particular # package. It assumes that the relevant source files are in the # $reduce/lib directory. It is specific to PSL, and of course those # systems (e.g. UNIX) that support a make mechanism. However, it can # be easily used with other systems with a make facility once a # suitable mkfasl script has been written. REDUCE= /tresor/dagobert/cons/reduce3.4.1/dec3100 FASL = b BINDIR= $(REDUCE)/fasl SRCDIR= $(REDUCE)/lib TSTDIR= $(REDUCE)/lib MKFASL= $(REDUCE)/util/mkfasl PACKAGES= assist camal changevar cvit desir fide gnuplot laplace \ linineq numeric physop pm reacteqn reset rlfi showrules \ symmetry tri wu UNCOMPILEDPACKAGES= odeex TSTPACKAGES= assist camal changevar cvit desir fide laplace linineq \ numeric physop pmrules reacteqn rlfi symmetry tri wu all: $(PACKAGES) assist: $(BINDIR)/assist.$(FASL) $(BINDIR)/assist.$(FASL): $(SRCDIR)/assist.red $(MKFASL) assist lib camal: $(BINDIR)/camal.$(FASL) $(BINDIR)/camal.$(FASL): $(SRCDIR)/camal.red $(MKFASL) camal lib changevar: $(BINDIR)/changevar.$(FASL) $(BINDIR)/changevar.$(FASL): $(SRCDIR)/changevar.red $(MKFASL) changevar lib cvit: $(BINDIR)/cvit.$(FASL) $(BINDIR)/cvit.$(FASL): $(SRCDIR)/cvit.red $(MKFASL) cvit lib desir: $(BINDIR)/desir.$(FASL) $(BINDIR)/desir.$(FASL): $(SRCDIR)/desir.red $(MKFASL) desir lib fide: $(BINDIR)/fide1.$(FASL) $(BINDIR)/fide.$(FASL) $(BINDIR)/fide1.$(FASL): $(SRCDIR)/fide1.red $(MKFASL) fide1 lib $(BINDIR)/fide.$(FASL): $(SRCDIR)/fide.red $(MKFASL) fide lib gnuplot: $(BINDIR)/gnuplot.$(FASL) $(BINDIR)/gnuplot.$(FASL): $(SRCDIR)/gnuplot.red $(MKFASL) gnuplot lib laplace: $(BINDIR)/laplace.$(FASL) $(BINDIR)/laplace.$(FASL): $(SRCDIR)/laplace.red $(MKFASL) laplace lib linineq: $(BINDIR)/linineq.$(FASL) $(BINDIR)/linineq.$(FASL): $(SRCDIR)/linineq.red $(MKFASL) linineq lib numeric: $(BINDIR)/numeric.$(FASL) $(BINDIR)/numeric.$(FASL): $(SRCDIR)/numeric.red $(MKFASL) numeric lib physop: $(BINDIR)/noncom2.$(FASL) $(BINDIR)/physop.$(FASL) $(BINDIR)/noncom2.$(FASL): $(SRCDIR)/noncom2.red $(MKFASL) noncom2 lib $(BINDIR)/physop.$(FASL): $(SRCDIR)/physop.red $(MKFASL) physop lib pm: $(BINDIR)/pm.$(FASL) $(BINDIR)/pmrules.$(FASL) # $(BINDIR)/pmrules2.$(FASL) $(BINDIR)/pm.$(FASL): $(SRCDIR)/pm.red $(MKFASL) pm lib $(BINDIR)/pmrules.$(FASL): $(SRCDIR)/pmrules.red $(MKFASL) pmrules lib # $(BINDIR)/pmrules2.$(FASL): $(SRCDIR)/pmrules2.red # $(MKFASL) pmrules2 lib reacteqn: $(BINDIR)/reacteqn.$(FASL) $(BINDIR)/reacteqn.$(FASL): $(SRCDIR)/reacteqn.red $(MKFASL) reacteqn lib reset: $(BINDIR)/reset.$(FASL) $(BINDIR)/reset.$(FASL): $(SRCDIR)/reset.red $(MKFASL) reset lib rlfi: $(BINDIR)/rlfi.$(FASL) $(BINDIR)/rlfi.$(FASL): $(SRCDIR)/rlfi.red $(MKFASL) rlfi lib showrules: $(BINDIR)/showrules.$(FASL) $(BINDIR)/showrules.$(FASL): $(SRCDIR)/showrules.red $(MKFASL) showrules lib symmetry: $(BINDIR)/symmetry.$(FASL) $(BINDIR)/symmetry.$(FASL): $(SRCDIR)/symmetry.red $(MKFASL) symmetry lib tri: $(BINDIR)/tri.$(FASL) $(BINDIR)/tri.$(FASL): $(SRCDIR)/tri.red $(MKFASL) tri lib wu: $(BINDIR)/wu.$(FASL) $(BINDIR)/wu.$(FASL): $(SRCDIR)/wu.red $(MKFASL) wu lib test: $(PACKAGES) for i in $(TSTPACKAGES) ; do \ rm -f $(REDUCE)/log/$$i.log ; \ echo \ 'load_package '$$i';on errcont;in"'$(TSTDIR)/$$i'.tst";showtime;bye;' \ | reduce > $(REDUCE)/log/$$i.log ; \ done check: $(PACKAGES) - for i in $(TSTPACKAGES) ; do \ echo 'comparing '$$i'...' ; \ diff $(REDUCE)/log/$$i.log $(TSTDIR) ; \ done |
Added r34.1/lib/README version [0d8fe58f04].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | REDUCE USER CONTRIBUTED LIBRARY 15 July 1992 The files in this directory comprise a library of contributions from many REDUCE users. The relevant members first appeared in the REDUCE Network Library. They are collected here as a service to REDUCE users, and no responsibility can be taken regarding them. In particular, any questions about any of the files should be directed to the relevant author(s). All code in this library has been tested with REDUCE 3.4, but may require modifications to work in later releases. Any updates will appear in later releases of this library, or in the REDUCE Network Library. For an information about this library, send the message "help" to reduce-netlib@rand.org, reduce-netlib@can.nl or redlib@elib.zib-berlin.de. A prototypical Makefile is included for those users whose systems provide this facility (e.g., UNIX-based systems). Although this makefile is specific to PSL- and Common Lisp-based systems, it should be fairly easy to modify for other versions. The use of this Makefile should be self-explanatory. In particular, "make all" will make fast loading versions of all relevant files in that directory, and "make <package>" will make a fast loading version of the package named <package>. The Network Library is divided into sublibraries which have a particular theme (such as "chemistry"). The sublibraries are then divided into members, which are individual files with names of the form <name>.<type>. This particular organization is not preserved here, since all members are in a single directory. The table of contents of the current library organized in the original hierarchical manner is: ARITH numeric.red - Source for numerical algorithm package numeric.tst - Test file for numerical algorithm package numeric.tex - Document file for numerical algorithm package numeric.log - Log of test run for numerical algorithm package CHEMISTRY reacteqn.doc - documentation for reaction equation system package reacteqn.log - log of test file for reaction equation system package reacteqn.red - source for reaction equation system package reacteqn.tst - test file for reaction equation system package DE (Differential Equations) changevar.log - Log of test file for Changevar - a package for changing variables in differential equations changevar.red - Source for Changevar package changevar.tex - Tex version of document for Changevar package changevar.tst - Test file for Changevar package desir.doc - Document for DESIR package desir.log - Log of UNIX script for testing DESIR package desir.red - Source for DESIR package desir.tst - Test file for DESIR package. This should be used with the UNIX script tstdesir, or modified for the local system tstdesir - UNIX script for testing DESIR package fide.doc - Document for FIDE package for the automation of the finite difference method for PDE's fide.log - log of run of FIDE package test file fide1.red - part 1 of source file for FIDE package fide.red - part 2 of source file for FIDE package fide.tst - Test file for FIDE package odeex.red - Examples of solving ODE's using Taylor series GRAPHICS gnuplot.red - Source for REDUCE GNUPLOT package gnuplot.tst - Test file for REDUCE GNUPLOT package gnuplot.tex - Document for REDUCE GNUPLOT package GROEBNER wu.log - log of test file for Wu's algorithm package wu.red - source for Wu's algorithm package wu.tex - LaTeX version of document for Wu's algorithm package (there is no plain text version) wu.tst - test file for Wu's algorithm package LAPLACE laplace.red - source for Laplace and Inverse Laplace Transforms laplace.doc - document for Laplace and Inverse Laplace Transforms laplace.tst - Test file for Laplace and Inverse Laplace Transforms laplace.log - Log of test file for Laplace and Inverse Laplace Transforms MISC reset.red - code for resetting REDUCE to initial state PHYSICS cvit.red - source for CVIT package for the computation of Dirac gamma matrix expressions by the Cvitanovic-Kennedy algorithm cvit.doc - document for CVIT package cvit.log - log of running test file for CVIT package cvit.tst - test file for CVIT package physop.red - source file for PHYSOP package for operator calculus in physics. This REQUIRES the NONCOM2 package described below physop.log - log of running test file for PHYSOP package physop.tex - LaTeX version of document for PHYSOP package physop.tst - Test file for PHYSOP package noncom2.red - source for noncommutativity package NONCOM2 needed by PHYSOP package symmetry.log - Log of test run for symmetry package symmetry.red - Part 1 of source for symmetry package (all parts are needed) symdata1.red - Part 2 of source for symmetry package symdata2.red - Part 3 of source for symmetry package symmetry.tex - Document file for symmetry package symmetry.tst - Log of test run for symmetry package RULES pm.red - Source of the PM pattern matcher pmrules.red - Basic rules for PM pattern matcher NOTE that pm.red is loaded by this file pmrules2.red - More rules for PM pattern matcher, but not thoroughly tested. NOTE that pm.red and pmrules.red must be loaded before this file pm.doc - Document for the PM pattern matcher pmrules.tst - Test file for the PM pattern matcher and basic rules pmrules.log - Log of test file for PM pattern matcher and basic rules SERIES camal.red - Source for CAMAL package for celestial mechanics camal.bib - Bibliography file for CAMAL package document camal.log - Log of running test file for CAMAL package camal.tex - LaTeX version of document for CAMAL package camal.tst - Test file for CAMAL package SOLVE linineq.log - Log of test file for the linineq package for solving sets of linear inequalities linineq.red - Source for linineq package linineq.tex - LaTex version of document for linineq package linineq.tst - Test file for linineq package TEX reduce.tex - TeX file to be used together with output from the TRI package for producing TeX output redwidth.tex - TeX file for determining item widths tri.latex - LaTeX form of document for TRI package tri.red - REDUCE source code for TRI package tri.tex - TeX form of document for TRI package tri.tst - Test file for TRI package; this produces a file tritst.tex, which can be compared with tritstx.tex, and then processed by "tex tritest" tri.log - Log from run of TRI test file tritest.tex - TeX file for processing output of tri.tst tritstx.tex - Normal output from running test file for TRI package rlfi.doc - Document for the RLFI package for producing LaTeX output rlfi.red - REDUCE source for RLFI package rlfi.log - Log from run of RLFI test file rlfi.tst - Test file for RLFI package UTIL assist.doc - Document for ASSIST utility package assist.log - Log of test file for ASSIST utility package assist.red - Source for ASSIST utility package assist.tst - Test file for ASSIST utility package showrules.red - Source for a command to show rules for an operator (no other documentation) |
Added r34.1/lib/assist.doc version [8fce5c193a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ****** ASSIST ****** A file of additional functions to REDUCE which raise the programming power of the user in a broad range of applications. Author : H. Caprasse . Date : 15/09/1991 ------ ---- Address : Physics Institute, B5 , Sart-Tilman, B4000 Liege, Belgium. -------- Electronic Mail : <u21400L@bliulg11.bitnet> or <u214001@vm1.ulg.ac.be> --------------- ASSIST arose from the use of REDUCE in many different applications. It contains functions which are often needed. Many of them give assistance to the user allowing him to produce a more straightforward and a more efficient code for its own applications. Others give him more control on the environment. Some of them allows him to introduce PROPERTIES and FLAGS within the algebraic mode. ___________________________________ _________________ NEW FUNCTIONS AVAILABLE ----------------------- Control of SWITCHES : -------------------- SWITCHES SWITCHORG Operations on "lists" AND "bags" : ------------------------------- MKLIST DELETE BAGPROP PUTBAG CLEARBAG BAGP BAGLISTP ALISTP ABAGLISTP LISTBAG FIRST SECOND THIRD REST REVERSE LAST BELAST APPEND CONS LENGTH REMOVE DELETE MEMBER ELMULT PAIR DEPTH INSERT POSITION ASFLIST ASSLIST RESTASLIST SUBSTITUTE REPFIRST REPLAST Operations on SETS : ------------------ MKSET UNION SETP SETDIFF SYMDIFF General purpose functions : ------------------------- MKIDN == INF2 SUP2 ODDP EVENP FOLLOWLINE DETIDNUM RANDOMLIST COMBNUM PERMUTATION COMBINATIONS FUNCVAR IMPLICIT DEPATOM EXPLICIT SIMPLIFY "Properties" and "flags": ----------------------- PUTFLAG PUTPROP DISPLAYPROP DISPLAYFLAG CLEARFLAG CLEARPROP Control statement and control of the environment : NORDP DEPVARP ALATOMP ALKERNP PRECP KORDERLIST REMSYM SHOW SUPPRESS CLEAROP CLEARFUNCTIONS Handling of polynomials : ----------------------- DISTRIBUTE LEADTERM REDEXPR MONOM LOWESTDEG DIVPOL Handling of TRIGONOMETRIC functions : ----------------------------------- TRIGEXPAND HYPEXPAND TRIGREDUCE HYPREDUCE Handling of log's : ----------------- PLUSLOG CONCSUMLOG Handling of n-vectors : SUMVECT MINVECT SCALVECT CROSSVECT MPVECT Handling of matrices : MKIDM BAGLMAT COERCEMAT UNITMAT SUBMAT MATSUBR MATSUBC RMATEXTR RMATEXTC HCONCMAT VCONCMAT TPMAT HERMAT SETELTMAT GETELTMAT __________________ ===== We describe successively these different facilities. CONTROL OF SWITCHES -------------------- Not all switches are included. The ones we have chosen are EXP, DIV, MCD, LCM, EZGCD, GCD, ALLFAC, INTSTR, RAT , RATIONAL, FACTOR, PRECISE, REDUCED, COMPLEX, RATIONALIZE and the new switch DISTRIBUTE. The selection covers all switches which are essential for ALGEBRAIC calculations fashion by the user. The control symbolic variables !*EXP, !*DIV, etc... which have either the value T or the value NIL are available on the level of the algebraic mode so it becomes possible to write conditional statements of the kind IF !*EXP THEN DO ...... IF !*GCD THEN OFF GCD; Two functions SWITCHES; and SWITCHORG; are provided: SWITCHES; gives the ACTUAL STATUS of ALL (selected) switches, SWITCHORG; puts them in the status they have when ENTERING the system (ORiGinal status). The new switch DISTRIBUTE controls the working of some polynomial func- tions which are described below. It allows to put polynomial in a distri- buted form. MANIPULATION OF THE "LIST" STRUCTURE ____________________________________ Some additional functions for list manipulations are provided. i) automatic generation of a LIST : MKLIST n ; n is an INTEGER returns a list of length n with 0 elements. MKLIST(U,n); U is LIST-like, n is an INTEGER returns U if n is LESS than the length of U; otherwise returns a list of length n with the first length U elements equal to the elements of U. and with the n-length U elements equal to 0. ii) direct manipulation of a LIST (apart from FIRST,REST,REVERSE): *** U is a LIST-like quantity. LAST U ; BELAST U ; DEPTH U ; LAST gives the last element of U BELAST gives the list U without the last element, DEPTH returns an INTEGER equal to the number of levels where a list is found if and only if this number is the SAME for each element of U otherwise a message telling the user that U is of UNEQUAL depth is returned. POSITION(x,U); x is anything. returns the POSITION of the first occurrence of x in U or a message if x is not present in U. DELETE(x,U); x is anything. DELETE returns U after the FIRST occurrence of x in U has been deleted. REMOVE(U,n); n is an INTEGER. REMOVE returns a list which is U without the nth. element. If one wants to EXTRACT the nth. element of U instead of using PART one may write U.n; MEMBER(x,U); x is anything. MEMBER returns a non-empty list if x belongs to U and nothing if it this is not the case. It is a BOOLEAN function so one may write IF MEMBER(x,U) then ...... ELMULT(x,U); x is anything. ELMULT return an INTEGER which is the MULTIPLICITY of x inside U. REPFIRST(x,U); REPREST(x,U); x is anything. REPFIRST replaces the first element of U by x and returns the new list. REPREST replaces the rest of U by x and returns the list list(first U,x). INSERT(x,U,n); x is anything, n is an integer. INSERTs x in U at the position n and returns the resulting list. SUBSTITUTE(new,old,U); where "new" is the OBJECT to substitute to the object "old" in U at ALL levels. This function is more elementary than the functions "SUB". It is more efficient but works properly only for atomic "new" and old objects. iii) manipulations of two lists: *** U and V are LIST-like. APPEND(U,V); U.V; APPEND returns a list which is the union of the two lists U and V. "." (dot) returns a list whose first element is the list U and the other elements are the elements of V. PAIR(U,V); PAIR returns a list whose elements are LISTS of TWO ELEMENTS. The nth sublist contains the nth element of U and the nth. element of V. These types of lists are called ASSOCIATION LISTS or ALISTS in the fol- lowing. To test for these type of lists a BOOLEAN function is available ABAGLISTP U; Can ONLY be used in a conditional statement like IF ABAGLISTP U THEN ..... ( this "bizarre" name because it also works for BAGS; see below). iv) functions which apply to ALISTS: *** x is anything, U is an ALIST. ASFIRST(x,U); returns the sublist of U whose FIRST element is x. ASSECOND(x,U); returns the sublist of U whose SECOND element is x. ASLAST(x,U); returns the sublist of U whose LAST element is x. ASREST(V,U); here V is a LIST. returns the sublist of U whose REST is V. In addition to these different functions always gives as output the FIRST occurrence of the appropriate element. There are functions which either return a LIST of elements of U. We describe them now. U is still an ALIST. ASFLIST(x,U); returns ALL the listb-elements of U whose first element are the KEY x. So the returned object is a list of lists. ASSLIST(x,U); acts in the same way as the previous one except that the KEY x is the second element of the list-elements of U. RESTASLIST(V,U); V is a LIST of KEYS. returns a list of the RESTs of the sublists of U associated to each KEY present in V. THE "BAG" TYPE AND ITS ASSOCIATED FUNCTIONS ___________________________________________ In REDUCE 3.4, the LIST structure has a mapping property associated to it and, consistently, cannot be a coefficient in a polynomial. Sometimes, also, one would like to manipulate functions or operators arguments in the same way one manipulates the elements of a list. The BAG structure allows to do such things. The definition: It is a "FLAG" which can be superimposed to the properties of most KERNELS. They keep their own properties but to these are superimposed properties which make them VERY SIMILAR to lists. When the prefix of a kernel gets the flag "BAG" all functions defined for lists (or for sets) become ACTIVE. A detailed description of this structure is given in the article by H. Caprasse and M. Hans in SIGSAM Bulletin, Vol. 19, 46-52 (1985). Here we try to make the use of this notion clear from the des- cription of the action of the various functions available. PUTBAG id1,id2,....idn; where id1,.....idn are identifiers. This functions allows one to give to id1,...,idn the BAG properties. id1,.. ,idn are only restricted NOT to be - the name LIST, - the name of a BOOLEAN function. id1,....,idn may be the - the name of an OPERATOR prefix, - the name of an ordinary function. WHEN AND ONLY WHEN the identifier is not an already defined function does PUTBAG puts on it the property of an OPERATOR PREFIX. CLEARBAG id1,...idn; eliminates the BAG property on id1,...,idn. When an identifier has got the bag property ALL FUNCTIONS previously defined for LISTS (and also subsequently defined for SETS) become ACTIVE. Their actions are the same as for list-like objects except for the following important difference: The NAME of the IDENTIFIER is KEPT by the functions FIRST and LAST. When "appending" two bags the resulting bag gets the name of the FIRST argument bag. So a bag-like identifier can always be considered as an "envelope" suited to contain any objects. These ojects are the arguments of the bag. The possibility to manipulate the arguments as if the bag were a LIST increases the programming capabilities and efficiency in the ALGEBRAIC MODE. The TEST FILE gives several illustrations of the actions of the various functions on bags. Here we stress two cases where it is particularly convenient: An operator function is defined as OP(x):=x**2; OP(x,y):=x*sin(y); The command PUTBAG OP; will allow us to encompass the different definitions trivially. For example AA:=FIRST OP(X,Y,Z); ==> AA:=OP(X) and AA:=AA; ==> AA:=X**2 AA:=REST OP(X,X,Y); ==> AA:=OP(X,Y) and AA:=AA; ==> AA:=X*SIN Y One can wonder why we did not manage to do the two steps together. This is so because in most applications we encountered the evaluation is not to be done IMMEDIATELY. Moreover we want to keep the basic functions very efficient since they are usually applied repeatedly a great number of times. Last but not least, it is not difficult, if necessary, to con- struct a procedure which does so. The second case is when one wants to construct a PROCEDURE with an (a priori) INDETERMINATE number of variables. Then the use of a prefix with the "BAG" flag to capture all variables will allow to do so easily. The package provides a "standard" name for it which is BAG but ANY OTHER NAME can be used after it has been declared a "bag" through PUTBAG. For instance one may write PROCEDURE TRIAL U ; FOR I:=1:SIZE U DO WRITE PART(U,i); When U is BAG(v1,v2,....,vn), SIZE U automatically determines the ACTUAL number of variables (SIZE is another name for LENGTH which is more appropriate when applied to a bag-like object). This possibility is also available if U is a list when one delivers the command LISTARGP TRIAL; But this command forbids the associated mapping property of U. So, it is very convenient to be able to use as U either a list-like or bag-like object using a code which manages to handle both structures. Of course several arguments are allowed one or several of them can be "bags". The example above could be treated also with U being LIST-LIKE. It is important to remember that - a bag can be treated as an ordinary KERNEL so that all ALGEBRAIC operations and simplifications do apply to it. - if the prefix is the one of an already defined function it keeps these properties or can also be given other properties (one may declare BAG to be a SYMMETRIC function for instance). ADDITIONAL FUNCTIONS -------------------- There are several simple functions devoted to the bag manipulations . BAGP x ; BAGLISTP x ; x is anything. They are boolean functions. As such they can only be used in conditional statements. BAGP detects if x is a bag or not . BAGLISTP detects if x is a list or a bag. Coercing functions are KERNLIST U ; U is a bag. KERNLIST transforms a KERNEL into a LIST. This is convenient when the name of the prefix does not matter or if one wants to HIDE temporarily its properties. LISTBAG(U,nb); U is a list, nb is an identifier. LISTBAG transforms a LIST into a BAG whose envelope has the NAME nb. SIZE U ; U is a bag (or a list). As said above it is another name for length givem to indicate that it gives the total number of objects INSIDE the envelope. REMARK: The functions KERNLIST and LISTBAG allow easily to mix list-like and ------ bag-like objects in a given expression. All functions do recognize the differences except that functions which work on association-list or -bag cannot work on MIXED objects. This restriction can be elimina- ted but we have had no motivation to do so. SETS AND BASIC MANIPULATION FUNCTIONS ------------------------------------- These functions apply BOTH to list-like and bag-like objects. MKSET U ; SETP U ; U is a bag or list. MKSET returns a bag or list with each element appearing only ONCE. SETP is a boolean function which recognizes set-like objects. UNION(U,V); INTERSECT(U,V); DIFFSET(U,V); SYMDIFF(U,V); U and V are set-like. All these functions return a SET. The names are self-explanatory. GENERAL PURPOSE FUNCTIONS ------------------------- The list of these functions were already given. They depend either of one or two arguments. We describe some of them only. COMBNUM gives the number of combinations of P objects taken among N objects. PERMUTATIONS U ; U is a bag returns a bag of bags each containing one permutation of the original bag. COMBINATIONS (U,n) ; U is a bag , n is an integer. returns a bag of bags each containing one combination of the original bag FUNCVAR x ; x is any expression . returns the *set* identifiers which are NOT prefix identifiers. The set does NOT contain reserved or constant identifiers. DEPATOM x ; x is an ATOMIC expression. returns a list of identifiers if x has previously been declared to DEPEND on these otherwise returns an empty list. EXPLICIT x ; IMPLICIT x ; These two functions allow one to change smoothly the representation of OPERATORS and FUNCTIONS going from an EXPLICIT to an IMPLICIT representations of these objects. By EXPLICIT representation we mean one in which VARIABLES mus be EXPLICITLY written as in OP(X,Y,F(G)); By IMPLICIT representation we mean one in which VARIABLES dependences are "HIDDEN" as one obtains through the DEPEND command. So the IMPLICIT representation of the object above is OP ; TOGETHER with the command DEPEND OP,X,Y,F(G); One could equivalently call them the CONCRETE and ABSTRACT representations. It is often much better in a calculation to manipulate the abstract represen- tation but then we need functions allowing us to switch easily to the concrete one and vice versa. The function IMPLICIT returns its argument if it is an ATOM and returns the ABSTRACT (or "implicit") representation of its argument if this argument is an OPERATOR (or a FUNCTION). So IMPLICIT OP(X,Y,F(G)); ==> OP IMPLICIT A ; ==> A. The function EXPLICIT must have an argument x which is ALWAYS an ATOM. If this atom is the abstract representation of an OPERATOR (or a FUNCTION) it returns its CONCRETE (or "explicit") representation. So EXPLICIT OP ; ==> OP(X,Y,F(G)) DETIDXNUM x ; where x is any IDENTIFIER This function allows to identify a given variable in a set like A1,A2,....A23,... extracting the number appended to its name. It returns nothing if a variable name terminates by a letter but any integer may be included in the name. For instance DETIDXNUM a1bb23c122 ; ==> 122 The function SET of REDUCE 3.4 is generalized and slightly modified to make it work not only for atomic quantities but also for KERNELS. We have not redefined the function SET but we have created the INFIX function " == " . Suppose one makes the assignment A:=OP(X); then writing A == SIN(X); will assign OP(X) to SIN(X). Finally the function SIMPLIFY which full forces resimplification of an expression is an "emergency" function sometimes helpful to simplify some output of the EXCALC package. "PROPERTIES" AND "FLAGS": ----------------------- One of the important drawbacks of the algebraic mode is the fact that the user has not the possibility to ENDOW objects of flags and properties. The subse- quent functions allow one to do that. If one wants to give a flag or a property to one or a list of IDENTIFIERS one must issue PUTFLAG(idp,<flagname>,T); or PUTFLAG(LIST(idp1,idp2,..),<flagname>,T); PUTPROP(idp,<propname>,<value>,T); or PUTPROP(LIST(idp1,idp2,..),<propname>,<value>,T); The SAME commands must be issued if one wants to ERASE them EXCEPT that T must be replaced by 0. If one wants to DISPLAY the FLAGS or (and) the PROPERTIES of a given IDENTIFIER one must issue the commands DISPLAYFLAG(idp); or (and) DISPLAYPROP(idp,<propname>); We point out that the "DISPLAY" functions do not give access to the property list generated at the level of the source code but ONLY to the properties generated by the PUT(FLAG or PROP) commands i.e. to the properties or flags CREATED BY THE USER. Two additional functions for CLEARING are provided. They are CLEARFLAG A1,A2,...An ; CLEARPROP A1,A2,...An ; where A1..,An are identifiers. They eliminate ALL flags or properties of these. Moreover if one chooses ALL as the UNIQUE argument ALL flags or properties of ALL identifiers are ELIMINATED. CONTROL FUNCTIONS ----------------- Here we describe a certain number of functions which will help the user to CONTROL and BETTER understand the REDUCE environment. A collection of BOOLEAN functions are available. They are ALATOMP x; x is anything. ALKERNP x; x is anything. PRECP(x,y); x,y are ATOMS or printcharacters. DEPVARP(x,V); x is anything, V is an ATOM or a KERNEL. ALATOMP has the value T iff x is an integer or an identifier AFTER it has been evaluated. ALKERNP has the value T iff x is a KERNEL AFTER it has been evaluated. PRECP determines whether the OPERATION x has PRECEDENCE over the OPERATION y. Returns T iff it is the case. DEPVARP returns T iff the expression x depends on V at ANY LEVEL. These functions are ALSO ALGEBRAIC functions. This is very convenient to guide beginners and in particular to make them understand what a KERNEL is. In addition the function STRINGP x ; which determines if x is a string is also available in conditional statements. The next functions allow one to analyze and to CLEAN the environment of REDUCE which is created by the user while he is working INTERACTIVELY. They REMIND the user of the names of identifiers they have introduced IN THE CONSOLE for different purposes and to make PARTIAL CLEARING of them according to their TYPES. There are TWO commands to remember: SHOW and SUPPRESS. They have different arguments which are associated to the different types. So, one can deliver the following commands to DISPLAY the different used-ids: SHOW SCALARS; SHOW LISTS; SHOW MATRICES; SHOW ARRAYS; SHOW VECTORS; (contains vector, index and tvector) SHOW FORMS; SHOW ALL; The argument ALL allows to see all user variables whatever their type. SUPPRESS can be called with the same arguments. It clears ALL ids of the required type and eventually all of them. It must be stressed these functions IGNORE all variables which are not DIRECTLY introduced or manipulated ON THE CONSOLE. For instance variables which are used ONLY in an INPUT FILE. The CLEAR function of the system does not do a complete cleaning of OPERATORS and FUNCTIONS. The following two functions do a more complete cleaning which also takes automatically into account the USER flag and properties that the new functions PUTFLAG and PUTPROP may have introduced. CLEAROP x; x is an OPERATOR do a COMPLETE cleaning of the x property list. CLEARFUNCTIONS A1,A2,...An ; do the same with ALL functions with names A1,A2...An. These are still in an EXPERIMENTAL STAGE . The user should be careful when he uses them since they only avoid to ERASE the PROTECTED functions and most of the functions in the basic code are NOT protected. HANDLING OF POLYNOMIALS : ----------------------- The LOG file gives all necessary explanations here. Two comments are to be made: a. MONOM is very useful since it places automatically of all monoms of a multivariate polynomial in a list. From the result each monom can be manipulated SEPARATELY. Moreover, if one wishes, it becomes trivial to place them in an ARRAY or to put then as elements of a MATRIX. b. LEADTERM and REDEXPR works either on the recursive or on the distributive forms of a polynomial. They give a mean to control simplifications and the swelling of intermediate expressions. The choice of the recursive- or distributive-way of working is made by the user through the command OFF (ON) DISTRIBUTE; HANDLING OF TRIGONOMETRIC FUNCTIONS : ----------------------------------- The LOG file is here self-explanatory. The use of TRIG(HYP)REDUCE followed by the use of TRIG(HYP)EXPAND makes the necessary simplifica- tions for the sum-squared of the trig(hyp)-functions. In these two cases they make the work of the COMPACT. It is not garanteed however that the resulting expression will be the most compact one. HANDLING OF LOG'S : ----------------- PLUSLOG is put for convenience of the user. CONCSUMLOG do the reverse job for any rational expression. Both of them restore the environment in the status it had before their action. BASIC OPERATIONS ON N-DIMENSIONAL (explicit) VECTORS _____________________________________________________ Vectors in EUCLIDEAN space may be represented by list-like or bag-like objects. The components may be "bags" but may NOT be "lists". This is so because one has only defined operations between vectors and NOT between tensors so that the operations at level 1 are ORDINARY algebraic operations. As already said list-like objects may NOT be treated as ordinary kernels while bag-like objects do for the basic operations. Of course one can be much more ambitious and we have indeed been. But in this UTILITY package which must remain of rather small size and UNSPECIALIZED so we confine to the ELEMENTARY cases. We have, with U1,U2 being two BAGS or LISTS with n elements SUMVECT(U1,U2); for the sum of U1 and U2, MINVECT(U1,U2); for the difference of U1 and U2, SCALVECT(U1,U2);for the scalar product. LIMITED to 3-dimensional vectors we have CROSSVECT(U1,U2); for the cross product, MPVECT(U1,U2); for the mixed product. ADDITIONAL FUNCTIONS FOR MATRIX MANIPULATIONS --------------------------------------------- MKIDM(U,J); J is an ATOM. This functions works like MKID except that its argument U is a MATRIX. It is also REQUIRED that Uj be a MATRIX. It allows one to make loops. For instance if U,U1,U2,..U5 are matrices one may write FOR I:=1:5 DO U:=U-MKIDM(U,I); The next functions are COERCION functions i.e. they MAP matrices on BAG-LIKE or LIST-LIKE objects and conversely they generate MATRICES from "bags" or "lists". If U is a MATRIX and id is any identifier COERCEMAT(U,id); COERCEMAT transforms U into a list of lists IFF id is equal to LIST otherwise it transforms it into a bag of bags whose ENVELOPE has the NAME id. If UN is a MATRIX-NAME and bgl is either a bag or a list of DEPTH two the function BAGLMAT(bgl,UN); transforms bgl into a matrix whose name is UN. The transformation is NOT done if UN is ALREADY the name of a previously defined matrix. This is to avoid ACCIDENTAL redefinition of this matrix. Often one needs to construct a UNIT matrix of some dimension. This construction is done by the system thanks to the function UNITMAT M1(n1), M2(n2), .....Mi(ni) ; where M1,...Mi are names of matrices and n1,n2,....ni are INTEGERS representing space dimensions. Submatrices are obtained using the function SUBMAT(U,nr,nc); where nr,nc are the row and column numbers respectively. It gives the submatrix obtained from U deleting the row nr and the column nc. When nr or nc are equal to zero only column nc or row nr is deleted. Two functions allow one to EXTRACT a row or a column. They are MATEXTR(U,VN,nr); MATEXTC(U,VN,nc); U is the matrix, VN is the "VECTOR NAME", nr and nc are integers. If VN is equal to LIST the vector is given as a list otherwise it is given as a BAG. Rows and columns may be SUBSTITUTED using MATSUBR(U,bgl,nr); MATSUBC(U,bgl,nc); The meaning of the variables U,nr,nc is the same as above while bgl is a LIST or a BAG. Of course the LENGTH (or the SIZE) of bgl should be compatible with the dimensions of U. Concatenation of two matrices can be made with HCONCMAT(U,V); VCONCMAT(U,V); the first function concatenates horizontally, the second one concatenates vertically. The tensor product between two matrices is madse by TPMAT(U,V); or U TPMAT V; The hermitian matrix corresponding ti an already defined matrix is created automatically by HERMAT(U,hu); hu becomes the hermitian matrix of U. hu SHOULD be a FREE identifier for HERMAT to work successfully. This is done on purpose to prevent accidental redefinition of an already used used identifier . SETELMAT allows to reset the element (i,j) of a given matrix while GETELTMAT allows to extract the element (i,j). They are useful only when used INSIDE a procedure. |
Added r34.1/lib/assist.log version [bc29b70b65].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | REDUCE 3.4.1, 15-Jul-92 ... 1: (ASSIST) % Tests of Assist Package version 1.1 . % Valid only with REDUCE 3.4 % DATE : 15 September 1991. % Author: H. Caprasse <u214001@bliulg11.bitnet>. % <u214001@vm1.ulg.ac.be> %--------------------------------------------------------------------- load assist; showtime; Time: 17 ms % 1. TESTS OF THE SWITCH CONTROL FUNCTIONS : ; switches; **** exp:=T ............. allfac:= T **** **** ezgcd:=NIL ......... gcd:= NIL **** **** mcd:=T ............. lcm:= T **** **** div:=NIL ........... rat:= NIL **** **** intstr:=NIL ........ rational:= NIL **** **** precise:=NIL ....... reduced:= NIL **** **** complex:=NIL ....... rationalize:= NIL **** **** factor:= NIL ....... distribute:= NIL *** switchorg; switches; **** exp:=T ............. allfac:= T **** **** ezgcd:=NIL ......... gcd:= NIL **** **** mcd:=T ............. lcm:= T **** **** div:=NIL ........... rat:= NIL **** **** intstr:=NIL ........ rational:= NIL **** **** precise:=NIL ....... reduced:= NIL **** **** complex:=NIL ....... rationalize:= NIL **** **** factor:= NIL ....... distribute:= NIL *** ; if !*mcd then "the switch mcd is on"; the switch mcd is on if !*gcd then "the switch gcd is on"; ; % A new switch : !*distribute; % % 2. THE "LIST" MANIPULATION FACILITIES" : ; % generation of a new list ; t1:=mklist(4); T1 := {0,0,0,0} for i:=1:4 do t1:= (t1.i:=mkid(a,i)); ; % notice that part(t1,i) has become t1.i. as also shown here : ; t1.1; A1 t1:=(t1.1).t1; T1 := {A1,A1,A2,A3,A4} % MKLIST does NEVER destroy anything ; mklist(t1,3); {A1,A1,A2,A3,A4} mklist(t1,10); {A1,A1,A2,A3,A4,0,0,0,0,0} % 3. THE DEFINITION OF A BAG ; % The atom "BAG" is an available (and reserved) name for a BAG envelope % it is an OPERATOR. In what follows we mostly use it but we insist that % ANY identifier (there are a few exceptions) may be used. ; aa:=bag(x,1,"A"); AA := BAG(X,1,A) % It is easy to construct NEW bag-like objects ; putbag bg1,bg2; T % now one can verify that ; aa:=bg1(x,y**2); 2 AA := BG1(X,Y ) % is a bag by BAGP ; if bagp aa then "this is a bag"; this is a bag ; % One can erase the bag property of bg2 by the command ; clearbag bg2; ; % baglistp works in the same way for either a LIST OR a BAG ; if baglistp aa then "this is a bag or list"; this is a bag or list if baglistp list(x) then "this is a bag or list"; this is a bag or list ; % Use of the DISPLAYFLAG command that we shall illustrate below is % another way. % "LIST" MAY NOT be a bag. on errcont; % The command below gives an error message: ; putbag list; ***** LIST invalid as BAG % LISTS may be transformed to BAGS and vice versa off errcont; ; kernlist(aa); 2 {X,Y } listbag(list x,bg1); BG1(X) % % % 4. BASIC MANIPULATION FUNCTIONS WORKING FOR BOTH STRUCTURES : ; % define: ; ab:=bag(x1,x2,x3); AB := BAG(X1,X2,X3) al:=list(y1,y2,y3); AL := {Y1,Y2,Y3} % We illustrate how the elementary functions do work DIFFERENTLY ; first ab; BAG(X1) third ab; BAG(X3) first al; Y1 last ab; BAG(X3) last al; Y3 % The subsequent one do act in the SAME way; rest ab; BAG(X2,X3) rest al; {Y2,Y3} belast ab; BAG(X1,X2) belast al; {Y1,Y2} ; % depth determines if the depth of the list is uniform. % when it is, it gives its deepness as an integer. ; depth al; 1 depth bg1(ab); 2 % It is very convenient to define the PICKUP function PART(x,n) by . : ; ab.1; X1 al.3; Y3 on errcont; ab.4; ***** Expression BAG(X1,X2,X3) does not have part 4 off errcont; % For bags, it is possible to avoid an error message when one % has an index out of range using "first", "second" and "third". % For instance: ; second second ab; BAG() % This is coherent because the envelope of a bag always remains. ; size ab; 3 length al; 3 remove(ab,3); BAG(X1,X2) delete(y2,al); {Y1,Y3} reverse al; {Y3,Y2,Y1} member(x3,ab); BAG(X3) % notice the output. ; al:=list(x**2,x**2,y1,y2,y3); 2 AL := {X , 2 X , Y1, Y2, Y3} ; elmult(x**2,al); 2 position(y3,al); 5 ; repfirst(xx,al); 2 {XX,X ,Y1,Y2,Y3} represt(xx,ab); BAG(X1,XX) insert(x,al,3); 2 2 {X ,X ,X,Y1,Y2,Y3} insert( b,ab,2); BAG(X1,B,XX) insert(ab,ab,1); BAG(BAG(X1,XX),X1,XX) substitute (new,y1,al); 2 2 {X ,X ,NEW,Y2,Y3} ; % Function that acts on TWO lists or bags : ; append(ab,al); 2 2 BAG(X1,XX,X ,X ,Y1,Y2,Y3) append(al,ab); 2 2 {X ,X ,Y1,Y2,Y3,X1,XX} ; % Association list or bag may be constructed and thoroughly used ; l:=list(a1,a2,a3,a4); L := {A1,A2,A3,A4} b:=bg1(x1,x2,x3); B := BG1(X1,X2,X3) % PAIR is the CONSTRUCTOR of the ASSOCIATION LIST or BAG. al:=pair(list(1,2,3,4),l); AL := {{1,A1},{2,A2},{3,A3},{4,A4}} ab:=pair(bg1(1,2,3),b); AB := BG1(BG1(1,X1),BG1(2,X2),BG1(3,X3)) ; % A BOOLEAN function abaglistp to test if it is an association ; if abaglistp bag(bag(1,2)) then "it is an associated bag"; it is an associated bag ; % Values associated to the keys can be extracted % first occurence ONLY. ; asfirst(1,al); {1,A1} asfirst(3,ab); BG1(3,X3) ; assecond(a1,al); {1,A1} assecond(x3,ab); BG1(3,X3) ; aslast(z,list(list(x1,x2,x3),list(y1,y2,z))); {Y1,Y2,Z} asrest(list(x2,x3),list(list(x1,x2,x3),list(y1,y2,z))); {X1,X2,X3} ; % All occurences. asflist(x,bg1(bg1(x,a1,a2),bg1(x,b1,b2))); BG1(BG1(X,A1,A2),BG1(X,B1,B2)) asslist(a1,list(list(x,a1,a2),list(x,a1,b2),list(x,y,z))); {} restaslist(bag(a1,x),bg1(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z))); BG1(BG1(X,B2),BG1(A1,A2)) restaslist(list(a1,x),bag(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z))); BAG(BAG(X,B2),BAG(A1,A2)) %******** % Mapping functions can be used with bags through ; on errcont; ; for each j in list(list(a),list(c)) join j; {A,C} for each j in list(bg1(a),bg1(b)) collect first j; {BG1(A),BG1(BG1(X1,X2,X3))} off errcont; ; % The FOR EACH .. IN .. statement requires a LIST-LIKE object.; ; % There are functions available for manipulating bags or lists % as sets. (they exist in the symbolic mode). ; ts:=mkset list(a1,a1,a,2,2); TS := {A1,A,2} ; % Again a boolean function to test the SET property ; if setp ts then "this is a SET"; this is a SET ; union(ts,ts); {A1,A,2} diffset(ts,list(a1,a)); {2} diffset(list(a1,a),ts); {} symdiff(ts,ts); {} intersect(listbag(ts,set1),listbag(ts,set2)); SET1(A1,A,2) % 5. MISCELLANEOUS GENERAL PURPOSE FUNCTIONS : ; clear a1,a2,a3,a,x,y,z,x1,x2,op; % % DETECTION OF A GIVEN VARIABLE IN A GIVEN SET ; detidnum aa; detidnum a10; 10 detidnum a1b2z34; 34 % A list of a finite number of randomly chosen integers can be % generated: % randomlist(3,10); {0,0,1,2,2,2,0,0,0,0} % combnum(8,3); 56 permutations(bag(a1,a2,a3)); BAG(BAG(A1,A2,A3),BAG(A1,A3,A2),BAG(A2,A1,A3),BAG(A2,A3,A1), BAG(A3,A1,A2),BAG(A3,A2,A1)) combinations({a1,a2,a3},2); {{A2,A3},{A1,A3},{A1,A2}} ; % The "depend" command can be traced and made EXPLICIT : ; depatom a; A depend a,x,y; depatom a; {X,Y} % The second use of DEPEND ; depend op,x,y,z; implicit op; OP explicit op; OP(X,Y,Z) depend y,zz; explicit op; OP(X,Y(ZZ),Z) aa:=implicit op; AA := OP % The ENTIRE dependence of OP becomes "IMPLICIT" ; df(aa,y); DF(OP,Y) % These two last functions work properly ONLY when the command "DEPEND" %involves ATOMIC quantities. ; % Detection of variables a given function depends on is possible ; funcvar(x+y); {X,Y} funcvar(sin log(x+y)); {X,Y} ; % Variables on which an expression depends : % funcvar(sin pi); funcvar(x+e+i); {X} % % CONSTANT and RESERVED identifiers are recognize and not taken % as variables. % % Now we illustrate functions that give, display or erase % a "FLAG" or a "PROPERTY" : ; % It is possible to give "flags" in the algebraic mode; % putflag(list(a1,a2),fl1,t); T putflag(list(a1,a2),fl2,t); T displayflag a1; {FL1,FL2} % to clear ALL flags created for a1 : ; clearflag a1,a2; displayflag a2; {} putprop(x1,propname,value,t); X1 displayprop(x1,prop); {} displayprop(x1,propname); {{PROPNAME,VALUE}} % To clear ONE property ; putprop(x1,propname,value,0); displayprop(x1,propname); {} % % % 6. FUNCTIONS TO CONTROL THE ENVIRONMENT : ; % Algebraic ATOMS detection ; alatomp z; T z:=s1; Z := S1 alatomp z; T % Algebraic KERNEL detection ; alkernp z; T alkernp log sin r; T % PRECEDENCE detection ; precp(difference,plus); T precp(plus,difference); precp(times,.); precp(.,times); T % STRING detection ; if stringp x then "this is a string"; if stringp "this is a string" then "this is a string"; this is a string ; ; % A function which detects the dependence of u with respect %to the ATOM or KERNEL v at ANY LEVEL ; depvarp(log(sin(x+cos(1/acos rr))),rr); T ; operator op; *** OP already defined as operator symmetric op; op(x,y)-op(y,x); 0 remsym op; op(x,y)-op(y,x); OP(X,Y) - OP(Y,X) ; clear y,x,u,v; korder y,x,u,v; korderlist; (Y X U V) ; for all x,y such that nordp(x,y) let op(x,y)=x+y; op(a,b); BG1(X1,X2,X3) + A op(b,a); OP(BG1(X1,X2,X3),A) clear op; % DISPLAY and CLEARING of user's objects of various types entered % to the console. Only TOP LEVEL assignments are considered up to now. % The following statements must be made INTERACTIVELY. We put them % as COMMENTS for the user to experiment with them. We do this because % in a fresh environment all outputs are nil. ; % THIS PART OF THE TEST SHOULD BE REALIZED INTERACTIVELY. % SEE THE ** ASSIST LOG ** FILE . %clear a1,a2,aa,ar,br,mm,m1,m2,f,tv; %a1:=a2:=1; %show scalars; %x**2; %saveas res; %show scalars; %aa:=list(a); %show lists; %array ar(2),br(3,3); %show arrays; %load matr$ %matrix mm; matrix m1(2,2); m2:=mat((1,1)); %show matrices; %vector v1,v2; %show vectors; %load excalc; pform f=1; tvector tv; %show vectors; %show forms; %show all; %suppress vectors; %show vectors; %suppress all %show all; clear op; operator op; op(x,y,z); OP(X,Y,S1) clearop op; T clearfunctions abs,tan; *** ABS is unprotected : Cleared *** *** TAN is unprotected : Cleared *** "Clearing is complete" ; % THIS FUNCTION MUST BE USED WITH CARE !!"!!! ; % 7. NEW POLYNOMIAL MANIPUKLATION FACILITIES % % clear x,y,z; % To see the internal representation : % off pri; ; pol:=(x+2*y+3*z**2)**3; 3 2 2 2 2 4 3 POL := 8*Y + (12*X + 36*Z )*Y + (6*X + 36*Z *X + 54*Z )*Y + X + 9 2 2 4 6 *Z *X + 27*Z *X + 27*Z ; % Notice the recursive form. ; pold:=distribute pol; 3 2 2 2 4 2 2 3 POLD := 8*Y + 36*Z *Y + 12*X*Y + 54*Z *Y + 36*Z *X*Y + 6*X *Y + X 2 2 4 6 + 9*Z *X + 27*Z *X + 27*Z ; % Now it is in a distributive form. ; % Terms and reductums may be extracted individually : on distribute; polp:=pol$ leadterm (pold); 3 8*Y pold:=redexpr pold; 2 2 2 4 2 2 3 2 POLD := 36*Z *Y + 12*X*Y + 54*Z *Y + 36*Z *X*Y + 6*X *Y + X + 9*Z 2 4 6 *X + 27*Z *X + 27*Z leadterm pold; 2 2 36*Z *Y ; off distribute; polp:=pol$ leadterm polp; 3 8*Y polp:=redexpr polp; 2 2 2 2 4 3 2 2 POLP := (12*X + 36*Z )*Y + (6*X + 36*Z *X + 54*Z )*Y + X + 9*Z *X 4 6 + 27*Z *X + 27*Z leadterm polp; 2 2 (12*X + 36*Z )*Y ; % "leadterm" and "redexpr" extract the leading term and reductum of a % polynomial respectively WITHOUT specifying the variable. % The default ordering is then assumed. % They work both for the distributive and recursive representations. % % The function "monom" puts in a list all monoms of a multivariate % polynomial. monom polp; 6 {27*Z , 4 27*Z *X, 2 2 9*Z *X , 3 X , 2 6*X *Y, 2 36*Z *X*Y, 4 54*Z *Y, 2 12*X*Y , 2 2 36*Z *Y } % "lowestdeg" extracts the smallest power of a given indeterminate % in a polynomial: lowestdeg(pol,z); 0 ; on pri; ; divpol(pol,x+2*y+3*z**2); 2 2 2 2 4 {X + 4*X*Y + 6*X*Z + 4*Y + 12*Y*Z + 9*Z , 0} % This function gives the quotient AND the remainder directly inside a % list. ; % 8. MANIPUKLATIONS OF SOME ELEMENTARY TRANSCENDENTAL FUNCTIONS trig:=((sin x)**2+(cos x)**2)**4; 8 6 2 4 4 TRIG := SIN(X) + 4*SIN(X) *COS(X) + 6*SIN(X) *COS(X) 2 6 8 + 4*SIN(X) *COS(X) + COS(X) trigreduce trig; 1 trig:=sin (5x); TRIG := SIN(5*X) trigexpand trig; 4 2 2 4 SIN(X)*(SIN(X) - 10*SIN(X) *COS(X) + 5*COS(X) ) trigreduce ws; SIN(5*X) trigexpand sin(x+y+z); - SIN(X)*SIN(Y)*SIN(Z) + SIN(X)*COS(Y)*COS(Z) + SIN(Y)*COS(X)*COS(Z) + SIN(Z)*COS(X)*COS(Y) ; % The same functions exist for hyperbolic functions: ; hypreduce (sinh x **2 -cosh x **2); -1 ; % For expressions containing log's. Expansion in terms of sums, % differences, .. is given by "logplus" while concatenation is given % by the function "concsumlog". ; clear a,b; pluslog log(a*log(x**b)); LOG(LOG(X)) + LOG(A) + LOG(B) concsumlog((2*log x + a*b*log(x*y)+1)/(3*x**2*log(y))); A*B A*B 2 LOG(Y *X *X ) + 1 ----------------------- 2 3*X LOG(Y ) % Though these functions do use substitution rules, these are % active only during the time they actually do their work. % 9. VECTOR CALCULUS OPERATIONS ; clear u1,u2,v1,v2,v3,v4,w3,w4; u1:=list(v1,v2,v3,v4); U1 := {V1,V2,V3,V4} u2:=bag(w1,w2,w3,w4); U2 := BAG(W1,W2,W3,W4) % sumvect(u1,u2); {V1 + W1, V2 + W2, V3 + W3, V4 + W4} minvect(u2,u1); BAG( - V1 + W1, - V2 + W2, - V3 + W3, - V4 + W4) scalvect(u1,u2); V1*W1 + V2*W2 + V3*W3 + V4*W4 crossvect(rest u1,rest u2); {V3*W4 - V4*W3, - V2*W4 + V4*W2, V2*W3 - V3*W2} mpvect(rest u1,rest u2, minvect(rest u1,rest u2)); 0 scalvect(crossvect(rest u1,rest u2),minvect(rest u1,rest u2)); 0 ; % 10. NEW OPERATIONS ON MATRICES ; clear m,mm,b,b1,bb,cc,a,b,c,d; matrix mm(2,2); baglmat(bag(bag(a1,a2)),m); T m; [A1 A2] on errcont; ; baglmat(bag(bag(a1),bag(a2)),m); ***** (MAT ((*SQ ((((A1 . 1) . 1)) . 1) T) (*SQ ((((A2 . 1) . 1)) . 1) T))) should be an identifier off errcont; % **** i.e. it cannot redefine the matrix! in order % to avoid accidental redefinition of an already given matrix; clear m; baglmat(bag(bag(a1),bag(a2)),m); T m; [A1] [ ] [A2] on errcont; baglmat(bag(bag(a1),bag(a2)),bag); ***** OPERATOR BAG invalid as matrix off errcont; % Right since a bag-like object cannot become a matrix. coercemat(m,op); OP(OP(A1),OP(A2)) coercemat(m,list); {{A1},{A2}} ; on nero; unitmat b1(2); matrix b(2,2); b:=mat((r1,r2),(s1,s2)); [R1 R2] B := [ ] [S1 S2] b1; [1 0] [ ] [0 1] b; [R1 R2] [ ] [S1 S2] mkidm(b,1); [1 0] [ ] [0 1] % Allows to relate matrices already defined. ; % Convenient to replace or get a matrix element inside a procedure : % seteltmat(b,newelt,2,2); [R1 R2 ] [ ] [S1 NEWELT] geteltmat(b,2,1); S1 % b:=matsubr(b,bag(1,2),2); [R1 R2] B := [ ] [1 2 ] % It gives automatically a new matrix with the second row substituted. ; submat(b,1,2); [1] % What is left when row 1 and column 2 are taken off the matrix. bb:=mat((1+i,-i),(-1+i,-i)); [I + 1 - I] BB := [ ] [I - 1 - I] cc:=matsubc(bb,bag(1,2),2); [I + 1 1] CC := [ ] [I - 1 2] % Second column substituted. cc:=tp matsubc(bb,bag(1,2),2); [I + 1 I - 1] CC := [ ] [ 1 2 ] matextr(bb, bag,1); BAG(I + 1, - I) % First row extracted and placed in a bag. matextc(bb,list,2); { - I, - I} % Second column extracted and placed in a bag. ; hconcmat(bb,cc); [I + 1 - I I + 1 I - 1] [ ] [I - 1 - I 1 2 ] vconcmat(bb,cc); [I + 1 - I ] [ ] [I - 1 - I ] [ ] [I + 1 I - 1] [ ] [ 1 2 ] % Horizontal an vertical concatenations. ; tpmat(bb,bb); [ 2*I - I + 1 - I + 1 -1] [ ] [ -2 - I + 1 I + 1 -1] [ ] [ -2 I + 1 - I + 1 -1] [ ] [ - 2*I I + 1 I + 1 -1] % Tensor product. % % It is an INFIX operation : bb tpmat bb; [ 2*I - I + 1 - I + 1 -1] [ ] [ -2 - I + 1 I + 1 -1] [ ] [ -2 I + 1 - I + 1 -1] [ ] [ - 2*I I + 1 I + 1 -1] ; clear hbb; hermat(bb,hbb); [ - I + 1 - (I + 1)] [ ] [ I I ] % id hbb changed to a matrix id and assigned to the hermitian matrix % of bb. ; showtime; Time: 2210 ms end; Time: 17 ms Quitting |
Added r34.1/lib/assist.red version [f968fdd3e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | module assist; % Header Module for REDUCE 3.4 Extensions. % create!-package('(assist switchext baglist genpurfunc control % polyextensions transfunctions vectoroper matrext), % '(contrib assist)); % % ******************************************************************** % % Author: H. Caprasse <u214001@bliulg11.bitnet>. % or <u214001@vm1.ulg.ac.be> % % Version and Date: Version 1.1, 15 September 1991. % Revision history for version 1.0 : % % 5 Aug. 1991 : Corrections to RCONS % Property NUMBER!_OF!_ARGS commented. % Flag "NOVAL" on REDEXPR and LEADTERM eliminated. % 1 Sept. 1991 : MAXLIST and MINLIST eliminated since they exist % now in the basic package. % 6 Sept. 1991 : Module "transfunctions" rewritten to conform to % the new syntax for rules. % FACT function eliminated since in the ARITH % package under the name FACTORIAL. % Function SIMPLIFY added to enforce full % simplification in outputs of EXCALC. % 12 Sept.1991 : Capabilities of the functions SHOW and SUPPRESS % enlarged. % Control of switches extended. % ******************************************************************** % endmodule; module switchext$ fluid '(!*distribute); switch distribute; flag('(!*factor !*mcd !*div !*exp !*gcd !*rat !*rational !*rationalize !*intstr !*reduced !*ratpri !*revpri !*distribute !*ezgcd !*complex !*reduced !*lcm !*precise),'share)$ endmodule$ module baglist$ symbolic procedure rmklis u$ % This function works only for LIST-like objects. begin scalar s,ss;integer n; argnochk('mklist . u); if length u = 2 then <<s:=reval car u; n:=reval cadr u; if car s eq 'list then ss:= append(s,cdr rmklis(list(n+1-length s))) else nil>> else if length u=1 then <<n:=reval car u; for j:=1:n do s:=0 . s; ss:='list . s>> else nil; return ss end; put('mklist,'psopfn,'rmklis); global '(!:flaglis !:proplis); % To make properties and flags % available in algebraic mode. put('bag,'simpfn,'simpiden); flag('(bag),'bag)$ % the default bag flag('(bag),'reserved)$ symbolic (!:flaglis:=union(list list2('bag,'bag),!:flaglis))$ symbolic procedure !:delete(u,prop,val)$ if prop then for each x in !:proplis do if x=list3(u,prop,val) then !:proplis:=delete(x,!:proplis) else nil else for each x in !:flaglis do if x=list2(u,val) then !:flaglis:=delete(x,!:flaglis); symbolic procedure !:bagno u; u eq 'list or flagp(u,'boolean); symbolic procedure !:bagyes u; getd u or gettype u member list('tvector,'vector) or flagp( u,'opfn) or get(u,'simpfn) or get(u,'psopfn) or get(u,'fdegree) or get(u,'ifdegree); symbolic procedure simpbagprop u$ % gives the bag property to identifier or baglike-list of identifiers U % V is T if one creates the property or 0 if one destroys it. % Use is bagprop(<list of atoms>,T or 0) % Makes tests to avoid giving this property to an unsuitable object. begin scalar id,bool; id:= car u; bool:= if cadr u eq t then t; if listp id then << for each x in id do simpbagprop list(x,bool) $ return bool>> else if idp id and bool=t then if !:bagno id then typerr (id,"BAG") else if !:bagyes id then <<flag(list id,'bag),go to l1>> else <<put(id,'simpfn,'simpiden)$ flag(list id,'bag)$ go to l1>> else if idp id and not bool then <<remflag(list id,'bag); go to l1>> else rederr("BAD ARGUMENT for bagprop"); l1: if bool then !:flaglis:=union(list list2(id,'bag),!:flaglis) else !:delete(id,nil,'bag) end; symbolic procedure putbag u; simpbagprop list(u,t); % gives the bag property to identifier or baglike-list of identifiers u % V is T to create the bag property. symbolic procedure clearbag u; simpbagprop list(u,0); % destroys the bag property of the identifier or the baglike-list u symbolic rlistat '(putbag clearbag); symbolic procedure bagp(u)$ % test of the baglike property of U$ not atom u and flagp(car u ,'bag)$ flag('(bagp),'boolean); symbolic procedure nbglp(u,n)$ %Function which determines if U is not a bag at the level N. % Used in DEPTH. if n=0 then not baglistp u else if atom u or not bglp!:!: car u then nil else begin scalar uu$ uu:= u$ l1: uu:=cdr uu$ if null uu then return t$ if nbglp(car uu,n-1) then go to l1 else return nil end$ symbolic procedure bglp!:!: u; if not atom u then bglp!:!: car u else if (flagp(u,'bag) or u eq 'list) then t else nil; symbolic procedure baglistp u; % This function is supposed to act on a prefix simplified expression. not atom u and ( car u eq 'list or flagp(car u,'bag)); symbolic procedure nul!: u; baglistp u and null cdr u; symbolic flag('(baglistp nul!:),'boolean); symbolic procedure alistp u$ % Not for use in algebraic mode. if null u then t else (not atom car u) and alistp cdr u; symbolic procedure abaglistp u; % For use in algebraic mode. Recognizes when a bag-like object % contains bags which themselves contain two and only two objects. if null baglistp u or null baglistp cadr u then nil else begin; l1: u:=cdr u; if null u then return t ; if length car u <3 then return nil else go to l1 end; flag('(abaglistp),'boolean); % Definitions of operations on lists symbolic procedure rexplis u; % THIS PROCEDURE GENERALIZES BAGLIST TO ANY OBJECT AND GIVES A LIST OF % THE ARGUMENTS OF U. <<argnochk('kernlist . u); if atom ( u:=reval car u) then nil else if kernp mksq(u,1) then 'list . cdr u>> ; put('kernlist,'psopfn,'rexplis); symbolic procedure rlisbag u$ begin scalar x,prf; argnochk('listbag . u); x:=reval car u; prf :=reval cadr u; if atom x then return nil else <<simpbagprop list(prf,t) ; x:=prf . cdr x>>; return x end; % symbolic put('rlisbag,'number!_of!_args,2); symbolic put('listbag,'psopfn,'rlisbag); symbolic procedure rfirst li; <<argnochk('first . li); if bagp( li:=reval car li) then if null cdr li then car li . nil else car li . cadr li . nil else if car li neq 'list then typerr(li,"list or bag") else if null cdr li then parterr(li,1) else cadr li>>$ put('first,'psopfn,'rfirst); symbolic procedure rsecond li; <<argnochk ('second . li); if bagp( li:=reval car li) then if null cdr li or null cddr li then car li . nil else car li . caddr li . nil else if car li neq 'list then typerr(li,"list or bag") else if null cdr li or null cddr li then parterr(li,2) else caddr li>>; put('second,'psopfn,'rsecond); symbolic procedure rthird li; <<argnochk ('third . li); if bagp( li:=reval car li) then if null cdr li or null cddr li or null cdddr li then car li . nil else car li . cadddr li . nil else if car li neq 'list then typerr(li,"list or bag") else if null cdr li or null cddr li or null cdddr li then parterr(li,3) else cadddr li>>; symbolic procedure rrest li; <<argnochk('rest . li); if bagp( li:=reval car li) then if null cdr li then li . nil else car li . cddr li else if car li neq 'list then typerr(li,"list or bag") else 'list . if null (li:=cdr li) then li else cdr li>>$ symbolic put('rest,'psopfn,'rrest); symbolic procedure rreverse u; <<argnochk('reverse . u); u:=reval car u; if bagp u then car u . reverse cdr u else if car u neq 'list then typerr(u,"list or bag") else 'list . reverse cdr u>>$ symbolic put('reverse,'psopfn,'rreverse); symbolic procedure rlast u; <<argnochk('last . u); u:=reval car u; if bagp u then if null cdr u then u else car u . car reverse cdr u . nil else if car u neq 'list then typerr(u,"list or bag") else if null cdr u then nil else car reverse cdr u>>$ symbolic put('last,'psopfn,'rlast); symbolic procedure rdc u; if null cdr u then nil else car u . rdc cdr u; symbolic procedure rbelast u; <<argnochk('belast . u); u:=reval car u; if bagp u then if null cdr u then u else car u . rdc cdr u else if car u neq 'list then typerr(u,"list or bag") else if null cdr u then u else 'list . rdc cdr u>>$ put('belast,'psopfn,'rbelast); symbolic procedure rappend u; begin scalar x,y; argnochk ('append . u); if length u neq 2 then rederr("append has TWO arguments"); x:=reval car u; y:=reval cadr u; if baglistp x and baglistp y then return car x . append(cdr x,cdr y) else typerr(list(x,y),"list or bag") end ; % put('rappend,'number!_of!_args,2); put('append,'psopfn,'rappend); symbolic procedure rcons u; % This procedure does not work perfectly well when the package % HEPHYS is entered because ISIMPA is applied by reval1 on the % result of RCONS. When it is given by (BAG (LIST A B) C D) it gives % the output BAG({A,B}) erasing C and D ! It is due to the fact that % ISIMP1 and ISIMP2 do not accept SQ forms for identifiers. % So avoid inputs like list(a,b).bag(c,d) when HEPHYS is loaded. begin scalar x,y,z; if (y := getrtypeor(x := revlis u)) eq 'hvector then return if get('cons,'opmtch) and (z:=opmtch('cons . x)) then reval z else prepsq simpdot x else if getrtype(y:=cadr x) eq 'list then return 'list . car x . cdadr x else if bagp y then return z:=car y . car x . cdr y else if fixp y then return z:=revalpart u else typerr(x,"list or bag") end; % symbolic put('rcons,'number!_of!_args,2); symbolic put('cons,'setqfn,'setpart!*); symbolic put('cons,'psopfn,'rcons); symbolic procedure lengthreval u; begin scalar v,w; if length u neq 1 then rederr "LENGTH called with wrong number of arguments" else if idp car u and arrayp car u then return 'list . get(car u,'dimension) else if bagp (u:=reval car u) then return length cdr u; v := aeval u; if (w := getrtype v) and (w := get(w,'lengthfn)) then return apply1(w,v) else if atom v then return 1 else if not idp car v or not(w := get(car v,'lengthfn)) then typerr(u,"length argument") else return apply1(w,cdr v) end; symbolic put('length,'psopfn,'lengthreval); symbolic put('size,'psopfn,'lengthreval); symbolic procedure rremove u; % Allows one to remove the element n of bag u. % First argument is a bag or list, second is an integer. if length u neq 2 then rederr("remove called with wrong number of arguments") else begin scalar x;integer n; argnochk('remove . u); x:=reval car u; n:=reval cadr u; if baglistp x then return car x . remove(cdr x,n) else rederr(" first argument is a list or a bag, second is an integer") end; % symbolic put('rremove,'number!_of!_args,2); symbolic put('remove,'psopfn,'rremove); symbolic procedure rdelete u; begin scalar x,y; x:=reval car u; y:=reval cadr u; if baglistp y then return delete(x,y) end; symbolic put('delete,'psopfn,'rdelete); % Use is delete(<any>,<bag or list>) symbolic procedure rmember u; % First argument is anything, second argument is a bag or list. begin scalar x,y$ argnochk('member . u); x:=reval car u; y:=reval cadr u; if baglistp y then if (x:=member(x,cdr y)) then return car y . x else return nil else typerr(y,"list or bag") end; % symbolic put('rmember,'number!_of!_args,2); symbolic put('member,'psopfn,'rmember); % INPUT MUST BE " member (any , < bag OR list> ) ". symbolic procedure relmult u; if length u neq 2 then rederr("elmult called with wrong number of arguments") else begin scalar x,y; integer n; argnochk('elmult . u); x:=reval car u; % It is the object the multiplicity of which one % wants to compute. y:=reval cadr u; % IT IS THE list OR bag if x=y then return 1 else if baglistp y then <<y:=cdr y; while not null (y:=member(x,y)) do <<y:=cdr y;n:=n+1>>>> else typerr(y,"list or bag"); return n end; % symbolic put('relmult,'number!_of!_args,2); symbolic put('elmult,'psopfn,'relmult); % Use is " elmult (any , < bag OR list> ) " . symbolic procedure rpair u$ begin scalar x,y,prf$ argnochk('pair . u); if length u neq 2 then rederr("pair called with wrong number of arguments"); x:=reval car u; y:=reval cadr u$ if not (baglistp x and baglistp y) then rederr("arguments must be lists or bags") else prf:=car x;x:=cdr x; y:=cdr y; y:=pair(x,for each j in y collect list j); return y:=prf . for each j in y collect prf . j end; % symbolic put('rpair,'number!_of!_args,2); symbolic put('pair,'psopfn,'rpair); symbolic procedure depth!: u; if not atom u and (car u eq 'list or flagp(car u,'bag)) then 1 + depth!: cadr u else 0; symbolic procedure rdepth(u)$ % Use is depth(<BAG or LIST>). begin scalar x; integer n; argnochk('depth . u); x := reval car u; if nbglp(x,n:=depth!: x) then return n else return "bag or list of unequal depths" end; put('depth,'psopfn,'rdepth); symbolic procedure rinsert u; % Use is insert(<any>, <list or bag>, <integer>). begin scalar x,bg,bbg,prf; integer n; argnochk('insert . u); bg:=reval cadr u; n:=reval caddr u; if not baglistp bg then typerr(bg,"list or bag") else if n<=0 then rederr("third argument must be positive an integer") else if (n:=n+1) > length bg then return append(bg,x:=list reval car u); prf:=car bg; x:=reval car u; for i:=3:n do <<bg:=cdr bg; bbg:=car bg . bbg>>; bbg:=reverse bbg; return bbg:=prf . append(bbg,cons(x,cdr bg)) end; % symbolic put('insert,'number!_of!_args ,3); symbolic put('insert,'psopfn,'rinsert); symbolic procedure rposition u$ % Use is position(<any>,<LIST or BAG>). begin scalar el,bg; integer n; el:=reval car u; if not baglistp (bg:=reval cadr u) then typerr(bg," list or bag"); n:=length( bg:=cdr bg); if (bg:=member(el,bg)) then return (n:=n+1-length bg) else msgpri(nil,el,"is not present in list or bag",nil,nil) end; % put('rposition,'number!_of!_args,2); put('position,'psopfn,'rposition); % ********** % The functions below, when applied to objects containing SEVERAL bag % prefixes have a rule to select them in the output object when this % one is itself a bag: the first level prefix has priority over all % other prefixes and will be selected, when needed, as the envelope % of the output. symbolic procedure !:assoc u; if length u neq 2 then rederr("asfirst called with wrong number of arguments") else begin scalar x,y,prf; argnochk('asfirst . u); x:=reval car u; y:=reval cadr u; if null baglistp y then typerr(y,"list or bag"); prf:=car y; y:=cdr y; if null alistp y then typerr(y, "association list") else y:=for each j in y collect cdr j; return if null (y:=assoc(x,y)) then nil else prf . y end; % symbolic put ('!:assoc,'number!_of!_args,2); symbolic put('asfirst,'psopfn,'!:assoc); % Use is : asfirst(<key>,<a-list>Y<a-bag>) symbolic procedure !:rassoc u; if length u neq 2 then rederr("assecond called with wrong number of arguments") else begin scalar x,y,prf; argnochk('assecond . u); x:=reval car u; y:=reval cadr u; if null baglistp y then typerr(y,"list or bag"); prf:=car y; y:=cdr y; if null alistp y then typerr(y, "association list") else y:=for each j in y collect cdr j; return if null (y:=rassoc(list x,y)) then nil else prf . y end; % symbolic put ('!:rassoc,'number!_of!_args,2); symbolic put('assecond,'psopfn,'!:rassoc); % Use is : assecond(<key>,<a-list>Y<a-bag>) symbolic procedure !:assoc2 u; if length u neq 2 then rederr("asrest called with wrong number of arguments") else begin scalar x,y,prf; argnochk('asrest . u); x:=reval car u; y:=reval cadr u; if null baglistp x or null baglistp y then typerr(list(x,y),"list or bag"); prf:=car y; y:=cdr y; x:=cdr x; if null alistp y then typerr(y, "association list") else y:=for each j in y collect cdr j; return if null (y:=assoc2(x,y)) then nil else prf . y end; % symbolic put ('!:assoc2,'number!_of!_args,2); symbolic put('asrest,'psopfn,'!:assoc2); % Use is : asrest(<key>,<a-list>Y<a-bag>) symbolic procedure lastassoc!*(u,v); % Use is : % aslast(<key as a last element>,<a-list>Y<a-bag>) % Finds the sublist in which u is the last element in the % compound list or bag v, or nil if it is not found. if null v then nil else begin scalar vv; vv:=car v; while length vv > 1 do vv:=cdr vv; if u = car vv then return car v else return lastassoc!*(u,cdr v) end; symbolic procedure !:lassoc u; if length u neq 2 then rederr("aslast called with wrong number of arguments") else begin scalar x,y,prf; argnochk('aslast . u); x:=reval car u; y:=reval cadr u; if null baglistp y then typerr(y,"list or bag"); prf:=car y; y:=cdr y; if null alistp y then typerr(y, "association list") else y:=for each j in y collect cdr j; return if null (y:=lastassoc!*(x,y)) then nil else prf . y end; % symbolic put ('!:lassoc,'number!_of!_args,2); symbolic put('aslast,'psopfn,'!:lassoc); symbolic procedure rasflist u; % Use is : % asflist(<key as a first element>,<a-list>Y<a-bag>) % This procedure gives the LIST (or BAG) associated with the KEY con- % tained in the first argument. The KEY is here the FIRST element % of each sublist contained in the association list . if length u neq 2 then rederr("ASFLIST called with wrong number of arguments") else begin scalar x,y,prf,res,aa; x:=reval car u; y:=reval cadr u; prf:=car y; if null cdr y then return y; for each j in cdr y do if car j neq prf then rederr list("prefix INSIDE the list or bag neq to",prf); l1: aa:=!:assoc(list(x,y)); if not aa then return prf . reverse res; res:=aa . res; y:=delete(aa,y); go to l1; end$ symbolic put('asflist,'psopfn,'rasflist); symbolic procedure rasslist u; % Use is : % asslist(<key as the second element>,<a-list>Y<a-bag>) if length u neq 2 then rederr("ASSLIST called with wrong number of arguments") else begin scalar x,y,prf,res,aa; x:=reval car u; y:=reval cadr u; prf:=car y; if null cdr y then return y; for each j in cdr y do if car j neq prf then rederr list("prefix INSIDE the list or bag neq to",prf); l1: aa:=!:rassoc(list(x,y)); if not aa then return prf . reverse res; res:=aa . res; y:=delete(aa,y); go to l1; end$ symbolic put('asslist,'psopfn,'rasslist); symbolic procedure !:sublis u; % Use is : % restaslist(<bag-like object containing keys>,<a-list>Y<a-bag>) % Output is a list containing the values associated to the selected % keys. if length u neq 2 then rederr("restaslist called with wrong number of arguments") else begin scalar x,y,yy,prf; argnochk('sublis . u); x:=reval car u; y:=reval cadr u; prf:=car y; if null baglistp y then typerr(y,"list or bag") else if null alistp (y:=cdr y) then typerr(y," association list or bag") else y:=for each j in y collect cdr j; if baglistp x then <<x:=cdr x; x:=for each j in x collect if assoc(j,y) then j>>; y:=sublis(y,x); if atom y then yy:=list y else for each j in y do if not null j then yy:=j . yy; yy:=reverse yy; return prf . for each j in yy collect if atom j then prf . j . nil else prf . j$ end$ % symbolic put('!:sublis,'number!_of!_args,2); symbolic put('restaslist,'psopfn,'!:sublis); % Use is : % restaslist(<bag-like object containing keys>,<a-list>Y<a-bag>) % Output is a list containing the values associated to the selected % keys. % ******* End of functions which may change bag- or list- prefixes. % FOR SUBSTITUTION OF IDENTIFIERS IT IS CONVENIENT TO USE : symbolic procedure !:subst u; <<argnochk('substitute . u); reval subst(reval car u,reval cadr u,reval caddr u)>>; % symbolic put('!:subst,'number!_of!_args,3); symbolic put('substitute,'psopfn,'!:subst); % Use is : substitute(<newid>,<oldid>,<in any>). % May serve to transform ALL bags into lists or vice-versa. symbolic procedure !:repla u; if length u neq 2 then rederr("repfirst called with wrong number of arguments") else begin scalar x,y,prf; argnochk('repfirst . u); y:=reval car u; x:= reval cadr u; if null baglistp x then typerr(x,"list or bag"); prf:= car x; x:=cdr x; return prf . rplaca(x,y) end; % symbolic put('!:repla,'number!_of!_args,2); symbolic put('repfirst,'psopfn,'!:repla); % Use is : repfirst(<any>, <bag or list>); symbolic procedure !:repld u; % Use is : replast(<any>, <bag or list>); begin scalar x,y,prf; argnochk('represt . u); if length u neq 2 then rederr("replast called with wrong number of arguments"); y:=reval car u; x:= reval cadr u; if null baglistp x then typerr(u,"list or bag"); prf:= car x; x:=cdr x; return prf . rplacd(x,list y) end; % symbolic put('!:repld,'number!_of!_args,2); symbolic put('represt,'psopfn,'!:repld); symbolic procedure rinsert u; begin scalar x,bg,bbg,prf; integer n; argnochk('insert . u); bg:=reval cadr u; n:=reval caddr u; if not baglistp bg then typerr(bg,"list or bag") else if n<=0 then rederr("third argument must be positive integer") else if (n:=n+1) > length bg then return append(bg,x:=list reval car u); prf:=car bg; x:=reval car u; for i:=3:n do <<bg:=cdr bg; bbg:=car bg . bbg>>; bbg:=reverse bbg; return bbg:=prf . append(bbg,cons(x,cdr bg)) end; % symbolic put('insert,'number!_of!_args ,3); symbolic put('insert,'psopfn,'rinsert); % Use is : insert(<any>, <list or bag>, <integer>). % HERE ARE FUNCTIONS FOR SETS. symbolic procedure !:union u$ begin scalar x,y,prf; argnochk('union . u); if length u neq 2 then rederr("union called with wrong number of arguments"); x:=reval car u; y:=reval cadr u; if baglistp x and baglistp y then <<prf:=car y; y:=prf . union(cdr x,cdr y)>> else return nil; return y end; % symbolic put('!:union,'number!_of!_args,2); symbolic put('union,'psopfn,'!:union); symbolic procedure setp u; null repeats u; symbolic flag('(setp),'boolean); symbolic procedure !:mkset u$ if null u then nil else if member(car u,cdr u) then !:mkset cdr u else car u . !:mkset cdr u$ symbolic procedure rmkset u; begin scalar x,prf$ argnochk('mkset . u); x:=reval car u; prf:=car x; if baglistp x then return prf . !:mkset cdr x end; symbolic put('mkset,'psopfn,'rmkset); symbolic procedure !:setdiff u$ begin scalar x,y,prf; argnochk('diffset . u); if length u neq 2 then rederr("diffset called with wrong number of arguments"); x:=reval car u; y:=reval cadr u; if baglistp x and baglistp y then <<prf:=car y; y:=prf . setdiff(cdr x,cdr y)>> else return nil; return y end; % symbolic put('!:setdiff,'number!_of!_args,2); symbolic put('diffset,'psopfn,'!:setdiff); symbolic procedure !:symdiff u$ begin scalar x,y,prf; argnochk('symdiff . u); if length u neq 2 then rederr("symdiff called with wrong number of arguments"); x:=reval car u; y:=reval cadr u; prf:=car x; if setp x and setp y then return prf . append(setdiff(x:=cdr x,y:=cdr y),setdiff(y,x)) end; % symbolic put('!:symdiff,'number!_of!_args,2); symbolic put('symdiff,'psopfn,'!:symdiff); symbolic procedure !:xn u$ begin scalar x,y,prf; argnochk('intersect . u); if length u neq 2 then rederr("intersect called with wrong number of arguments"); x:=reval car u; y:=reval cadr u; if setp x and setp y then return car x . intersection(cdr x,cdr y) end; % symbolic put('!:xn,'number!_of!_args,2); symbolic put('intersect,'psopfn,'!:xn); endmodule ; module genpurfunc; %=====================================================================$ % $ % VARIOUS GENERAL PURPOSE FUNCTIONS $ % $ %=====================================================================$ % 1. GENERALIZATION OF EXISTING FUNCTIONS symbolic procedure mkidn(u)$ % generalizes "mkid" for any number of atoms % Input is mkidn(list(a1,...ak)Ybag(a1,...,ak)). expand(cdr u, 'mkid); flag('(mkidn),'opfn); symbolic procedure simpsetf u; % generalizes the function "set" to kernels. begin scalar x; x := simp!* car u; if not kernp x or fixp (!*q2a x) then typerr(!*q2a x,"setvalue kernel") else x:=!*q2a x; let0 list(list('equal,x,mk!*sq(u := simp!* cadr u))); return u end; put ('setvalue, 'simpfn, 'simpsetf); newtok '((!= !=) setvalue ! !=!=! ); infix ==; symbolic procedure inf2(n,m); if evalgreaterp(n,m) then m else n; symbolic procedure sup2(n,m); if evalgreaterp(n,m) then n else m; flag('(inf2,sup2),'opfn); flag('(prin2 ) ,'opfn); % To make it available in the alg. mode. % 2. NEW ELEMENTARY FUNCTIONS CLOSELY RELATED TO EXISTING ONES. symbolic procedure oddp u$ % Tests if integer U is odd. Is also defined in EXCALC; fixp u and remainder(u,2)=1$ symbolic procedure evenp u; not oddp u; symbolic flag('(oddp evenp),'boolean); symbolic procedure followline(n)$ % It allows to go to a new line at the position given by the integer N. << terpri()$ spaces(n)>>$ symbolic flag('(followline ) ,'opfn); % 3. NEW GENERAL PURPOSE FUNCTIONS. symbolic procedure charnump!: x; if x member list('!0,'!1,'!2,'!3,'!4,'!5,'!6,'!7,'!8,'!9) then t ; symbolic procedure charnump u; if null u then t else charnump!: car u and charnump cdr u; symbolic procedure detidnum u; % Allows one to extract the index number from the identifier u. if idp u then begin scalar uu; if length(uu:= cdr explode u) =1 then go to l1 else while not charnump uu do uu:=cdr uu; l1: uu:= compress uu; if fixp uu then return uu end; flag('(detidnum),'opfn); symbolic procedure randomlist(n,trial); % This procedure gives a list of trials in number "trial" of % random numbers between 0 and n. For the algorithm see KNUTH vol. 2. 'list . lisp for j:=1:trial collect random n; flag('(randomlist),'opfn); algebraic procedure combnum(n,nu)$ % Number of combinations of n objects nu to nu. if nu>n then rederr "second argument cannot be bigger than first argument" else factorial(n)/factorial(nu)/factorial(n-nu)$ symbolic procedure rpermutation u; <<argnochk('permutations . u); if not baglistp(u:=reval car u) then nil else if null cdr u then 'list . nil else begin scalar x,prf$ prf:=car u$ u:=cdr u$ x:=for each j in u conc mapcons(permutations delete(j,u),j)$ x:=for each j in x collect prf . j$ return prf . x end>>; put('permutations,'psopfn,'rpermutation); symbolic procedure !:comb(u)$ begin scalar x,prf; integer n; argnochk('combinations . u); if length u neq 2 then rederr "combinations called with wrong number of arguments"; x:=reval car u ; if not baglistp x then return nil ; prf :=car x; x:=cdr x; n:=reval cadr u; return prf . (for each j in comb(x,n) collect prf . j) end; symbolic put('combinations,'psopfn,'!:comb); symbolic procedure rfuncvar(u)$ % U is an arbitrary expression % Gives a list which contains all the variables whom U depends % in an ARBITRARY order$ <<if atom (u:=reval car u) then if not flagp(u,'reserved) then if depatom u neq u then depatom u else nil else nil else begin scalar wi,aa$ aa:=listofvars(u)$ % if null cdr aa then return car aa else if null cdr aa then return if flagp(car aa,'reserved) or flagp(car aa,'constant) then nil else car aa else aa:=!:mkset aa $ wi:=aa$ while wi do if flagp(car wi ,'reserved) then <<aa:=delete(car wi ,aa)$ wi:=cdr wi >> else wi:=cdr wi $ return aa:='list . aa end >>; flag('(e i),'reserved); symbolic procedure listofvars u $ if null u or numberp u then nil else if atom u then list u else varsinargs cdr u $ symbolic procedure varsinargs(u)$ if null u then nil else append(listofvars car u,varsinargs cdr u)$ symbolic put('funcvar,'psopfn ,'rfuncvar); symbolic procedure implicit u; if atom u then u else begin scalar prf; prf:=car u; if get(prf,'simpfn) neq 'simpiden then rederr list(u,"must be an OPERATOR"); remprop(car u,'simpfn); depl!*:=union(list (car u . reverse for each y in cdr u collect implicit y),depl!*); return prf end; symbolic procedure depatom a$ %Gives a list of variables declared in DEPEND commands whom A depends %A must be an atom$ if not atom a then rederr("ARGUMENT MUST BE AN ATOM") else if null assoc(a,depl!*) then a else 'list . reverse cdr assoc(a,depl!*); flag('(depatom),'opfn); symbolic procedure explicit u$ % U is an atom. It gives a function named A which depends on the % variables detected by DEPATOM and this to all levels$ begin scalar aa$ aa:=depatom u $ if aa = u then return u$ put(u,'simpfn,'simpiden)$ return u . (for each x in cdr aa collect explicit x) end$ symbolic flag('(implicit explicit),'opfn); symbolic procedure simplify u; % Enforces simplifications if necessary. % u is any expression. mk!*sq resimp simp!* reval u; symbolic flag('(simplify),'opfn); % 4. FUNCTIONS TO DEAL WITH PROPERTIES IN THE ALGEBRAIC MODE. global('(!:flaglis !:proplis)); symbolic(!:flaglis:=union(list list2('bag,'bag),!:flaglis)); symbolic procedure putflag(u,flg,b)$ % Allows one to put or erase any FLAG on the identifier U. % U is an idf or a list of idfs, FLAG is an idf, B is T or 0. if not idp u and not null baglistp u then <<for each x in cdr u do putflag(x,flg,b)$ t>> else if idp u and b eq t then <<flag(list u, flg)$ !:flaglis:=union(list list2(u, flg),!:flaglis)$ u>> else if idp u and b equal 0 then <<remflag( list u, flg)$ !:delete(u,nil,flg)$>> else rederr "*** VARIABLES ARE (idp OR list of flags, T or 0)."; symbolic procedure putprop(u,prop,val,b)$ % Allows to put or erase any PROPERTY on the object U % U is an idf or a list of idfs, B is T or 0$ if not idp u and baglistp u then <<for each x in cdr u do putprop(x,prop,val,b)$ t>> else if idp u and b eq t then <<put(u, prop,val)$ !:proplis:=union(list list3(u,prop,val),!:proplis)$ u>> else if idp u and b equal 0 then <<remprop( u, prop)$ !:delete(u,prop,val)$ >> else rederr "*** VARIABLES ARE (idp OR list of idps, T or 0)."; symbolic flag('(putflag putprop),'opfn)$ symbolic procedure rdisplayprop(u)$ % U is the idf whose properties one wants to display.Result is a % list which contains them$ begin scalar x,val,aa$ x:=reval car u; val:=reval cadr u; for each j in !:proplis do if car j eq x and cadr j eq val then aa:=('list . cdr j) . aa; return 'list . aa end; symbolic put('displayprop,'psopfn,'rdisplayprop)$ symbolic put('displayflag,'psopfn,'rdisplayflag)$ symbolic procedure rdisplayflag(u)$ % U is the idf whose properties one wants to display.Result is a % list which contains them$ begin scalar x,aa$ x:=reval car u; for each j in !:flaglis do if car j=x then aa:=cons(cadr j,aa)$ return 'list . aa end; symbolic procedure clrflg!: u; for each x in !:flaglis do if u eq car x then putflag(car x,cadr x,0) ; symbolic procedure clearflag u; % If u equals "all" all flags are eliminated. % If u is a1,a2,a3.....an flags of these identifiers are eliminated. if null cdr u and car u eq 'all then for each x in !:flaglis do putflag (car x,cadr x,0) else if null cdr u then clrflg!: car u else for each y in u do clrflg!: y; symbolic procedure clrprp!: u; for each x in !:proplis do if u eq car x then putprop(car x,cadr x,caddr x,0); symbolic procedure clearprop u; % If u equals "all" all properties are eliminated. % If u is a1,a2,a3...an properties of these identifiers are eliminated. if null cdr u and car u eq 'all then for each x in !:proplis do putprop(car x,cadr x,caddr x,0) else if null cdr u then clrprp!: car u else for each y in u do clrprp!: y; symbolic put('clearflag,'stat,'rlis); symbolic put('clearprop,'stat,'rlis); endmodule; module control; % functions which offer a BETTER CONTROL on $ % various objects and of the ALREADY USED quantities $ % 1. BOOLEAN functions. flag('(null idp flagp),'boolean); symbolic procedure nordp(u,v); % TRUE if a>b, FALSE if a=<b. NOT USED HERE. not ordp(u,v); symbolic procedure depvarp(u,v)$ % V is an idf. or a kernel$ if depends(u,v) then t else nil$ symbolic procedure alatomp(u)$ % U is any expression . Test if U is an idf. whose only value is its % printname or another atom$ fixp u or idp u$ symbolic procedure alkernp u$ % U is any expression . Test if U is a kernel.$ not stringp u and kernp(simp!* u)$ symbolic procedure precp(u,v)$ % Tests if the operator U has precedence over the operator V. begin integer nn$scalar uu,vv,aa$ uu:=u$ vv:=v$aa:=preclis!*$ if or(not(uu member aa),not(vv member aa)) then return nil$ nn:=lpos(u,aa)$; nn:=nn-lpos(v,aa)$ if nn geq 0 then return t else return nil end$ flag('(nordp alatomp alkernp precp depvarp stringp ),'boolean)$ % THE SUBSEQUENT DECLARATION IS USEFUL FOR "TEACHING PURPOSES". flag('(alatomp precp depvarp alkernp depatom ) ,'opfn); % 2. MISCELLANEOUS functions. symbolic procedure korderlist; % gives a list of the user defined internal order of the % indeterminates. Just state KORDERLIST; to get it. kord!*; flag('(korderlist), 'opfn); put('korderlist,'stat,'endstat); symbolic procedure remsym u; % ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES. for each j in u do if flagp(j,'symmetric) then remflag(list j,'symmetric) else if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric); put('remsym,'stat,'rlis); % 3. Control of SWITCHES. symbolic procedure switches; %This procedure allows to see the values of the main switches$ <<terpri(); prin2 " **** exp:=";prin2 !*exp;prin2 " ............. "; prin2 "allfac:= ";prin2 !*allfac;prin2 " ****";terpri(); terpri(); prin2 " **** ezgcd:=";prin2 !*ezgcd;prin2 " ......... "; prin2 "gcd:= ";prin2 !*gcd;prin2 " ****";terpri();terpri(); prin2 " **** mcd:=";prin2 !*mcd;prin2 " ............. "; prin2 "lcm:= ";prin2 !*lcm;prin2 " ****";terpri();terpri(); prin2 " **** div:=";prin2 !*div;prin2 " ........... "; prin2 "rat:= ";prin2 !*rat;prin2 " ****";terpri();terpri(); prin2 " **** intstr:=";prin2 !*intstr;prin2 " ........ "; prin2 "rational:= ";prin2 !*rational;prin2 " ****";terpri();terpri(); prin2 " **** precise:=";prin2 !*precise;prin2 " ....... "; prin2 "reduced:= ";prin2 !*reduced;prin2 " ****";terpri();terpri(); prin2 " **** complex:=";prin2 !*complex;prin2 " ....... "; prin2 "rationalize:= ";prin2 !*rationalize; prin2 " ****";terpri();terpri(); prin2 " **** factor:= "; prin2 !*factor;prin2 " ....... "; prin2 "distribute:= ";prin2 !*distribute;prin2 " ***";>>$ flag('(switches),'opfn)$ symbolic procedure switchorg$ %It puts all switches relevant to current algebra calculations to % their initial values. << !*exp:=t; !*allfac:=t; !*gcd:=nil; !*mcd:=t; !*div:=nil; !*rat:=nil; !*distribute:=nil; !*intstr:=nil; !*rational:=nil; !*ezgcd:=nil; !*ratarg:=nil; !*precise:=nil; !*complex:=nil; !*heugcd:=nil; !*lcm:=t; !*factor:=nil; !*ifactor:=nil; !*rationalize:=nil; !*reduced:=nil; !*savestructr:=nil; >>; flag('(switchorg switchoff),'opfn)$ deflist('((switches endstat) (switchorg endstat) (switchoff endstat)), 'stat)$ % 4. Control of USER DEFINED objects. % This aims to extract from the history of the run % the significant data defined by the user. It DOES NOT give insights on % operations done in the SYMBOLIC mode. symbolic procedure remvar!:(u,v)$ % This procedure traces and clear both assigned or saved scalars and % lists. begin scalar buf,comm,lv; buf:=inputbuflis!*; for each x in buf do if not atom (comm:=caddr x) and car comm = 'setk then begin scalar obj; l1: if null cddr comm then return lv; obj:=cadadr comm; if gettype obj eq v then lv:=cons(obj,lv); comm:=caddr comm; go to l1 end; lv:= !:mkset lv; if null u then <<for each x in lv do clear x; return t>> else return lv end; flag('(displaylst displayscal),'noform); symbolic procedure displayscal; % Allows to see all scalar variables which have been assigned % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file; union(remvar!:(t,'scalar),remsvar!:(t,'scalar)); symbolic procedure displaylst$ % Allows to see all list variables which have been assigned % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file; union(remvar!:(t,'list),remsvar!:(t,'list)) ; symbolic procedure clearscal$ % Allows to clear all scalar variables introduced % DIRECTLY ON THE CONSOLE; <<remvar!:(nil,'scalar);remsvar!:(nil,'scalar)>>$ symbolic procedure clearlst$ % Allows to clear all list variables introduced % DIRECTLY ON THE CONSOLE; <<remvar!:(nil,'list);remsvar!:(nil,'list)>>; symbolic procedure remsvar!:(u,v)$ begin scalar buf,comm,lsv,obj; buf:= inputbuflis!*; for each x in buf do if not atom (comm:=caddr x) and car comm eq 'saveas then if v eq t then if gettype (obj:=cadr cadadr comm) member list('scalar,'list,'matrix,'hvector,'tvector) then lsv:=cons(obj,lsv) else nil else if v eq gettype (obj:=cadr cadadr comm) then lsv:=cons(obj,lsv); lsv:= !:mkset lsv$ if null u then <<for each x in lsv do clear x$ return t>> else return lsv end; flag('(displaysvar),'noform); symbolic procedure displaysvar; % Allows to see all variables created by SAVEAS. remsvar!:(t,t) ; symbolic procedure clearsvar; % Allows to clear all variables created. % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file. remsvar!:(nil,t); symbolic procedure rema!:(u); % This function works to trace or to clear arrays. begin scalar buf,comm,la$ buf:=inputbuflis!*$ for each x in buf do if not atom (comm:=caddr x) and car comm eq 'arrayfn then begin scalar arl,obj; arl:=cdaddr comm; l1: if null arl then return la else if gettype (obj:=cadadr car arl ) eq 'array then la:=cons(obj,la); arl:=cdr arl$ go to l1 end$ la:= !:mkset la$ if null u then <<for each x in la do clear x$ return t>> else return la end; flag('(displayar),'noform); symbolic procedure displayar; % Allows to see all array variables created. % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file. rema!:(t)$ symbolic procedure clearar; % Allows to clear array variables introduced % DIRECTLY ON THE CONSOLE; rema!:(nil)$ % This file shoul be loaded together with remscal.red symbolic procedure remm!:(u)$ % This function works to trace or to clear matrices. Be CAREFUL to use % the declaration MATRIX on input (not m:=mat(...) directly). % declaration MATRIX .. %x ==> (97 SYMBOLIC (MATRIX (LIST (LIST (QUOTE MM) 1 1)))) % Declaration MM:=MAT((...)) % x==>(104 ALGEBRAIC % (SETK (QUOTE M2) (AEVAL (LIST (QUOTE MAT) (LIST 1) (LIST 1))))) begin scalar buf,comm,lm; buf:= inputbuflis!*; for each x in buf do if not atom (comm:=caddr x) and car comm eq 'matrix then begin scalar lob,obj; lob:=cdadr comm; l1: if null lob then return lm else if gettype(obj:=if length car lob = 2 then cadr car lob else cadadr car lob) then lm:=cons(obj,lm); lob:=cdr lob; go to l1 end$ lm :=union(lm,remvar!:(t,'matrix)); lm:=!:mkset lm; if null u then <<for each x in lm do clear x$ return t>> else return lm end; flag('(displaymat),'noform); symbolic procedure displaymat$ % Allows to see all variables of matrix type % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file; union( remm!:(t),remsvar!:(t,'matrix)); symbolic procedure clearmat$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; <<remm!:(nil);remsvar!:(nil,'matrix)>>; symbolic procedure remv!:(u)$ % This function works to trace or to clear vectors. begin scalar buf,av$ buf:= inputbuflis!*$ for each x in buf do if not atom (x:=caddr x) and car x member list('vector,'tvector,'index) then begin scalar uu,xx$ uu:=cdadr x$ l1: if null uu then return av else if gettype(xx:=cadar uu) or get(xx,'fdegree) then av:=cons(xx,av); uu:=cdr uu$ go to l1 end$ av:= !:mkset av$ if null u then <<for each x in av do clear x$ return t>> else return av end$ flag('(displayvec),'noform); symbolic procedure displayvec$ % Allows to see all variables which have been assigned % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file; union(remv!:(t),union(remsvar!:(t,'hvector),remsvar!:(t,'tvector)) ); symbolic procedure clearvec$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; <<remv!:(nil);remsvar!:(nil,'hvector);remsvar!:(nil,'tvector)>>; symbolic procedure remf!:(u)$ % This function works to trace or to clear arrays. begin scalar buf,av$ buf:= inputbuflis!*$ for each x in buf do if not atom (x:=caddr x) and car x eq 'pform then begin scalar uu,xx$ uu:=cdadr x$ l1: if null uu then return av else if get(xx:=cadadr cdar uu ,'fdegree) or (not atom xx and get(xx:=cadr xx,'ifdegree)) then av:=cons(xx,av); uu:=cdr uu$ go to l1 end$ av:= !:mkset av$ if null u then <<for each x in av do clear x$ return t>> else return av end$ flag('(displayform),'noform); symbolic procedure displayform$ % Allows to see all variables which have been assigned % independently DIRECTLY ON THE CONSOLE. It does not work % for assignments introduced THROUGH an input file; union(remf!:(t),remvar!:(t,'pform)); symbolic procedure clearform$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; <<remf!:(nil);remvar!:(nil,'pform)>>; symbolic procedure clear!_all; <<remvar!: (nil,'scalar); remvar!:(nil,'list); remvar!:(nil,'pform); remsvar!:(nil,t);rema!: nil;remv!: nil;remm!: nil; remf!: nil ;t>>; symbolic procedure show u; begin u:=car u; if u eq 'scalars then return write "scalars are: ", displayscal() else if u eq 'lists then return write "lists are: ", displaylst() else if u eq 'arrays then return write "arrays are: ", displayar() else if u eq 'matrices then return write "matrices are: ",displaymat() else if u member list('vectors,'tvectors,'indices) then return write "vectors are: ", displayvec() else if u eq 'forms then return write "forms are: ", displayform() else if u eq 'all then for each i in list('scalars,'arrays,'lists,'matrices,'vectors,'forms) do <<show list i;lisp terpri()>>; end; put('show,'stat,'rlis); symbolic procedure suppress u; begin u:=car u; if u member list('vectors,'tvectors,'indices) then return clearvec() else if u eq 'variables then return clearvar() else if u eq 'scalars then return clearscal() else if u eq 'lists then return clearlst() else if u eq 'saveids then return clearsvar() else if u eq 'matrices then return clearmat() else if u eq 'arrays then return clearar() else if u eq 'forms then return clearform() else if u eq 'all then return clear!_all() end; put('suppress,'stat,'rlis); % 5. Means to CLEAR operators and functions. symbolic procedure clearop u; <<clear u; remopr u; remprop(u , 'kvalue);remprop(u,'klist)$ for each x in !:flaglis do if u eq car x then putflag(u,cadr x,0) else nil; for each x in !:proplis do if u eq car x then putprop(u,cadr x,caddr x,0) else nil; remflag(list u,'used!*); t>>; symbolic flag('(clearop),'opfn); symbolic procedure clearfunctions u$ % U is any number of idfs. This function erases properties of non % protected functions described by the idfs. % It is very convenient but is dangerous if applied to the % basic functions of the system since most of them are NOT protected. % It clears all properties introduced by PUTFLAG, PUTPROP and DEPEND. begin scalar uu,vv$ l1: uu:=car u$ vv:=cdr rdisplayflag (list uu )$ if flagp(uu,'lose) then go to l2 else << terpri();spaces(5)$ write "*** ",uu," is unprotected : Cleared ***"$ followline(0)>>$ for each x in !:proplis do if u eq car x then putprop(u,cadr x,caddr x,0) else nil; if get(uu,'simpfn) then <<clearop uu; remprop(uu,'!:ft!:); remprop(uu,'!:gf!:)>> else if get(uu,'psopfn) then remprop(uu,'psopfn) else if get(uu,'expr) then remprop(uu,'expr) else if get(uu,'subr) then remd uu$ remprop(uu,'stat); remprop(uu,'dfn); remflag(list uu,'opfn)$ remflag(list uu,'full)$ remflag(list uu,'odd)$ remflag(list uu,'even)$ remflag(list uu,'boolean)$ remflag(list uu,'used!*)$ for each x in vv do putflag( uu,x,0)$ depl!*:=delete(assoc(uu,depl!*),depl!*); remflag(list uu,'impfun)$ % to be effective in EXCALC; u:= cdr u$ go to l3$ l2: << spaces(5)$ write "*** ",uu," is a protected function: NOT cleared ***"$ terpri(); u:=cdr u>>$ l3: if null u then <<terpri(); return "Clearing is complete">> else go to l1 end$ symbolic rlistat '(clearfunctions); endmodule; module polyextensions; %===================================================================== % ADDITIONAL FUNCTIONS FOR POLYNOME AND RATIONAL EXPRESSION % MANIPULATIONS. %===================================================================== fluid '(!*distribute); switch distribute; symbolic procedure addfd (u,v); % It contains a modification to ADDF to avoid % a recursive representation. % U and V are standard forms. Value is a standard form. if null u then v else if null v then u else if domainp u then addd(u,v) else if domainp v then addd(v,u) %else if peq(lpow u,lpow v) or ordpp(lpow u,lpow v) else if ordpp(lpow u,lpow v) then lt u .+ addfd(red u,v) else lt v .+ addfd (u,red v); symbolic procedure distribute u; % Gives a polynome in distributed form in the algebraic mode. list('!*sq,distri!_pol numr simp!* u ./ 1,t); symbolic flag('(distribute),'opfn); symbolic procedure distri!_pol u; % This function assumes that u is a polynomial given % as a standard form. It transforms its recursive representation into % a distributive representation. if null u then nil else if atom u then u else if red u then addfd(distri!_pol !*t2f lt u,distri!_pol red u) else begin scalar x,y; x:=1 ; y:=u; while not atom y and null red y do <<x:=multf(!*p2f lpow y,x); y:=lc y>>; if atom y then return multf(x,y) else return addfd(distri!_pol multf(x,distri!_pol !*t2f lt y), distri!_pol multf(x,distri!_pol red y)) end; symbolic procedure leadterm u; <<u:=simp!* u; if !*distribute then u:=distri!_pol numr u ./ denr u else u; if domainp u then mk!*sq u else mk!*sq(!*t2f lt numr u ./ denr u)>>; symbolic flag('(leadterm redexpr ),'opfn); symbolic procedure redexpr u; <<u:=simp!* u; if !*distribute then u:=distri!_pol numr u ./ denr u else u; if domainp u then mk!*sq(nil ./ 1) else mk!*sq( red numr u ./ denr u)>>; symbolic procedure list!_of!_monom u; % It takes a polynomial in distributive form. % returns a list of monoms. % u is numr simp!* (algebraic expression) if domainp u then u else begin scalar exp,lmon,mon; exp:=u; l: if null exp then return lmon ; mon:=lt exp; lmon:=(!*t2f mon ) . lmon; exp:=red exp; go to l; end; symbolic procedure monomterm y; begin scalar x; x:=numr simp!* y; x:=distri!_pol x; x:=list!_of!_monom x; x:=for each m in x collect mk!*sq(m ./ 1); return 'list . x end; algebraic procedure monom(u); % Use: monom <polynome> begin scalar x,xx; xx:= lisp monomterm u ; return xx end; symbolic procedure !&dpol u$ % RETURNS A LIST WHICH CONTAINS THE QUOTIENT POLYNOMIAL and THE % REMAINDER. if length u neq 2 then rederr "divpol must have two arguments" else begin scalar poln,pold,aa,ratsav$ if lisp (!*factor) then off factor; % This restriction is % necessary for some implementatins . poln:= simp!* car u$ pold:= simp!* cadr u$ if denr poln neq 1 or denr pold neq 1 then rederr(" arguments must be polynomials")$ poln:=numr poln$ pold:=numr pold$ if lc poln neq 1 or lc poln neq lc pold then <<ratsav:=lisp (!*rational); on rational>>; aa:=qremf(poln,pold)$ aa:=mksq(list('list ,prepsq!*( car aa . 1), prepsq!*(cdr aa . 1)),1)$ if not ratsav then off rational; return aa end$ put('divpol,'simpfn,'!&dpol)$ symbolic procedure lowestdeg(u,v)$ % IT EXTRACTS THE LOWEST DEGREE IN V OF THE POLYNOMIAL U. begin scalar x,y,uu,vv,mvy$ uu:=simp!* u$ if domainp uu then return 0$ uu:=!*q2f uu; vv:=!*a2k v$ x:=setkorder list v$ y:=reorder uu$ setkorder x$ y:=reverse y$y$ if fixp y then return 0$ mvy:=mvar y$ if not atom mvy then if car mvy eq 'expt then rederr("exponents must be integers")$ if mvy neq vv then return 0 else return ldeg y end$ flag('(lowestdeg),'opfn)$ endmodule; module transfunctions; algebraic; algebraic procedure trigexpand wws; wws where { sin(~x+~y) => sin(x)*cos(y)+cos(x)*sin(y), cos(~x+~y) => cos(x)*cos(y)-sin(x)*sin(y), sin((~n)*~x) => sin(x)*cos((n-1)*x)+cos(x)*sin((n-1)*x) when fixp n and n>1, cos((~n)*~x) => cos(x)*cos((n-1)*x)-sin(x)*sin((n-1)*x) when fixp n and n>1 }; algebraic procedure hypexpand wws; wws where {sinh(~x+~y) => sinh(x)*cosh(y)+cosh(x)*sinh(y), cosh(~x+~y) => cosh(x)*cosh(y)+sinh(x)*sinh(y), sinh((~n)*~x) => sinh(x)*cosh((n-1)*x)+cosh(x)*sinh((n-1)*x) when fixp n and n>1, cosh((~n)*~x) => cosh(x)*cosh((n-1)*x)+sinh(x)*sinh((n-1)*x) when fixp n and n>1 }; operator !#ei!&; !#ei!&(0):=1; trig!#ei!& := {!#ei!&(~x)**(~n) => !#ei!&(n*x), !#ei!&(~x)*!#ei!&(~y) => !#ei!&(x+y)}; let trig!#ei!&; algebraic procedure trigreduce wws; <<wws:=(wws WHERE {cos(~x) => (!#ei!&(x)+!#ei!&(-x))/2, sin(~x) => -i*(!#ei!&(x)-!#ei!&(-x))/2}); wws:=(wws WHERE {!#ei!&(~x) => cos x +i*sin x})>>; algebraic procedure hypreduce wws; <<wws:=(wws where {cosh(~x) => (!#ei!&(x)+!#ei!&(-x))/2, sinh(~x) => (!#ei!&(x)-!#ei!&(-x))/2}); wws:=(wws where {!#ei!&(~x) => cosh(x)+sinh(x)})>>; algebraic procedure pluslog wws; wws:=(wws where {log(~x*(~n)) => log(x)+log(n), log(~x/(~n)) => log(x)-log(n), log(~x**(~n)) => n*log(x), log sqrt(~x) => 1/2*log(x), log cbrt(~x) => 1/3*log(x) }); % realizes the concatenation of "sum over i c(i)*log x(i)". operator e!_log!_conc; algebraic procedure concsumlog exp; % This procedure works properly only in ON EXP only though it may lead % to some simplification also in OFF EXP. if den exp neq 1 then concsumlog num exp / concsumlog den exp else <<exp:=(e!_log!_conc(exp) where { e!_log!_conc(~x+~y)=e!_log!_conc(x)*e!_log!_conc(y), e!_log!_conc(log(~x)) => x, e!_log!_conc(-log(~x)) => 1/x, e!_log!_conc(~a*log (~x)) => x**a, e!_log!_conc((- ~a)*log(~x)) => 1/x**a }); exp:=(log exp where { log(e!_log!_conc(~y)) => y, log(~x*e!_log!_conc(~y)) => log(x)+y, log(~x*e!_log!_conc(-~y)) => log(x)-y, log(~x*e!_log!_conc(-~y)/(~z)) => log(x/z)-y, log(~x*e!_log!_conc(~y)/(~z)) => log(x/z)+y })>>; symbolic; endmodule; module vectoroper; % This small module makes basic operation between EXPLICIT vectors % available. They are assumed to be represented by BAGS or LISTS. % Mixed product is restricted to 3-space vectors. % Generalization is still NEEDED. ; symbolic procedure depthl1!: u; if null u then t else (caar u neq 'list) and depthl1!: cdr u; symbolic procedure depthl1 u; not null getrtype u and depthl1!: cdr u; symbolic procedure !:vect(u,v,bool); %returns a list whose elements are the sum of each list elements. % null v check not necessary; if null u then nil else addsq(car u,if null bool then car v else negsq car v) . !:vect(cdr u,cdr v,bool); symbolic procedure rsumvect(u); begin scalar x,y,prf; argnochk('sumvect . u); x:=reval car u;y:=reval cadr u; prf:=car x; if (rdepth list x = 0) or (rdepth list y = 0) then rederr " both arguments must be of depth 1 " else x:=cdr x; y:=cdr y; if length x neq length y then rederr "vector mismatch"; x:=for each j in x collect simp!* j; y:=for each j in y collect simp!* j; return prf . (for each j in !:vect(x,y,nil) collect mk!*sq j) end; put('sumvect,'psopfn,'rsumvect); symbolic procedure rminvect(u); begin scalar x,y,prf; argnochk('minvect . u); x:=reval car u;y:=reval cadr u; prf:=car x; if (rdepth list x = 0) or (rdepth list y = 0) then rederr " both arguments must be of depth 1 " else x:=cdr x; y:=cdr y; if length x neq length y then rederr "vector mismatch"; x:=for each j in x collect simp!* j; y:=for each j in y collect simp!* j; return prf . (for each j in !:vect(x,y,'minus) collect mk!*sq j) end; put('minvect,'psopfn,'rminvect); symbolic procedure !:scalprd(u,v); %returns scalar product of two lists; if null u and null v then nil ./ 1 else addsq(multsq(car u,car v),!:scalprd(cdr u,cdr v)); symbolic procedure sscalvect(u); begin scalar x,y; argnochk('scalvect . u); x:=reval car u;y:=reval cadr u; if (rdepth list x = 0) or (rdepth list y = 0) then rederr " both arguments must be of depth 1 " else if length x neq length y then rederr "vector mismatch"; x:=cdr x; y:=cdr y; x:=for each j in x collect simp!* j; y:=for each j in y collect simp!* j; return mk!*sq !:scalprd(x,y) end; symbolic put('scalvect,'psopfn,'sscalvect); symbolic procedure !:pvect3 u; begin scalar x,y; integer xl; if (rdepth list car u = 0) or (rdepth cdr u = 0) then rederr " both arguments must be of depth 1 " else x:=reval car u;y:=reval cadr u; if (xl:=length x) neq 4 then rederr "not 3-space vectors" else if xl neq length y then rederr "vector mismatch" ; x:=cdr x; y:=cdr y; x:=for each j in x collect simp!* j; y:=for each j in y collect simp!* j; return list( addsq(multsq(cadr x,caddr y),negsq multsq(caddr x,cadr y)), addsq(multsq(caddr x,car y),negsq multsq(car x,caddr y)), addsq(multsq(car x,cadr y),negsq multsq(cadr x,car y))) end; symbolic procedure rcrossvect u; <<% implemented only with LIST prefix; argnochk('crossvect . u); 'list . (for each j in !:pvect3 u collect mk!*sq j)>>; symbolic put ('crossvect,'psopfn,'rcrossvect); symbolic procedure smpvect u; begin scalar x; if (rdepth list car u =0) then rederr " arguments must be of depth 1 " else x:=reval car u; u:=cdr u; x:=cdr x; if length x neq 3 then rederr " not 3-space vector"; x:=for each j in x collect simp!* j; return mk!*sq !:scalprd(x,!:pvect3 u) end; symbolic put('mpvect,'psopfn,'smpvect); endmodule; module matrext; % This module defines additional utility functions for manipulating % matrices. Coercions to BAG and LIST structures are defined. symbolic procedure natnumlis u; % True if U is a list of natural numbers. % Taken from MATR.RED for bootstrap purpose. null u or numberp car u and fixp car u and car u>0 and natnumlis cdr u; symbolic procedure mkid!:(x,y); % creates the ID XY from identifier X and (evaluated) atom Y. if not idp x or null getrtype x then typerr(x,"MKID root") else if atom y and (idp y or fixp y and not minusp y) then intern compress nconc(explode x,explode y) else typerr(y,"MKID index"); symbolic procedure mkidm(u,j); % This function allows us to RELATE TWO MATRICES by concatanation of % characters. u AND uj should BOTH be matrices. matsm cadr get(mkid!:(u,j),'avalue) ; symbolic put('mkidm,'rtypefn,'getrtypecar); symbolic flag('(mkidm),'matflg); symbolic procedure baglmat (u,op); % this procedure maps U into the matrix whose name is OP; % it cannot REDEFINE the matrix OP. % This is to avoid accidental redefinition of a previous matrix; if getrtype op then rederr list(op,"should be an identifier") else begin scalar x,y; if atom op then if not (y:=gettype op) then put(op,'rtype,'matrix) else typerr(list(y,op),"matrix"); if rdepth list u neq 2 then rederr("depth of list or bag must be 2"); x:=cdr u; x:= for each j in x collect for each k in cdr j collect k; put(op,'avalue,list('matrix,'mat . x)); return t end; symbolic flag('(baglmat),'opfn); symbolic procedure rcoercemat u; % Transforms a matrix into a bag or list. Argument is a list (mat,idp). % idp is the name to be given to the line or column vectors. % The idp-envelope of the bag is the same as the one of the one of the % subbags$ begin scalar x,prf; x:=reval car u; if getrtype x neq 'matrix then rederr list(x,"should be a matrix"); prf:= cadr u; if car x neq 'mat then typerr(x,"matrix") else if prf neq 'list then <<prf:=reval prf; simpbagprop list(prf,t)>>; x:=cdr x; x:= for each j in x collect (prf . j); return prf . x end; symbolic put('coercemat,'psopfn,'rcoercemat); symbolic put('rcoercemat,'number!_of!_args,2); symbolic procedure n!-1zero(n,k)$ if n=0 then nil else if k=1 then 1 . nzero(n-1) else if k=n then append(nzero(n-1) , (1 . nil)) else append(nzero(k-1), (1 . nzero(n-k)))$ symbolic procedure unitmat u$ % It creates unit matrices. The argument is of the form A(2),B(5)....$ begin scalar l,sy,x,aa$ for each s in u do << if idp s or length (l:= revlis cdr s) neq 1 or not natnumlis l then errpri2(s,'hold) else <<aa:=nil;sy:=car s; x:=gettype sy; if not null x then if x eq 'matrix then lprim list(x,sy,"redefined") else typerr(list(x,sy),"matrix"); l:=car l; for n:=1:l do aa:=n!-1zero(l,l-n+1) . aa$ put(sy,'rtype,'matrix); put(sy,'avalue,list('matrix,'mat . aa))>>>>; end$ symbolic put('unitmat,'stat,'rlis); symbolic procedure submat (u,nl,nc); % Allows to extract from the matrix M the matrix obtained when % the row NL and the column NC have been dropped. % When NL and NC are out of range gives a copy of M; if getrtype u neq 'matrix then rederr list(u,"should be a matrix") else begin scalar x; x:= matsm u; if and(nl=0,nc=0) then return x else if nl neq 0 then x:=remove(x,nl)$ if nc neq 0 then x:=for each j in x collect remove(j,nc); return x end; symbolic put('submat,'rtypefn,'getrtypecar); symbolic flag('(submat),'matflg); symbolic procedure matsubr(m,bgl,nr)$ if getrtype m neq 'matrix then rederr list(m,"should be a matrix") else begin scalar x,y,res; integer xl; % It allows to replace row NR of the matrix M by the bag or list BGL; y:=reval bgl; if not baglistp y then typerr(y,"bag or list") else if nr leq 0 then rederr " THIRD ARG. MUST BE POSITIVE" else x:=matsm m$ xl:=length x$ if length( y:=cdr y) neq xl then rederr " MATRIX MISMATCH"$ y:= for each j in y collect simp j; if nr-xl >0 then rederr " row number is out of range"; while (nr:=nr-1) >0 do <<res:=car x . res$ x:=cdr x >>; rplaca(x,y) ; res:=append( reverse res, x) ; return res end; symbolic put('matsubr,'rtypefn,'getrtypecar); symbolic flag('(matsubr),'matflg); symbolic procedure matsubc(m,bgl,nc)$ if getrtype m neq 'matrix then rederr list(m,"should be a matrix") else begin scalar x,y,res; integer xl; %It allows to replace column NC of the matrix M by the bag or list BGL y:=reval bgl; if not baglistp y then typerr(y,"bag or list") else if nc leq 0 then rederr " THIRD ARG. MUST BE POSITIVE" else x:=tp1 matsm m$ xl:=length x$ if length( y:=cdr y) neq xl then rederr " MATRIX MISMATCH"$ y:= for each j in y collect simp j; if nc-xl >0 then rederr " column number is out of range"; while (nc:=nc-1) >0 do <<res:=car x . res$ x:=cdr x >>; rplaca(x,y) ; res:=tp1 append( reverse res, x) ; return res end; symbolic put('matsubc,'rtypefn,'getrtypecar); symbolic flag('(matsubc),'matflg); symbolic procedure rmatextr u$ % This function allows to extract the row N from the matrix A and % to place it inside a bag whose name is LN$ begin scalar x,y; integer n,nl; x:= matsm car u; y:= reval cadr u; n:=reval caddr u; if not fixp n then rederr "Arguments are: matrix, vector name, line number" else if not baglistp list y then simpbagprop list(y, t)$ nl:=length x; if n<= 0 or n>nl then return nil$ while n>1 do <<x:=cdr x$ n:=n-1>>$ if null x then return nil$ return x:=y . ( for each j in car x collect prepsq j) end$ symbolic procedure rmatextc u$ % This function allows to extract the row N from the matrix A and % to place it inside a bag whose name is LN$ begin scalar x,y; integer n,nc; x:= tp1 matsm car u; y:= reval cadr u; n:=reval caddr u; if not fixp n then rederr "Arguments are: matrix, vector name, line number" else if not baglistp list y then simpbagprop list(y, t)$ nc:=length x; if n<= 0 or n>nc then return nil$ while n>1 do <<x:=cdr x$ n:=n-1>>$ if null x then return nil$ return x:=y . ( for each j in car x collect prepsq j) end$ symbolic put('matextr,'psopfn,'rmatextr); symbolic put('matextc,'psopfn,'rmatextc); symbolic procedure hconcmat(u,v)$ % Gives the horizontal concatenation of matrices U and V$ hconcmat!:(matsm u,matsm v ); symbolic procedure hconcmat!:(u,v)$ if null u then v else if null v then u else append(car u,car v) . hconcmat!:(cdr u,cdr v)$ symbolic put('hconcmat,'rtypefn,'getrtypecar); symbolic flag('(hconcmat),'matflg); symbolic procedure vconcmat (u,v)$ % Gives the vertical concatenation of matrices U and V$ append(matsm u,matsm v); symbolic put('vconcmat,'rtypefn,'getrtypecar); symbolic flag('(vconcmat),'matflg); symbolic procedure tprodl(u,v)$ begin scalar aa,ul$ l1: if null u then return aa$ ul:=car u$ ul:=multsm(ul,v)$ aa:=hconcmat!:(aa,ul)$ u:=cdr u$ go to l1$ end$ symbolic procedure tpmat(u,v)$ % Constructs the direct product of two matrices; if null gettype u then multsm(simp u,matsm v) else if null gettype v then multsm(simp v,matsm u) else begin scalar aa,uu,vv$ uu:=matsm u$ vv:=matsm v$ for each x in uu do aa:=append (aa,tprodl(x,vv))$ return aa end; infix tpmat$ put('tpmat,'rtypefn, 'getrtypecar); flag('(tpmat),'matflg)$ algebraic procedure hermat (m,hm); % hm must be an identifier with NO value. Returns the % Hermitiam Conjugate matrix. begin scalar ml,ll; %ll:=length M; m:=tp m; ml:=coercemat(m,list); ll:=list(length first ml,length ml); ml:=for j:=1: first ll collect for k:=1:second ll collect sub(i=-i,(ml.j).k); baglmat(ml,hm); return hm end; symbolic procedure seteltmat(m,elt,i,j); % Sets the matrix element (i,j) to elt. Returns the modified matrix. begin scalar res;res:=matsm m; rplaca(pnth(nth(res,i),j),simp elt); return res end; put('seteltmat,'rtypefn,'getrtypecar); flag('(seteltmat),'matflg); symbolic procedure simpgetelt u; % Gets the matrix element (i,j). Returns the element. begin scalar mm; mm:=matsm car u; return nth(nth(mm,cadr u),caddr u) end; put('geteltmat, 'simpfn,'simpgetelt); endmodule; end; |
Added r34.1/lib/assist.tst version [df2ab03702].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Tests of Assist Package version 1.1 . % Valid only with REDUCE 3.4 % DATE : 15 September 1991. % Author: H. Caprasse <u214001@bliulg11.bitnet>. % <u214001@vm1.ulg.ac.be> %--------------------------------------------------------------------- load assist; showtime; % 1. TESTS OF THE SWITCH CONTROL FUNCTIONS : ; switches; switchorg; switches; ; if !*mcd then "the switch mcd is on"; if !*gcd then "the switch gcd is on"; ; % A new switch : !*distribute; % % 2. THE "LIST" MANIPULATION FACILITIES" : ; % generation of a new list ; t1:=mklist(4); for i:=1:4 do t1:= (t1.i:=mkid(a,i)); ; % notice that part(t1,i) has become t1.i. as also shown here : ; t1.1; t1:=(t1.1).t1; % MKLIST does NEVER destroy anything ; mklist(t1,3); mklist(t1,10); % 3. THE DEFINITION OF A BAG ; % The atom "BAG" is an available (and reserved) name for a BAG envelope % it is an OPERATOR. In what follows we mostly use it but we insist that % ANY identifier (there are a few exceptions) may be used. ; aa:=bag(x,1,"A"); % It is easy to construct NEW bag-like objects ; putbag bg1,bg2; % now one can verify that ; aa:=bg1(x,y**2); % is a bag by BAGP ; if bagp aa then "this is a bag"; ; % One can erase the bag property of bg2 by the command ; clearbag bg2; ; % baglistp works in the same way for either a LIST OR a BAG ; if baglistp aa then "this is a bag or list"; if baglistp list(x) then "this is a bag or list"; ; % Use of the DISPLAYFLAG command that we shall illustrate below is % another way. % "LIST" MAY NOT be a bag. on errcont; % The command below gives an error message: ; putbag list; % LISTS may be transformed to BAGS and vice versa off errcont; ; kernlist(aa); listbag(list x,bg1); % % % 4. BASIC MANIPULATION FUNCTIONS WORKING FOR BOTH STRUCTURES : ; % define: ; ab:=bag(x1,x2,x3); al:=list(y1,y2,y3); % We illustrate how the elementary functions do work DIFFERENTLY ; first ab; third ab; first al; last ab; last al; % The subsequent one do act in the SAME way; rest ab; rest al; belast ab; belast al; ; % depth determines if the depth of the list is uniform. % when it is, it gives its deepness as an integer. ; depth al; depth bg1(ab); % It is very convenient to define the PICKUP function PART(x,n) by . : ; ab.1; al.3; on errcont; ab.4; off errcont; % For bags, it is possible to avoid an error message when one % has an index out of range using "first", "second" and "third". % For instance: ; second second ab; % This is coherent because the envelope of a bag always remains. ; size ab; length al; remove(ab,3); delete(y2,al); reverse al; member(x3,ab); % notice the output. ; al:=list(x**2,x**2,y1,y2,y3); ; elmult(x**2,al); position(y3,al); ; repfirst(xx,al); represt(xx,ab); insert(x,al,3); insert( b,ab,2); insert(ab,ab,1); substitute (new,y1,al); ; % Function that acts on TWO lists or bags : ; append(ab,al); append(al,ab); ; % Association list or bag may be constructed and thoroughly used ; l:=list(a1,a2,a3,a4); b:=bg1(x1,x2,x3); % PAIR is the CONSTRUCTOR of the ASSOCIATION LIST or BAG. al:=pair(list(1,2,3,4),l); ab:=pair(bg1(1,2,3),b); ; % A BOOLEAN function abaglistp to test if it is an association ; if abaglistp bag(bag(1,2)) then "it is an associated bag"; ; % Values associated to the keys can be extracted % first occurence ONLY. ; asfirst(1,al); asfirst(3,ab); ; assecond(a1,al); assecond(x3,ab); ; aslast(z,list(list(x1,x2,x3),list(y1,y2,z))); asrest(list(x2,x3),list(list(x1,x2,x3),list(y1,y2,z))); ; % All occurences. asflist(x,bg1(bg1(x,a1,a2),bg1(x,b1,b2))); asslist(a1,list(list(x,a1,a2),list(x,a1,b2),list(x,y,z))); restaslist(bag(a1,x),bg1(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z))); restaslist(list(a1,x),bag(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z))); %******** % Mapping functions can be used with bags through ; on errcont; ; for each j in list(list(a),list(c)) join j; for each j in list(bg1(a),bg1(b)) collect first j; off errcont; ; % The FOR EACH .. IN .. statement requires a LIST-LIKE object.; ; % There are functions available for manipulating bags or lists % as sets. (they exist in the symbolic mode). ; ts:=mkset list(a1,a1,a,2,2); ; % Again a boolean function to test the SET property ; if setp ts then "this is a SET"; ; union(ts,ts); diffset(ts,list(a1,a)); diffset(list(a1,a),ts); symdiff(ts,ts); intersect(listbag(ts,set1),listbag(ts,set2)); % 5. MISCELLANEOUS GENERAL PURPOSE FUNCTIONS : ; clear a1,a2,a3,a,x,y,z,x1,x2,op; % % DETECTION OF A GIVEN VARIABLE IN A GIVEN SET ; detidnum aa; detidnum a10; detidnum a1b2z34; % A list of a finite number of randomly chosen integers can be % generated: % randomlist(3,10); % combnum(8,3); permutations(bag(a1,a2,a3)); combinations({a1,a2,a3},2); ; % The "depend" command can be traced and made EXPLICIT : ; depatom a; depend a,x,y; depatom a; % The second use of DEPEND ; depend op,x,y,z; implicit op; explicit op; depend y,zz; explicit op; aa:=implicit op; % The ENTIRE dependence of OP becomes "IMPLICIT" ; df(aa,y); % These two last functions work properly ONLY when the command "DEPEND" %involves ATOMIC quantities. ; % Detection of variables a given function depends on is possible ; funcvar(x+y); funcvar(sin log(x+y)); ; % Variables on which an expression depends : % funcvar(sin pi); funcvar(x+e+i); % % CONSTANT and RESERVED identifiers are recognize and not taken % as variables. % % Now we illustrate functions that give, display or erase % a "FLAG" or a "PROPERTY" : ; % It is possible to give "flags" in the algebraic mode; % putflag(list(a1,a2),fl1,t); putflag(list(a1,a2),fl2,t); displayflag a1; % to clear ALL flags created for a1 : ; clearflag a1,a2; displayflag a2; putprop(x1,propname,value,t); displayprop(x1,prop); displayprop(x1,propname); % To clear ONE property ; putprop(x1,propname,value,0); displayprop(x1,propname); % % % 6. FUNCTIONS TO CONTROL THE ENVIRONMENT : ; % Algebraic ATOMS detection ; alatomp z; z:=s1; alatomp z; % Algebraic KERNEL detection ; alkernp z; alkernp log sin r; % PRECEDENCE detection ; precp(difference,plus); precp(plus,difference); precp(times,.); precp(.,times); % STRING detection ; if stringp x then "this is a string"; if stringp "this is a string" then "this is a string"; ; ; % A function which detects the dependence of u with respect %to the ATOM or KERNEL v at ANY LEVEL ; depvarp(log(sin(x+cos(1/acos rr))),rr); ; operator op; symmetric op; op(x,y)-op(y,x); remsym op; op(x,y)-op(y,x); ; clear y,x,u,v; korder y,x,u,v; korderlist; ; for all x,y such that nordp(x,y) let op(x,y)=x+y; op(a,b); op(b,a); clear op; % DISPLAY and CLEARING of user's objects of various types entered % to the console. Only TOP LEVEL assignments are considered up to now. % The following statements must be made INTERACTIVELY. We put them % as COMMENTS for the user to experiment with them. We do this because % in a fresh environment all outputs are nil. ; % THIS PART OF THE TEST SHOULD BE REALIZED INTERACTIVELY. % SEE THE ** ASSIST LOG ** FILE . %clear a1,a2,aa,ar,br,mm,m1,m2,f,tv; %a1:=a2:=1; %show scalars; %x**2; %saveas res; %show scalars; %aa:=list(a); %show lists; %array ar(2),br(3,3); %show arrays; %load matr$ %matrix mm; matrix m1(2,2); m2:=mat((1,1)); %show matrices; %vector v1,v2; %show vectors; %load excalc; pform f=1; tvector tv; %show vectors; %show forms; %show all; %suppress vectors; %show vectors; %suppress all %show all; clear op; operator op; op(x,y,z); clearop op; clearfunctions abs,tan; ; % THIS FUNCTION MUST BE USED WITH CARE !!"!!! ; % 7. NEW POLYNOMIAL MANIPUKLATION FACILITIES % % clear x,y,z; % To see the internal representation : % off pri; ; pol:=(x+2*y+3*z**2)**3; ; % Notice the recursive form. ; pold:=distribute pol; ; % Now it is in a distributive form. ; % Terms and reductums may be extracted individually : on distribute; polp:=pol$ leadterm (pold); pold:=redexpr pold; leadterm pold; ; off distribute; polp:=pol$ leadterm polp; polp:=redexpr polp; leadterm polp; ; % "leadterm" and "redexpr" extract the leading term and reductum of a % polynomial respectively WITHOUT specifying the variable. % The default ordering is then assumed. % They work both for the distributive and recursive representations. % % The function "monom" puts in a list all monoms of a multivariate % polynomial. monom polp; % "lowestdeg" extracts the smallest power of a given indeterminate % in a polynomial: lowestdeg(pol,z); ; on pri; ; divpol(pol,x+2*y+3*z**2); % This function gives the quotient AND the remainder directly inside a % list. ; % 8. MANIPUKLATIONS OF SOME ELEMENTARY TRANSCENDENTAL FUNCTIONS trig:=((sin x)**2+(cos x)**2)**4; trigreduce trig; trig:=sin (5x); trigexpand trig; trigreduce ws; trigexpand sin(x+y+z); ; % The same functions exist for hyperbolic functions: ; hypreduce (sinh x **2 -cosh x **2); ; % For expressions containing log's. Expansion in terms of sums, % differences, .. is given by "logplus" while concatenation is given % by the function "concsumlog". ; clear a,b; pluslog log(a*log(x**b)); concsumlog((2*log x + a*b*log(x*y)+1)/(3*x**2*log(y))); % Though these functions do use substitution rules, these are % active only during the time they actually do their work. % 9. VECTOR CALCULUS OPERATIONS ; clear u1,u2,v1,v2,v3,v4,w3,w4; u1:=list(v1,v2,v3,v4); u2:=bag(w1,w2,w3,w4); % sumvect(u1,u2); minvect(u2,u1); scalvect(u1,u2); crossvect(rest u1,rest u2); mpvect(rest u1,rest u2, minvect(rest u1,rest u2)); scalvect(crossvect(rest u1,rest u2),minvect(rest u1,rest u2)); ; % 10. NEW OPERATIONS ON MATRICES ; clear m,mm,b,b1,bb,cc,a,b,c,d; matrix mm(2,2); baglmat(bag(bag(a1,a2)),m); m; on errcont; ; baglmat(bag(bag(a1),bag(a2)),m); off errcont; % **** i.e. it cannot redefine the matrix! in order % to avoid accidental redefinition of an already given matrix; clear m; baglmat(bag(bag(a1),bag(a2)),m); m; on errcont; baglmat(bag(bag(a1),bag(a2)),bag); off errcont; % Right since a bag-like object cannot become a matrix. coercemat(m,op); coercemat(m,list); ; on nero; unitmat b1(2); matrix b(2,2); b:=mat((r1,r2),(s1,s2)); b1;b; mkidm(b,1); % Allows to relate matrices already defined. ; % Convenient to replace or get a matrix element inside a procedure : % seteltmat(b,newelt,2,2); geteltmat(b,2,1); % b:=matsubr(b,bag(1,2),2); % It gives automatically a new matrix with the second row substituted. ; submat(b,1,2); % What is left when row 1 and column 2 are taken off the matrix. bb:=mat((1+i,-i),(-1+i,-i)); cc:=matsubc(bb,bag(1,2),2); % Second column substituted. cc:=tp matsubc(bb,bag(1,2),2); matextr(bb, bag,1); % First row extracted and placed in a bag. matextc(bb,list,2); % Second column extracted and placed in a bag. ; hconcmat(bb,cc); vconcmat(bb,cc); % Horizontal an vertical concatenations. ; tpmat(bb,bb); % Tensor product. % % It is an INFIX operation : bb tpmat bb; ; clear hbb; hermat(bb,hbb); % id hbb changed to a matrix id and assigned to the hermitian matrix % of bb. ; showtime; end; |
Added r34.1/lib/camal.bib version [9bff0225c6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Bibliography entry for camal.tex. @ARTICLE{Bourne, AUTHOR = {Stephen R. Bourne}, TITLE = {Literal expressions for the co-ordinates of the moon. {I}. The first degree terms}, JOURNAL = {Celestial Mechanics}, VOLUME = {6}, PAGES = {167--186}, YEAR = {1972}, GENERATED = {Mon Oct 23 19:42:01 GMT 1989 on fino} } @MISC{Fateman, AUTHOR = {Richard J. Fateman}, TITLE = {On the multiplication of Poisson series}, YEAR = {1973}, MONTH = {Draft}, GENERATED = {Mon Oct 23 19:42:01 GMT 1989 on fino} } @Manual{CAMALF, title = "{CAMAL} {User's} {Manual}", author = "J. P. Fitch", organization = "University of Cambridge Computer Laboratory", edition = "2nd", year = "1983" } @Article{Barton67a, author = "D. Barton", title = "", journal = "Astronomical Journal", year = "1967", volume = "72", pages = "1281--7" } @Article{Barton67b, author = "D. Barton", title = "A scheme for manipulative algebra on a computer", journal = "Computer Journal", year = "1967", volume = "9", pages = "340--4" } @Book{Delaunay, author = "C. Delaunay", title = "Th\'eorie du Mouvement de la Lune", publisher = "Mallet-Bachelier", year = "1860", series = "(Extraits des M\'em. Acad. Sci.)", address = "Paris" } @Article{Barton72, author = "D. Barton and J. P. Fitch", title = "The Application of Symbolic Algebra System to Physics", journal = "Reports on Progress in Physics", year = "1972", volume = "35", pages = "235--314" } @Article{LectureNotes, author = "J. P. Fitch", title = "Syllabus for Algebraic Manipulation Lectures in Cambridge", journal = "SIGSAM Bulletin", year = "1975", volume = "32", pages = "15" } @InProceedings{Barnes, author = "A. Barnes and J. A. Padget", title = "Univariate Power Series Expansions in {Reduce}", booktitle = "Proceedings of ISSAC'90", year = "1990", editor = "S. Watanabe and M. Nagata", pages = "82--7", organization = "ACM", publisher = "Addison-Wesley" } @Book{Brown, author = "E. W. Brown", title = "An Introductory Treatise on the Lunar Theory", publisher = "Cambridge University Press", year = "1896" } @Article{Jefferys, author = "W. H. Jeffereys", title = "", journal = "Celestial Mechanics", year = "1970", volume = "2", pages = "474--80" } |
Added r34.1/lib/camal.log version [d6333a5700].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | REDUCE 3.4.1, 15-Jul-92 ... 1: (CAMAL) n := 4; N := 4 on rational, rat; off allfac; array p(n/2+2); harmonic u,v,w,x,y,z; weight e=1, b=1, d=1, a=1; %% Step1: Solve Kepler equation bige := fourier 0; BIGE := 0 for k:=1:n do << wtlevel k; bige:=fourier e * hsub(fourier(sin u), u, u, bige, k); >>; write "Kepler Eqn solution:", bige$ 1 4 3 3 Kepler Eqn solution: - [( - ---*E )SIN[4U] + ( - ---*E )SIN[3U] + ( 3 8 1 4 1 2 1 3 ---*E - ---*E )SIN[2U] + (---*E - E)SIN[U]] 6 2 8 %% Ensure we do not calculate things of too high an order wtlevel n; %% Step 2: Calculate r/a in terms of e and l dd:=-e*e; 2 DD := - E hh:=3/2; 3 HH := --- 2 j:=1; J := 1 cc := 1; CC := 1 for i:=1:n/2 do << j:=i*j; hh:=hh-1; cc:=cc+hh*(dd^i)/j >>; bb:=hsub(fourier(1-e*cos u), u, u, bige, n); 1 4 3 3 1 4 1 2 BB := [( - ---*E )COS[4U] + ( - ---*E )COS[3U] + (---*E - ---*E )COS 3 8 3 2 3 3 1 2 [2U] + (---*E - E)COS[U] + (---*E + 1)] 8 2 aa:=fourier 1+hdiff(bige,u); 4 4 9 3 1 4 2 AA := [(---*E )COS[4U] + (---*E )COS[3U] + ( - ---*E + E )COS[2U] + 3 8 3 1 3 ( - ---*E + E)COS[U] + 1] 8 ff:=hint(aa*aa*fourier cc,u); 103 4 13 3 11 4 FF := - [( - -----*E )SIN[4U] + ( - ----*E )SIN[3U] + (----*E 96 12 24 5 2 1 3 1 4 - ---*E )SIN[2U] + (---*E - 2*E)SIN[U] + (---*E - 1)] 4 4 8 %% Step 3: a/r and f uu := hsub(bb,u,v); 1 4 3 3 1 4 1 2 UU := [( - ---*E )COS[4V] + ( - ---*E )COS[3V] + (---*E - ---*E )COS 3 8 3 2 3 3 1 2 [2V] + (---*E - E)COS[V] + (---*E + 1)] 8 2 uu:=hsub(uu,e,b); 1 4 3 3 1 4 1 2 UU := [( - ---*B )COS[4V] + ( - ---*B )COS[3V] + (---*B - ---*B )COS 3 8 3 2 3 3 1 2 [2V] + (---*B - B)COS[V] + (---*B + 1)] 8 2 vv := hsub(aa,u,v); 4 4 9 3 1 4 2 VV := [(---*E )COS[4V] + (---*E )COS[3V] + ( - ---*E + E )COS[2V] + 3 8 3 1 3 ( - ---*E + E)COS[V] + 1] 8 vv:=hsub(vv,e,b); 4 4 9 3 1 4 2 VV := [(---*B )COS[4V] + (---*B )COS[3V] + ( - ---*B + B )COS[2V] + 3 8 3 1 3 ( - ---*B + B)COS[V] + 1] 8 ww := hsub(ff,u,v); 103 4 13 3 11 4 WW := - [( - -----*E )SIN[4V] + ( - ----*E )SIN[3V] + (----*E 96 12 24 5 2 1 3 1 4 - ---*E )SIN[2V] + (---*E - 2*E)SIN[V] + (---*E - 1)] 4 4 8 ww:=hsub(ww,e,b); 103 4 13 3 11 4 WW := - [( - -----*B )SIN[4V] + ( - ----*B )SIN[3V] + (----*B 96 12 24 5 2 1 3 1 4 - ---*B )SIN[2V] + (---*B - 2*B)SIN[V] + (---*B - 1)] 4 4 8 %% Step 4: Substitute f and f' into S yy:=ff-ww; 103 4 13 3 11 4 5 2 YY := [(-----*E )SIN[4U] + (----*E )SIN[3U] + ( - ----*E + ---*E ) 96 12 24 4 1 3 103 4 SIN[2U] + ( - ---*E + 2*E)SIN[U] + ( - -----*B )SIN[4V] + ( 4 96 13 3 11 4 5 2 1 3 - ----*B )SIN[3V] + (----*B - ---*B )SIN[2V] + (---*B - 2*B) 12 24 4 4 1 4 1 4 SIN[V] + (---*B - ---*E )] 8 8 zz:=ff+ww; 103 4 13 3 11 4 ZZ := - [( - -----*E )SIN[4U] + ( - ----*E )SIN[3U] + (----*E 96 12 24 5 2 1 3 103 4 - ---*E )SIN[2U] + (---*E - 2*E)SIN[U] + ( - -----*B )SIN[4V] 4 4 96 13 3 11 4 5 2 1 3 + ( - ----*B )SIN[3V] + (----*B - ---*B )SIN[2V] + (---*B 12 24 4 4 1 4 1 4 - 2*B)SIN[V] + (---*B + ---*E - 2)] 8 8 xx:=hsub(fourier((1-d*d)*cos(u)),u,u-v+w-x-y+z,yy,n)+ hsub(fourier(d*d*cos(v)),v,u+v+w+x+y-z,zz,n); 625 4 4 3 XX := - [( - -----*E )COS[5U-V+W-X-Y+Z] + (---*B*E )COS[4U+W-X-Y+Z] 384 3 4 3 4 3 + ( - ---*E )COS[4U-V+W-X-Y+Z] + ( - ---*B*E )COS[4U-2V+W-X-Y+ 3 3 9 2 2 17 2 2 Z] + (---*D *E )COS[3U+V+W+X+Y-Z] + (----*D *E )SIN[3U+V+W+X+Y- 8 12 9 2 2 9 4 Z] + (----*B *E )COS[3U+V+W-X-Y+Z] + (-----*E )COS[3U+V-W+X+Y-Z 64 128 9 2 9 2 2 9 2 2 ] + (---*B*E )COS[3U+W-X-Y+Z] + (---*B *E + ---*D *E 8 8 8 27 4 9 2 9 2 + ----*E - ---*E )COS[3U-V+W-X-Y+Z] + ( - ---*B*E )COS[3U-2V+ 16 8 8 81 2 2 2 W-X-Y+Z] + ( - ----*B *E )COS[3U-3V+W-X-Y+Z] + (B*D *E)COS[2U+2 64 2 1 3 V+W+X+Y-Z] + (2*B*D *E)SIN[2U+2V+W+X+Y-Z] + (----*B *E)COS[2U+2 12 1 3 2 V+W-X-Y+Z] + (----*B*E )COS[2U+2V-W+X+Y-Z] + (D *E)COS[2U+V+W+X 12 2 2 1 2 +Y-Z] + (---*D *E)SIN[2U+V+W+X+Y-Z] + (---*B *E)COS[2U+V+W-X-Y+ 3 8 1 3 2 Z] + (----*E )COS[2U+V-W+X+Y-Z] + ( - B*D *E)COS[2U+W+X+Y-Z] + 12 2 2 5 3 ( - 2*B*D *E)SIN[2U+W+X+Y-Z] + ( - B*D *E - ---*B*E + B*E)COS[ 4 1 3 2 2 2U+W-X-Y+Z] + ( - ----*B*E )COS[2U-W+X+Y-Z] + (B *E + D *E 12 5 3 5 3 2 5 3 + ---*E - E)COS[2U-V+W-X-Y+Z] + (---*B *E + B*D *E + ---*B*E 4 4 4 9 2 - B*E)COS[2U-2V+W-X-Y+Z] + ( - ---*B *E)COS[2U-3V+W-X-Y+Z] + ( 8 4 3 9 2 2 - ---*B *E)COS[2U-4V+W-X-Y+Z] + (---*B *D )COS[U+3V+W+X+Y-Z] 3 8 17 2 2 9 4 + (----*B *D )SIN[U+3V+W+X+Y-Z] + (-----*B )COS[U+3V+W-X-Y+Z] 12 128 9 2 2 2 + (----*B *E )COS[U+3V-W+X+Y-Z] + (B*D )COS[U+2V+W+X+Y-Z] + ( 64 2 2 1 3 1 ---*B*D )SIN[U+2V+W+X+Y-Z] + (----*B )COS[U+2V+W-X-Y+Z] + (--- 3 12 8 2 2 2 2 2 1 2 *B*E )COS[U+2V-W+X+Y-Z] + ( - B *D - D *E + ---*D )COS[U+V+W+ 3 2 2 2 2 2 2 X+Y-Z] + ( - 2*B *D - 2*D *E + ---*D )SIN[U+V+W+X+Y-Z] + ( 3 1 4 1 2 2 1 2 2 1 2 - ----*B - ---*B *D - ---*B *E + ---*B )COS[U+V+W-X-Y+Z] + 48 8 8 8 1 2 2 1 2 2 1 4 1 2 ( - ---*B *E - ---*D *E - ----*E + ---*E )COS[U+V-W+X+Y-Z] 8 8 48 8 2 2 2 + ( - B*D )COS[U+W+X+Y-Z] + ( - ---*B*D )SIN[U+W+X+Y-Z] + ( 3 2 2 1 2 - B*D - B*E + B)COS[U+W-X-Y+Z] + ( - ---*B*E )COS[U-W+X+Y-Z] 8 1 2 2 7 2 2 + ( - ---*B *D )COS[U-V+W+X+Y-Z] + (----*B *D )SIN[U-V+W+X+Y-Z 8 12 7 4 2 2 2 2 2 2 2 2 7 4 ] + ( - ----*B - B *D - B *E + B - D *E + D - ----*E 64 64 2 1 4 1 4 + E - 1)COS[U-V+W-X-Y+Z] + (---*B - ---*E )SIN[U-V+W-X- 8 8 1 2 2 1 2 2 Y+Z] + ( - ----*B *E )COS[U-V-W+X+Y-Z] + ( - ---*D *E )COS[U-V- 64 8 7 2 2 5 3 2 W-X-Y+Z] + ( - ----*D *E )SIN[U-V-W-X-Y+Z] + (---*B + B*D 12 4 2 27 4 9 2 2 + B*E - B)COS[U-2V+W-X-Y+Z] + (----*B + ---*B *D 16 8 9 2 2 9 2 4 3 + ---*B *E - ---*B )COS[U-3V+W-X-Y+Z] + ( - ---*B )COS[U-4V+W 8 8 3 625 4 4 3 -X-Y+Z] + ( - -----*B )COS[U-5V+W-X-Y+Z] + (---*B *E)COS[4V-W+X 384 3 9 2 2 +Y-Z] + (---*B *E)COS[3V-W+X+Y-Z] + ( - B*D *E)COS[2V+W+X+Y-Z] 8 2 1 3 + ( - 2*B*D *E)SIN[2V+W+X+Y-Z] + ( - ----*B *E)COS[2V+W-X-Y+Z] 12 5 3 2 2 + ( - ---*B *E - B*D *E + B*E)COS[2V-W+X+Y-Z] + ( - D *E)COS[V 4 2 2 1 2 +W+X+Y-Z] + ( - ---*D *E)SIN[V+W+X+Y-Z] + ( - ---*B *E)COS[V+W- 3 8 2 2 2 X-Y+Z] + ( - B *E - D *E + E)COS[V-W+X+Y-Z] + (B*D *E)COS[W+X+Y 2 2 -Z] + (2*B*D *E)SIN[W+X+Y-Z] + (B*D *E - B*E)COS[W-X-Y+Z]] %% Step 5: Calculate R zz:=bb*vv; 1 4 3 3 3 3 ZZ := [( - ---*E )COS[4U] + ( - ----*B*E )COS[3U+V] + ( - ---*E )COS[ 3 16 8 3 3 1 2 2 3U] + ( - ----*B*E )COS[3U-V] + ( - ---*B *E )COS[2U+2V] + ( 16 4 1 2 1 4 1 2 1 2 - ---*B*E )COS[2U+V] + (---*E - ---*E )COS[2U] + ( - ---*B*E 4 3 2 4 1 2 2 9 3 )COS[2U-V] + ( - ---*B *E )COS[2U-2V] + ( - ----*B *E)COS[U+3V] 4 16 1 2 1 3 3 3 1 + ( - ---*B *E)COS[U+2V] + (----*B *E + ----*B*E - ---*B*E) 2 16 16 2 3 3 1 3 3 3 COS[U+V] + (---*E - E)COS[U] + (----*B *E + ----*B*E 8 16 16 1 1 2 9 3 - ---*B*E)COS[U-V] + ( - ---*B *E)COS[U-2V] + ( - ----*B *E) 2 2 16 4 4 9 3 1 4 COS[U-3V] + (---*B )COS[4V] + (---*B )COS[3V] + ( - ---*B 3 8 3 1 2 2 2 1 3 1 2 + ---*B *E + B )COS[2V] + ( - ---*B + ---*B*E + B)COS[V] + 2 8 2 1 2 (---*E + 1)] 2 yy:=zz*zz*vv; 1 4 3 3 1 3 YY := [( - ---*E )COS[4U] + ( - ---*B*E )COS[3U+V] + ( - ---*E )COS[3 6 8 4 3 3 9 2 2 U] + ( - ---*B*E )COS[3U-V] + ( - ---*B *E )COS[2U+2V] + ( 8 8 3 2 3 2 2 1 4 1 2 - ---*B*E )COS[2U+V] + ( - ---*B *E + ---*E - ---*E )COS[2U] 4 4 6 2 3 2 9 2 2 + ( - ---*B*E )COS[2U-V] + ( - ---*B *E )COS[2U-2V] + ( 4 8 53 3 9 2 27 3 - ----*B *E)COS[U+3V] + ( - ---*B *E)COS[U+2V] + ( - ----*B *E 8 2 8 3 3 2 1 3 + ---*B*E - 3*B*E)COS[U+V] + ( - 3*B *E + ---*E - 2*E)COS[U] 8 4 27 3 3 3 9 2 + ( - ----*B *E + ---*B*E - 3*B*E)COS[U-V] + ( - ---*B *E)COS 8 8 2 53 3 77 4 53 3 [U-2V] + ( - ----*B *E)COS[U-3V] + (----*B )COS[4V] + (----*B ) 8 8 8 7 4 27 2 2 9 2 27 3 COS[3V] + (---*B + ----*B *E + ---*B )COS[2V] + (----*B 2 4 2 8 9 2 15 4 9 2 2 3 2 + ---*B*E + 3*B)COS[V] + (----*B + ---*B *E + ---*B 2 8 4 2 3 2 + ---*E + 1)] 2 on fourier; *** Domain mode RATIONAL changed to FOURIER p(0):= fourier 1; P(0) := [1] p(1) := xx; 625 4 4 3 P(1) := - [( - -----*E )COS[5U-V+W-X-Y+Z] + (---*B*E )COS[4U+W-X-Y+Z 384 3 4 3 4 3 ] + ( - ---*E )COS[4U-V+W-X-Y+Z] + ( - ---*B*E )COS[4U-2V+W-X 3 3 9 2 2 17 2 2 -Y+Z] + (---*D *E )COS[3U+V+W+X+Y-Z] + (----*D *E )SIN[3U+V+W 8 12 9 2 2 9 4 +X+Y-Z] + (----*B *E )COS[3U+V+W-X-Y+Z] + (-----*E )COS[3U+V- 64 128 9 2 9 2 2 9 2 2 W+X+Y-Z] + (---*B*E )COS[3U+W-X-Y+Z] + (---*B *E + ---*D *E 8 8 8 27 4 9 2 9 2 + ----*E - ---*E )COS[3U-V+W-X-Y+Z] + ( - ---*B*E )COS[3U-2 16 8 8 81 2 2 2 V+W-X-Y+Z] + ( - ----*B *E )COS[3U-3V+W-X-Y+Z] + (B*D *E)COS[ 64 2 1 3 2U+2V+W+X+Y-Z] + (2*B*D *E)SIN[2U+2V+W+X+Y-Z] + (----*B *E) 12 1 3 2 COS[2U+2V+W-X-Y+Z] + (----*B*E )COS[2U+2V-W+X+Y-Z] + (D *E) 12 2 2 1 2 COS[2U+V+W+X+Y-Z] + (---*D *E)SIN[2U+V+W+X+Y-Z] + (---*B *E) 3 8 1 3 2 COS[2U+V+W-X-Y+Z] + (----*E )COS[2U+V-W+X+Y-Z] + ( - B*D *E) 12 2 2 COS[2U+W+X+Y-Z] + ( - 2*B*D *E)SIN[2U+W+X+Y-Z] + ( - B*D *E 5 3 1 3 - ---*B*E + B*E)COS[2U+W-X-Y+Z] + ( - ----*B*E )COS[2U-W+X+ 4 12 2 2 5 3 Y-Z] + (B *E + D *E + ---*E - E)COS[2U-V+W-X-Y+Z] + ( 4 5 3 2 5 3 ---*B *E + B*D *E + ---*B*E - B*E)COS[2U-2V+W-X-Y+Z] + ( 4 4 9 2 4 3 - ---*B *E)COS[2U-3V+W-X-Y+Z] + ( - ---*B *E)COS[2U-4V+W-X-Y 8 3 9 2 2 17 2 2 +Z] + (---*B *D )COS[U+3V+W+X+Y-Z] + (----*B *D )SIN[U+3V+W+X 8 12 9 4 9 2 2 +Y-Z] + (-----*B )COS[U+3V+W-X-Y+Z] + (----*B *E )COS[U+3V-W+ 128 64 2 2 2 X+Y-Z] + (B*D )COS[U+2V+W+X+Y-Z] + (---*B*D )SIN[U+2V+W+X+Y-Z 3 1 3 1 2 ] + (----*B )COS[U+2V+W-X-Y+Z] + (---*B*E )COS[U+2V-W+X+Y-Z] 12 8 2 2 2 2 1 2 2 2 + ( - B *D - D *E + ---*D )COS[U+V+W+X+Y-Z] + ( - 2*B *D 3 2 2 2 2 1 4 - 2*D *E + ---*D )SIN[U+V+W+X+Y-Z] + ( - ----*B 3 48 1 2 2 1 2 2 1 2 - ---*B *D - ---*B *E + ---*B )COS[U+V+W-X-Y+Z] + ( 8 8 8 1 2 2 1 2 2 1 4 1 2 - ---*B *E - ---*D *E - ----*E + ---*E )COS[U+V-W+X+Y-Z] 8 8 48 8 2 2 2 + ( - B*D )COS[U+W+X+Y-Z] + ( - ---*B*D )SIN[U+W+X+Y-Z] + ( 3 2 2 1 2 - B*D - B*E + B)COS[U+W-X-Y+Z] + ( - ---*B*E )COS[U-W+X+Y- 8 1 2 2 7 2 2 Z] + ( - ---*B *D )COS[U-V+W+X+Y-Z] + (----*B *D )SIN[U-V+W+X 8 12 7 4 2 2 2 2 2 2 2 2 +Y-Z] + ( - ----*B - B *D - B *E + B - D *E + D 64 7 4 2 1 4 - ----*E + E - 1)COS[U-V+W-X-Y+Z] + (---*B 64 8 1 4 1 2 2 - ---*E )SIN[U-V+W-X-Y+Z] + ( - ----*B *E )COS[U-V-W+X+Y-Z] 8 64 1 2 2 7 2 2 + ( - ---*D *E )COS[U-V-W-X-Y+Z] + ( - ----*D *E )SIN[U-V-W- 8 12 5 3 2 2 X-Y+Z] + (---*B + B*D + B*E - B)COS[U-2V+W-X-Y+Z] + ( 4 27 4 9 2 2 9 2 2 9 2 ----*B + ---*B *D + ---*B *E - ---*B )COS[U-3V+W-X-Y+Z] + 16 8 8 8 4 3 625 4 ( - ---*B )COS[U-4V+W-X-Y+Z] + ( - -----*B )COS[U-5V+W-X-Y+Z] 3 384 4 3 9 2 + (---*B *E)COS[4V-W+X+Y-Z] + (---*B *E)COS[3V-W+X+Y-Z] + ( 3 8 2 2 - B*D *E)COS[2V+W+X+Y-Z] + ( - 2*B*D *E)SIN[2V+W+X+Y-Z] + ( 1 3 5 3 2 - ----*B *E)COS[2V+W-X-Y+Z] + ( - ---*B *E - B*D *E + B*E) 12 4 2 2 2 COS[2V-W+X+Y-Z] + ( - D *E)COS[V+W+X+Y-Z] + ( - ---*D *E)SIN[ 3 1 2 2 2 V+W+X+Y-Z] + ( - ---*B *E)COS[V+W-X-Y+Z] + ( - B *E - D *E 8 2 2 + E)COS[V-W+X+Y-Z] + (B*D *E)COS[W+X+Y-Z] + (2*B*D *E)SIN[W+ 2 X+Y-Z] + (B*D *E - B*E)COS[W-X-Y+Z]] for i := 2:n/2+2 do << wtlevel n+4-2i; p(i) := fourier ((2*i-1)/i)*xx*p(i-1) - fourier ((i-1)/i)*p(i-2); >>; wtlevel n; for i:=n/2+2 step -1 until 3 do p(n/2+2):=fourier(a*a)*zz*p(n/2+2)+p(i-1); yy*p(n/2+2); 27 4 25 3 [(----*E )COS[6U-2V+2W-2X-2Y+2Z] + ( - ----*B*E )COS[5U-V+2W-2X-2Y+2Z 32 64 25 3 75 2 2 ] + (----*E )COS[5U-2V+2W-2X-2Y+2Z] + (----*A *E )COS[5U-3V+3W-3X-3Y+ 32 64 175 3 13 2 2 3Z] + (-----*B*E )COS[5U-3V+2W-2X-2Y+2Z] + ( - ----*D *E )COS[4U+2W] 64 8 2 2 1 4 3 2 + ( - 2*D *E )SIN[4U+2W] + ( - ----*E )COS[4U] + ( - ---*B*E )COS[4U 24 8 15 2 -V+2W-2X-2Y+2Z] + ( - ----*A *B*E)COS[4U-2V+3W-3X-3Y+3Z] + ( 16 15 2 2 3 2 2 15 4 3 2 - ----*B *E - ---*D *E - ----*E + ---*E )COS[4U-2V+2W-2X-2Y+2Z] 8 2 8 4 15 2 21 2 + (----*A *E)COS[4U-3V+3W-3X-3Y+3Z] + (----*B*E )COS[4U-3V+2W-2X-2Y+ 16 8 35 4 75 2 2Z] + (----*A )COS[4U-4V+4W-4X-4Y+4Z] + (----*A *B*E)COS[4U-4V+3W-3X- 64 16 51 2 2 9 2 3Y+3Z] + (----*B *E )COS[4U-4V+2W-2X-2Y+2Z] + ( - ---*B*D *E)COS[3U+V 8 4 7 2 1 3 +2W] + ( - ---*B*D *E)SIN[3U+V+2W] + (----*B *E)COS[3U+V+2W-2X-2Y+2Z] 2 64 3 3 3 2 2 + ( - ----*B*E )COS[3U+V] + ( - ---*D *E)COS[3U+2W] + ( - D *E)SIN[3 32 2 1 3 5 2 2 U+2W] + ( - ----*E )COS[3U] + ( - ---*A *D )COS[3U-V+3W-X-Y+Z] + ( 16 8 5 2 2 5 2 2 - ---*A *D )SIN[3U-V+3W-X-Y+Z] + (----*A *B )COS[3U-V+3W-3X-3Y+3Z] 4 64 9 2 1 2 + ( - ---*B*D *E)COS[3U-V+2W] + (---*B*D *E)SIN[3U-V+2W] + ( 4 2 3 3 3 2 57 3 3 ----*B *E + ---*B*D *E + ----*B*E - ---*B*E)COS[3U-V+2W-2X-2Y+2Z] + 64 4 64 8 9 2 2 3 3 ( - ----*A *E )COS[3U-V+W-X-Y+Z] + ( - ----*B*E )COS[3U-V] + ( 64 32 5 2 15 2 3 2 - ---*A *B)COS[3U-2V+3W-3X-3Y+3Z] + ( - ----*B *E - ---*D *E 8 8 2 57 3 3 15 2 2 - ----*E + ---*E)COS[3U-2V+2W-2X-2Y+2Z] + ( - ----*A *B 32 4 4 15 2 2 15 2 2 5 2 - ----*A *D - ----*A *E + ---*A )COS[3U-3V+3W-3X-3Y+3Z] + ( 8 4 8 369 3 21 2 399 3 21 - -----*B *E - ----*B*D *E - -----*B*E + ----*B*E)COS[3U-3V+2W-2X-2 64 4 64 8 25 2 51 2 Y+2Z] + (----*A *B)COS[3U-4V+3W-3X-3Y+3Z] + (----*B *E)COS[3U-4V+2W-2 8 8 635 2 2 845 3 X-2Y+2Z] + (-----*A *B )COS[3U-5V+3W-3X-3Y+3Z] + (-----*B *E)COS[3U-5 64 64 1 4 1 4 V+2W-2X-2Y+2Z] + ( - ---*D )COS[2U+2V+2W+2X+2Y-2Z] + (---*D )SIN[2U+2 4 3 11 2 2 13 2 2 V+2W+2X+2Y-2Z] + ( - ----*B *D )COS[2U+2V+2W] + ( - ----*B *D )SIN[2U 4 4 1 4 2 2 +2V+2W] + (----*B )COS[2U+2V+2W-2X-2Y+2Z] + (D *E )COS[2U+2V+2X+2Y-2Z 32 3 2 2 9 2 2 ] + ( - ---*D *E )SIN[2U+2V+2X+2Y-2Z] + ( - ----*B *E )COS[2U+2V] + ( 4 32 3 4 7 2 - ----*E )COS[2U+2V-2W+2X+2Y-2Z] + ( - ---*B*D )COS[2U+V+2W] + ( 64 4 3 2 1 3 - ---*B*D )SIN[2U+V+2W] + (----*B )COS[2U+V+2W-2X-2Y+2Z] + ( 2 64 3 2 7 2 2 1 4 17 2 2 1 2 - ----*B*E )COS[2U+V] + ( - ---*B *D + ---*D + ----*D *E - ---*D 16 4 2 4 2 1 2 2 4 9 2 2 2 )COS[2U+2W] + (---*B *D + D + ---*D *E - D )SIN[2U+2W] + ( 2 2 3 2 3 2 2 3 2 2 1 4 - ----*A *B*E)COS[2U+W-X-Y+Z] + ( - ----*B *E + ---*D *E + ----*E 16 16 4 24 1 2 1 2 3 2 - ---*E )COS[2U] + (---*B*D )COS[2U-V+2W] + ( - ---*B*D )SIN[2U-V+2W 8 4 2 3 3 3 2 15 2 3 ] + (----*B + ---*B*D + ----*B*E - ---*B)COS[2U-V+2W-2X-2Y+2Z] + ( 64 4 16 8 3 2 3 2 45 2 - ----*A *E)COS[2U-V+W-X-Y+Z] + ( - ----*B*E )COS[2U-V] + (----*A *B 16 16 16 3 2 2 13 2 2 *E)COS[2U-2V+3W-3X-3Y+3Z] + (---*B *D )COS[2U-2V+2W] + ( - ----*B *D 2 4 5 4 39 4 15 2 2 75 2 2 )SIN[2U-2V+2W] + (----*A + ----*B + ----*B *D + ----*B *E 16 64 4 16 15 2 3 4 15 2 2 3 2 69 4 - ----*B + ---*D + ----*D *E - ---*D + ----*E 8 4 4 2 64 15 2 3 - ----*E + ---)COS[2U-2V+2W-2X-2Y+2Z] + ( 8 4 3 4 3 4 9 2 - ----*B + ----*E )SIN[2U-2V+2W-2X-2Y+2Z] + ( - ----*A *B*E)COS[2U- 16 16 16 9 2 2 1 2 2 2V+W-X-Y+Z] + ( - ----*B *E )COS[2U-2V] + (---*D *E )COS[2U-2V-2X-2Y+ 32 4 3 2 2 45 2 2Z] + (---*D *E )SIN[2U-2V-2X-2Y+2Z] + ( - ----*A *E)COS[2U-3V+3W-3X- 4 16 369 3 21 2 105 2 21 3Y+3Z] + ( - -----*B - ----*B*D - -----*B*E + ----*B)COS[2U-3V+2W- 64 4 16 8 225 2 115 4 2X-2Y+2Z] + ( - -----*A *B*E)COS[2U-4V+3W-3X-3Y+3Z] + ( - -----*B 16 8 51 2 2 255 2 2 51 2 845 - ----*B *D - -----*B *E + ----*B )COS[2U-4V+2W-2X-2Y+2Z] + (----- 4 16 8 64 3 1599 4 1 *B )COS[2U-5V+2W-2X-2Y+2Z] + (------*B )COS[2U-6V+2W-2X-2Y+2Z] + (--- 64 4 2 3 2 *B*D *E)COS[U+3V+2X+2Y-2Z] + (---*B*D *E)SIN[U+3V+2X+2Y-2Z] + ( 2 53 3 49 3 - ----*B *E)COS[U+3V] + ( - ----*B*E )COS[U+3V-2W+2X+2Y-2Z] + ( 32 64 1 2 2 - ---*D *E)COS[U+2V+2X+2Y-2Z] + (D *E)SIN[U+2V+2X+2Y-2Z] + ( 2 9 2 7 3 23 - ---*B *E)COS[U+2V] + ( - ----*E )COS[U+2V-2W+2X+2Y-2Z] + (----*B 8 32 4 2 13 2 3 3 *D *E)COS[U+V+2W] + (----*B*D *E)SIN[U+V+2W] + ( - ----*B *E)COS[U+V+ 2 64 3 2 2 3 2 2 2W-2X-2Y+2Z] + ( - ---*A *D )COS[U+V+W+X+Y-Z] + ( - ---*A *D )SIN[U+V 4 2 33 2 2 7 2 +W+X+Y-Z] + (----*A *B )COS[U+V+W-X-Y+Z] + ( - ---*B*D *E)COS[U+V+2X+ 64 4 3 2 27 3 9 2 2Y-2Z] + (---*B*D *E)SIN[U+V+2X+2Y-2Z] + ( - ----*B *E + ---*B*D *E 2 32 2 3 3 3 33 2 2 + ----*B*E - ---*B*E)COS[U+V] + (----*A *E )COS[U+V-W+X+Y-Z] + ( 32 4 64 7 3 5 2 2 ----*B*E )COS[U+V-2W+2X+2Y-2Z] + (---*D *E)COS[U+2W] + (3*D *E)SIN[U+ 64 2 3 2 3 2 2 1 3 2W] + (---*A *B)COS[U+W-X-Y+Z] + ( - ---*B *E + 3*D *E + ----*E 8 4 16 1 7 2 5 2 - ---*E)COS[U] + (---*B*D *E)COS[U-V+2W] + (---*B*D *E)SIN[U-V+2W] 2 4 2 9 3 9 2 39 3 9 + ( - ----*B *E - ---*B*D *E - ----*B*E + ---*B*E)COS[U-V+2W-2X-2Y+ 64 4 64 8 3 2 2 33 2 2 3 2 2 3 2 2Z] + (---*A *B - ----*A *D + ---*A *E + ---*A )COS[U-V+W-X-Y+Z] 4 8 4 8 27 3 9 2 3 3 3 + ( - ----*B *E + ---*B*D *E + ----*B*E - ---*B*E)COS[U-V] + ( 32 2 32 4 3 2 5 2 - ---*B*D *E)COS[U-V-2X-2Y+2Z] + (---*B*D *E)SIN[U-V-2X-2Y+2Z] + ( 4 2 45 2 9 2 39 3 9 9 ----*B *E + ---*D *E + ----*E - ---*E)COS[U-2V+2W-2X-2Y+2Z] + (--- 8 2 32 4 8 2 9 2 3 2 *A *B)COS[U-2V+W-X-Y+Z] + ( - ---*B *E)COS[U-2V] + (---*D *E)COS[U-2V 8 2 2 285 2 2 -2X-2Y+2Z] + ( - D *E)SIN[U-2V-2X-2Y+2Z] + (-----*A *E )COS[U-3V+3W-3 64 1107 3 63 2 273 3 63 X-3Y+3Z] + (------*B *E + ----*B*D *E + -----*B*E - ----*B*E)COS[U-3 64 4 64 8 159 2 2 5 2 2 V+2W-2X-2Y+2Z] + (-----*A *B )COS[U-3V+W-X-Y+Z] + ( - ---*A *D )COS[U 64 8 5 2 2 53 3 -3V+W-3X-3Y+3Z] + (---*A *D )SIN[U-3V+W-3X-3Y+3Z] + ( - ----*B *E)COS 4 32 21 2 11 2 [U-3V] + (----*B*D *E)COS[U-3V-2X-2Y+2Z] + ( - ----*B*D *E)SIN[U-3V-2 4 2 153 2 2535 3 X-2Y+2Z] + ( - -----*B *E)COS[U-4V+2W-2X-2Y+2Z] + ( - ------*B *E)COS 8 64 63 2 2 19 2 2 [U-5V+2W-2X-2Y+2Z] + ( - ----*B *D )COS[4V+2X+2Y-2Z] + ( - ----*B *D 8 2 77 4 255 2 2 )SIN[4V+2X+2Y-2Z] + (----*B )COS[4V] + (-----*B *E )COS[4V-2W+2X+2Y-2 32 16 11 2 7 2 Z] + ( - ----*B*D )COS[3V+2X+2Y-2Z] + ( - ---*B*D )SIN[3V+2X+2Y-2Z] 4 2 53 3 105 2 17 2 2 + (----*B )COS[3V] + (-----*B*E )COS[3V-2W+2X+2Y-2Z] + (----*B *D 32 16 4 1 4 7 2 2 1 2 9 2 2 4 + ---*D - ---*D *E - ---*D )COS[2V+2X+2Y-2Z] + (---*B *D + D 2 4 2 2 1 2 2 2 7 4 27 2 2 + ---*D *E - D )SIN[2V+2X+2Y-2Z] + (---*B - ----*B *D 2 8 4 27 2 2 9 2 45 2 + ----*B *E + ---*B )COS[2V] + ( - ----*A *B*E)COS[2V-W+X+Y-Z] + ( 16 8 16 75 2 2 15 2 2 15 2 5 2 - ----*B *E - ----*D *E + ----*E )COS[2V-2W+2X+2Y-2Z] + (---*B*D ) 16 4 8 4 1 2 27 3 9 2 COS[V+2X+2Y-2Z] + (---*B*D )SIN[V+2X+2Y-2Z] + (----*B - ---*B*D 2 32 2 9 2 3 15 2 + ---*B*E + ---*B)COS[V] + ( - ----*A *E)COS[V-W+X+Y-Z] + ( 8 4 16 15 2 25 2 2 - ----*B*E )COS[V-2W+2X+2Y-2Z] + ( - ----*D *E )COS[2W] + ( 16 8 7 2 2 15 2 5 2 2 - ---*D *E )SIN[2W] + ( - ----*A *B*E)COS[W-X-Y+Z] + (---*B *D )COS[ 2 16 8 2 2 9 4 15 4 9 2 2 2X+2Y-2Z] + ( - B *D )SIN[2X+2Y-2Z] + (----*A + ----*B - ---*B *D 64 32 4 9 2 2 3 2 7 4 9 2 2 3 2 3 2 1 + ----*B *E + ---*B + ---*D - ---*D *E - ---*D + ---*E + ---)] 16 8 6 4 2 8 4 showtime; Time: 15232 ms plus GC time: 578 ms end; Time: 0 ms Quitting |
Added r34.1/lib/camal.red version [3c88890c55].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%off comp; lisp; %%module foursupport; %% This section is to define macros and simple functions to handle the %% data structures for harmonic forms. %% The structure is a vector: %% Coeff | FN | Angle | Next % %% This version only allows 8 angles. Consider extending this later. switch fourier; %% A vector and counter to record link between angle names and index global '(next!-angle!* fourier!-name!*); next!-angle!* := 0; if vectorp fourier!-name!* then << for i :=0:7 do remprop(getv(fourier!-name!*, i), 'fourier!-angle) >>; fourier!-name!* := mkvect 7; %% For non Cambridge LISP add smacro procedure putv!.unsafe(x,y,z); putv(x,y,z); smacro procedure getv!.unsafe(x,y); getv(x,y); %% Data abtraction says that we should define macros for access to %% the parts of the Fourier structure smacro procedure fs!:set!-next(f,p); putv!.unsafe(f, 3, p); smacro procedure fs!:next(f); getv!.unsafe(f,3); smacro procedure fs!:set!-coeff(f,p); putv!.unsafe(f, 0, p); smacro procedure fs!:coeff(f); getv!.unsafe(f, 0); smacro procedure fs!:set!-fn(f,p); putv!.unsafe(f, 1, p); smacro procedure fs!:fn(f); getv!.unsafe(f, 1); smacro procedure fs!:set!-angle(f,p); putv!.unsafe(f, 2, p); smacro procedure fs!:angle(f); getv!.unsafe(f, 2); %% Some support functions for angle expressions symbolic procedure fs!:make!-nullangle(); begin scalar ans; ans := mkvect 7; for i:=0:7 do putv!.unsafe(ans,i,0); return ans; end; symbolic procedure fs!:null!-angle!: u; fs!:null!-angle cdr u; symbolic procedure fs!:null!-angle u; begin scalar ans, i, x; x := fs!:angle u; ans := t; i := 0; top: if not(getv!.unsafe(x,i)=0) then return nil; i := i+1; if (i<8) then go to top; return ans; end; %%module fourdom; % Domain definitions for angles and fourier series % Authors: John Fitch 1991 global '(domainlist!*); domainlist!*:=union('(!:fs!:),domainlist!*); put('fourier,'tag,'!:fs!:); put('!:fs!:,'dname,'fourier); flag('(!:fs!:),'field); %% Should be ring really put('!:fs!:,'i2d,'i2fourier); put('!:fs!:,'minusp,'fs!:minusp!:); put('!:fs!:,'plus,'fs!:plus!:); put('!:fs!:,'times,'fs!:times!:); put('!:fs!:, 'expt,'fs!:expt!:); put('!:fs!:,'difference,'fs!:difference!:); put('!:fs!:,'quotient,'fs!:quotient!:); put('!:fs!:, 'divide, 'fs!:divide!:); put('!:fs!:, 'gcd, 'fs!:gcd!:); put('!:fs!:,'zerop,'fs!:zerop!:); put('!:fs!:,'onep,'fs!:onep!:); put('!:fs!:,'prepfn,'fs!:prepfn!:); put('!:fs!:,'specprn,'fs!:prin!:); put('!:fs!:,'prifn,'fs!:prin!:); put('!:fs!:,'intequivfn,'fs!:intequiv!:); flag('(!:fs!:),'ratmode); % conversion functions put('!:fs!:,'!:mod!:,mkdmoderr('!:fs!:,'!:mod!:)); % put('!:fs!:,'!:gi!:,mkdmoderr('!:fs!:,'!:gi!:)); % put('!:fs!:,'!:bf!:,mkdmoderr('!:fs!:,'!:bf!:)); % put('!:fs!:,'!:rn!:,mkdmoderr('!:fs!:,'!:rn!:)); put('!:rn!:,'!:fs!:,'!*d2fourier); put('!:ft!:,'!:fs!:,'cdr); put('!:bf!:,'!:fs!:,'!*d2fourier); put('!:gi!:,'!:fs!:,'!*d2fourier); put('!:gf!:,'!:fs!:,'!*d2fourier); put('expt, '!:fs!:, 'fs!:expt!:); % Conversion functions symbolic procedure i2fourier u; if dmode!*='!:fs!: then !*d2fourier u else u; symbolic procedure !*d2fourier u; if null u then nil else begin scalar fourier; fourier:=mkvect 3; fs!:set!-coeff(fourier,(u . 1)); fs!:set!-fn(fourier,'cos); fs!:set!-angle(fourier,fs!:make!-nullangle()); fs!:set!-next(fourier,nil); return get('fourier,'tag) . fourier end; symbolic procedure !*sq2fourier u; if null car u then nil else begin scalar fourier; fourier:=mkvect 3; fs!:set!-coeff(fourier,u); fs!:set!-fn(fourier,'cos); fs!:set!-angle(fourier,fs!:make!-nullangle()); fs!:set!-next(fourier,nil); return get('fourier,'tag) . fourier end; symbolic procedure fs!:minusp!:(x); fs!:minusp cdr x; symbolic procedure fs!:minusp x; if null x then nil else if null fs!:next x then minusf car fs!:coeff x else fs!:minusp fs!:next x; %% Basic algebraic operations symbolic procedure fs!:times!:(x,y); % This function seems to be called with numeric values as well if null x then nil else if null y then nil else if numberp y then get('fourier,'tag) . fs!:timescoeff(y ./ 1, cdr x) else if numberp x then get('fourier,'tag) . fs!:timescoeff(x ./ 1, cdr y) else if not eqcar(x, get('fourier,'tag)) then get('fourier,'tag) . fs!:timescoeff(x,cdr y) else if not eqcar(y, get('fourier,'tag)) then get('fourier,'tag) . fs!:timescoeff(y,cdr x) else get('fourier,'tag) . fs!:times(cdr x, cdr y); symbolic procedure fs!:timescoeff(x, y); if null y then nil else begin scalar ans, coeff; coeff := multsq(x,fs!:coeff y); if coeff = '(nil . 1) then << print "zero in times"; return fs!:timescoeff(x, fs!:next y) >>; ans := mkvect 3; fs!:set!-coeff(ans,coeff); fs!:set!-fn(ans,fs!:fn y); fs!:set!-angle(ans,fs!:angle y); fs!:set!-next(ans, fs!:timescoeff(x, fs!:next y)); return ans end; symbolic procedure fs!:times(x,y); if null x then nil else if null y then nil else begin scalar ans; ans := fs!:timesterm(x, y); return fs!:plus(ans, fs!:times(fs!:next x, y)); end; symbolic procedure fs!:timesterm(x,y); % Treat x as a term and y as a tree if null y then nil else if null x then nil else begin scalar ans; ans := fs!:timestermterm(x,y); return fs!:plus(ans, fs!:timesterm(x, fs!:next y)); end; symbolic procedure fs!:timestermterm(x,y); % x and y are terms. Generate the two answer terms. begin scalar sum, diff, ans, xv, yv, coeff; sum := mkvect 7; xv := fs!:angle x; yv := fs!:angle y; for i:=0:7 do putv!.unsafe(sum,i, getv!.unsafe(xv,i)+getv!.unsafe(yv,i)); diff := mkvect 7; for i:=0:7 do putv!.unsafe(diff,i, getv!.unsafe(xv,i)-getv!.unsafe(yv,i)); coeff := multsq(fs!:coeff x, fs!:coeff y); coeff := multsq(coeff, '(1 . 2)); if null car coeff then return nil; if fs!:fn x = 'sin then if fs!:fn y = 'sin then % sin x*sin y => [-cos(x+y)+cos(x-y)]/2 return fs!:plus(make!-term('cos, sum, negsq coeff), make!-term('cos,diff, coeff)) else % fs!:fn y = 'cos % sin x * cos y => [sin(x+y)+sin(x-y)]/2 return fs!:plus(make!-term('sin, sum, coeff), make!-term('sin, diff,coeff)) else % fs!:fn x='cos if fs!:fn y = 'sin then % cos x*sin y => [sin(x+y)-sin(x-y)]/2 return fs!:plus(make!-term('sin, sum, coeff), make!-term('sin,diff, negsq coeff)) else % fs!:fn y = 'cos % cos x * cos y => [cos(x+y)+cos(x-y)]/2 return fs!:plus(make!-term('cos, sum, coeff), make!-term('cos, diff,coeff)) end; symbolic procedure fs!:expt!:(x,n); begin scalar ans, xx; ans := cdr !*d2fourier 1; x := cdr x; for i:=1:n do ans := fs!:times(ans,x); return get('fourier,'tag) . ans; end; symbolic procedure make!-term(fn, ang, coeff); begin scalar fourier, sign, i; sign := 0; i:=0; top: if getv!.unsafe(ang,i)<0 then sign := -1 else if getv!.unsafe(ang,i)>0 then sign := 1 else if i=7 then << if fn ='sin then return nil >> else << i := i #+ 1; goto top >>; fourier:=mkvect 3; if sign = 1 or fn = 'cos then fs!:set!-coeff(fourier,coeff) else fs!:set!-coeff(fourier, multsq('(-1 . 1), coeff)); fs!:set!-fn(fourier,fn); if sign = -1 then << sign := mkvect 7; for i:=0:7 do putv!.unsafe(sign,i,-getv!.unsafe(ang,i)); ang := sign >>; fs!:set!-angle(fourier,ang); fs!:set!-next(fourier,nil); return fourier end; symbolic procedure fs!:quotient!:(x,y); if numberp y then fs!:times!:(x, !*sq2fourier (1 ./ y)) else rerror(fourier, 98, "Unimplemented"); symbolic procedure fs!:divide!:(x,y); rerror(fourier, 98, "Unimplemented"); symbolic procedure fs!:gcd!:(x,y); rerror(fourier, 98, "Unimplemented"); symbolic procedure fs!:difference!:(x,y); fs!:plus!:(x, fs!:negate!: y); symbolic procedure fs!:negate!: x; get('fourier,'tag) . fs!:negate cdr x; symbolic procedure fs!:negate x; if null x then nil else begin scalar ans; ans := mkvect 3; fs!:set!-coeff(ans,negsq fs!:coeff x); fs!:set!-fn(ans,fs!:fn x); fs!:set!-angle(ans,fs!:angle x); fs!:set!-next(ans, fs!:negate fs!:next x); return ans end; symbolic procedure fs!:zerop!:(u); null u or (not numberp u and null cdr u or (null fs!:next cdr u and ((numberp v and zerop v) where v=fs!:coeff cdr u))); symbolic procedure fs!:onep!:(u); fs!:onep cdr u; symbolic procedure fs!:onep u; null fs!:next u and onep fs!:coeff u and fs!:null!-angle u and fs!:fn(u) = 'cos; symbolic procedure fs!:prepfn!:(x); x; symbolic procedure simpfs u; u; put('!:fs!:,'simpfn,'simpfs); %% PRINTING FUNCTIONS %% We have all the usual problems of unit coefficients, and zero angles smacro procedure zeroterm x; fs!:coeff x = '(nil . 1); symbolic procedure fs!:prin!:(x); << prin2!* "["; fs!:prin cdr x; prin2!* "]" >>; symbolic procedure fs!:prin x; if null x then prin2!* " 0 " else << while x do << fs!:prin1 x; x := fs!:next x; if x then prin2!* " + " >> >>; symbolic procedure fs!:prin1 x; begin scalar first, u, v; first := t; if not(fs!:coeff x = '(1 . 1)) then << prin2!* "("; sqprint fs!:coeff x; prin2!* ")" >>; if not(fs!:null!-angle x) then << prin2!* fs!:fn x; prin2!* "["; u := fs!:angle x; for i:=0:7 do if not((v := getv!.unsafe(u,i)) = 0) then << if v<0 then << first := t; prin2!* "-"; v := -v >>; if not first then prin2!* "+"; if not(v=1) then prin2!* v; first := nil; prin2!* getv!.unsafe(fourier!-name!*, i) >>; prin2!* "]" >> else if fs!:coeff x = '(1 . 1) then prin2!* "1" end; symbolic procedure fs!:intequiv!:(u); null fs!:next x and fs!:null!-angle x and fs!:fn(x) = 'cos and fixp car fs!:coeff x and cdr fs!:coeff x = 1 where x = cdr u; %%module fourplus; %% ARITHMETIC %% Addition of Fourier expressionsis really a merge operation symbolic procedure fs!:plus!:(x,y); %% Top level addition of two fourier series if fs!:zerop!: y then x else if fs!:zerop!: x then y else get('fourier,'tag) . fs!:plus(copy!-tree cdr x, copy!-tree cdr y); % I cannot rely on the CAMAL selective copy, so I take the coward's way out symbolic procedure copy!-tree x; if null x then nil else begin scalar ans; ans := mkvect 3; fs!:set!-coeff(ans,fs!:coeff x); fs!:set!-fn(ans,fs!:fn x); fs!:set!-angle(ans,fs!:angle x); fs!:set!-next(ans, copy!-tree fs!:next x); return ans end; symbolic procedure fs!:plus(x, y); %% The real addition. x is a new tree to which y must be merged. if null y then x else if null x then y else if fs!:fn x = fs!:fn y and angles!-equal(fs!:angle x, fs!:angle y) then begin scalar coef; coef := addsq(fs!:coeff x, fs!:coeff y); % Really I should deal with the zero case here if null car coef then return fs!:plus(fs!:next x, fs!:next y); fs!:set!-coeff(x, coef); fs!:set!-next(x, fs!:plus(fs!:next x, fs!:next y)); return x end else if fs!:angle!-order(x, y) then << fs!:set!-next(x, fs!:plus(fs!:next x, y)); x >> else << fs!:set!-next(y, fs!:plus(fs!:next y,x)); y >>; symbolic procedure angles!-equal(x, y); % Are all angles the same? begin scalar i; i := 0; top: if not(getv!.unsafe(x,i)=getv!.unsafe(y,i)) then return nil; i := i+1; if (i<8) then go to top; return t; end; symbolic procedure fs!:angle!-order(x, y); % Ordering function for angle expressions, also taking account of angle. begin scalar ans, i, xx, yy; i := 0; xx := fs!:angle x; yy := fs!:angle y; |