COPYRIGHT 644 10266 36 11635 5351046515 5502 TERMS AND CONDITIONS FOR USE OF "ICOT FREE SOFTWARE" 1. Purposes and Background of "ICOT Free Software." The Institute for New Generation Computer Technology ("ICOT") has been promoting the Fifth Generation Computer Systems project (the "Project") under the commitment of the Ministry of International Trade and Industry of Japan (the "MITI"). The Project is aimed at creating basic technology for novel computers that realizes parallel inference processing as its core mechanism, and contributing toward the progress of computer science by sharing the innovative knowledge and technology with the research community worldwide. Innovative hardware and software parallel inference technology was developed through the Project, which involved varieties of advanced software for experiments and evaluation. This software, being at a basic stage of research and development, should be diffused widely to the research community. According to the aims of the Project, ICOT decided to make this software, the copyright of which does not belong to the government but to ICOT itself, available to the public in order to contribute to the world, and, moreover, removed all the restrictions on its usage that may impede further research and development in order that large numbers of researchers can use it freely to begin a new era of computer science. This program together with any attached documentation (collec- tively, the "Program") is being distributed by ICOT free of charge as "ICOT Free Software." 2. Free Use, Modification, Copying and Distribution. Persons wanting to use the Program ("Users") may freely do so and may also freely modify and copy the Program. The term "modify," as used here, includes, but is not limited to, any act to improve or expand the Program for the purposes of enhancing and/or improving its function, performance and/or quality as well as to add one or more programs or documents developed by Users of the Program. Each User may also freely distribute the Program, whether in its original form or modified, to any third party or parties, PROVIDED, that the provisions of Section 3 ("NO WARRANTY") will ALWAYS appear on, or be attached to, the Program, which is distributed substantially in the same form as set out herein and that such intended distribution, if actually made, will neither violate or otherwise contravene any of the laws and regulations of the countries having jurisdiction over the User or the intended distribution itself. 3. NO WARRANTY THE PROGRAM WAS PRODUCED ON AN EXPERIMENTAL BASIS IN THE COURSE OF THE RESEARCH AND DEVELOPMENT CONDUCTED DURING THE PROJECT AND IS PROVIDED TO USERS AS SO PRODUCED ON AN EXPERIMENTAL BASIS. ACCORDINGLY, THE PROGRAM IS PROVIDED WITHOUT ANY WARRANTY WHATSOEVER, WHETHER EXPRESS, IMPLIED, STATUTORY OR OTHERWISE. THE TERM "WARRANTY" USED HEREIN INCLUDES, BUT IS NOT LIMITED TO, ANY WARRANTY OF THE QUALITY, PERFORMANCE, MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE OF THE PROGRAM AND THE NONEXISTENCE OF ANY INFRINGEMENT OR VIOLATION OF ANY RIGHT OF ANY THIRD PARTY. EACH USER OF THE PROGRAM WILL AGREE AND UNDERSTAND, AND BE DEEMED TO HAVE AGREED AND UNDERSTOOD, THAT THERE IS NO WARRANTY WHATSOEVER FOR THE PROGRAM AND, ACCORDINGLY, THE ENTIRE RISK ARISING FROM OR OTHERWISE CONNECTED WITH THE PROGRAM IS ASSUMED BY THE USER. THEREFORE, NEITHER ICOT, THE COPYRIGHT HOLDER, OR ANY OTHER ORGANIZATION THAT PARTICIPATED IN OR WAS OTHERWISE RELATED TO THE DEVELOPMENT OF THE PROGRAM AND THEIR RESPECTIVE OFFICIALS, DIRECTORS, OFFICERS AND OTHER EMPLOYEES SHALL BE HELD LIABLE FOR ANY AND ALL DAMAGES, INCLUDING, WITHOUT LIMITATION, GENERAL, SPECIAL, INCIDENTAL AND CONSEQUENTIAL DAMAGES, ARISING OUT OF OR OTHERWISE IN CONNECTION WITH THE USE OR INABILITY TO USE THE PROGRAM OR ANY PRODUCT, MATERIAL OR RESULT PRODUCED OR OTHERWISE OBTAINED BY USING THE PROGRAM, REGARDLESS OF WHETHER THEY HAVE BEEN ADVISED OF, OR OTHERWISE HAD KNOWLEDGE OF, THE POSSIBILITY OF SUCH DAMAGES AT ANY TIME DURING THE PROJECT OR THEREAFTER. EACH USER WILL BE DEEMED TO HAVE AGREED TO THE FOREGOING BY HIS OR HER COMMENCEMENT OF USE OF THE PROGRAM. THE TERM "USE" AS USED HEREIN INCLUDES, BUT IS NOT LIMITED TO, THE USE, MODIFICATION, COPYING AND DISTRIBUTION OF THE PROGRAM AND THE PRODUCTION OF SECONDARY PRODUCTS FROM THE PROGRAM. IN THE CASE WHERE THE PROGRAM, WHETHER IN ITS ORIGINAL FORM OR MODIFIED, WAS DISTRIBUTED OR DELIVERED TO OR RECEIVED BY A USER FROM ANY PERSON, ORGANIZATION OR ENTITY OTHER THAN ICOT, UNLESS IT MAKES OR GRANTS INDEPENDENTLY OF ICOT ANY SPECIFIC WARRANTY TO THE USER IN WRITING, SUCH PERSON, ORGANIZATION OR ENTITY, WILL ALSO BE EXEMPTED FROM AND NOT BE HELD LIABLE TO THE USER FOR ANY SUCH DAMAGES AS NOTED ABOVE AS FAR AS THE PROGRAM IS CONCERNED. COPYRIGHT.j 644 10266 36 6764 5351046516 5722 ICOT$BL5=~8x3+%=%U%H%&%'%"$NMxMQ>r7o(B $B#1!%(BICOT$BL5=~8x3+%=%U%H%&%'%"$NL\E*(B $B:bCDK!?M?7@$Be%3%s%T%e!<%?5;=Q3+H/5!9=(B ($B0J2&;:6H>J$h$j0QBw$5$l!"Bh8^@$Be%3%s%T%e!<%?!&%W%m%8%'%/%H$r?d?J$7$F$-(B $B$?!#$3$N%W%m%8%'%/%H$O!"JBNs?dO@=hM}$rCf3K%a%+%K%:%`$H$9$k?7$7$$%3%s%T(B $B%e!<%?$N4pAC5;=Q$rAO=P$7!"$=$NCN8+$H5;=Q$r@$3&$N8&5fc32$H$J$k$$$C$5$$$N@)Ls$r$O$:$9$3$H$K$h$C$F!"(B $BB?$/$N8&5fe$5$;$k$?$a$K2~(B $BNI!"3HD%$r9T$&$3$H!"$b$7$/$O<+$i3+H/$7$?%W%m%0%i%`$d%I%-%e%a%s%H$rK\%W(B $B%m%0%i%`$KDI2C$9$k$3$H$,4^$^$l$k$,!"$=$l$@$1$K$O8BDj$5$l$J$$!#(B $BK\%W%m%0%i%`$NMxMQr7o!WBh#3(B $B9`!J!VL5J]>Z!W!K$,5-$5$l$F$$$k$3$H$r>r7o$H$7$F!"4XO"K!Na$K0cH?$7$J$$8B(B $B$j!"K\%W%m%0%i%`$=$N$b$N!"$^$?$OK\%W%m%0%i%`$NJQ99HG$rBh;0Z(B $BK\%W%m%0%i%`$O!"K\%W%m%8%'%/%H$N8&5f3+H/$N;n:nJ*$r!X$"$k$,$^$^!Y$N>u(B $BBV$GDs6!$9$k$b$N$G$"$k!#$3$N$?$a!"L@<(E*$G$"$k$+L[<(E*$G$"$k$+!"$^$?$O(B $BK!Na$N5,Dj$K$h$j@8$:$k$b$N$G$"$k$+H]$+$rLd$o$:!"0l@Z$NJ]>Z$r$D$1$J$$$G(B $BDs6!$5$l$k$b$N$G$"$k!#$3$3$G$$$&J]>Z$H$O!"%W%m%0%i%`$NIJl(B $B@-!"FCDjL\E*E,9g@-!"$*$h$SB>$NBh;0Z$r4^(B $B$`$,!"$=$l$K8BDj$5$l$k$b$N$G$O$J$$!#(B $BK\%W%m%0%i%`$NMxMQZ$G$"$k$3$H$r>5Bz$7!"K\%W(B $B%m%0%i%`$,L5J]>Z$G$"$k$3$H$K$h$k$9$Y$F$N%j%9%/$rMxMQ$C$F!"MxMQ6H0w$O!"$=$N$h$&$JB;32$NH/@8$9$k2DG=@-$K$D$$$F!"CN$C$F(B $B$$$?$+H]$+$K$+$+$o$i$:!"2?$i$N@UG$$bIi$o$J$$!#K\%W%m%0%i%`$NMxMQ5Bz$7$F$$$k$b$N$H$_$J$5$l(B $B$k!#$3$3$G$$$&MxMQ$H$O!"K\%W%m%0%i%`$N;HMQ!"JQ99!"J#@=!"G[I[!"Fsl9g$K$*$$$F$b!"G[I[$r9T$C$?Bh;0Z$rJ8=q$G9T$o$J$$8B$j!"G[I[$r9T$C$?Bh;0\$7$/$O(B COPYRIGHT $B$r;2>H$7$F2<$5$$(B) ICOT $B%U%j!<%=%U%H%&%'%"(B "Constraint Logic Programming Lanuguage cu-Prolog" $B%$%s%9%H!<%k%,%$%I(B 1. How to install cu-Prolog. cu-Prolog$B$Nl9g$O>e5-$N%U%!%$%k$r0l$D$N%G%#%l%/%H%j$KCV$-!"(B cc -o cuprolog *.c [CR] $B$^$?$OE:IU$N(Bmakefile$B$rMQ$$$F!"(B make [CR] $B$H$9$k!#(B $B%*%W%F%#%^%$%:$*$h$S%G%P%C%0MQ$N%3%s%Q%$%k$K$D$$$F$O(B src/makefile $B$r;2(B $B>H$N$3$H!#(B 2. cu-Prolog$B$N%+%9%?%^%$%:K!(B $B;HMQ$9$k5!l9g(B (times() $B$H$O(BUNIX 4.2/3 BSD $B$N%i%$%V%i%j$G(B $B%W%m%;%9$N(BCPU$B;~4V$r(B 1/60$BICC10L$GJV$9(B.) #define CPUTIME 60 (2) $B%7%9%F%`$N(B times() $B%i%$%V%i%j$,(B1/N$BIC(B $BC10L$G;~4V7WB,$r9T$J$&>l9g(B #define CPUTIME N (3) Sun-4$B$N>l9g$K$O(B clock() $B%i%$%V%i%j$rMQ$$$k!#0J2<$N$h$&$K!"(BCPUTIME $B$N$+$o$j$K(BSUN4$B$rDj5A$7$F$/$@$5$$!#(B #define SUN4 1 (4) $B$=$l0J30$K$O!"(BCPU$B%?%$%`$OI=<($5$l$^$;$s!#(B #define CPUTIME 0 2.2 $B%R!<%W%5%$%:(B cu-Prolog$B$K$O0J2<$N%G!<%?NN0h$,$"$k!#(B $B%7%9%F%`%R!<%W(B: $B%W%m%0%i%`@a!"?7=R8lDj5AEy!#(B $BBg$-$5$O(BSHEAP_SIZE ($B%G%U%)%k%H$O(B20000) $B%f!<%6%R!<%W(B: Prolog$BH?G};~$N0l;~E*$J9=B$Ey!#(B $BBg$-$5$O(BHEAP_SIZE ($B%G%U%)%k%H$O(B600000) $B@)Ls%R!<%W(B: $B@)Ls!&(BPST$B$N0l;~E*$J9=B$Ey!#(B $BBg$-$5$O(BCHEAP_SIZE ($B%G%U%)%k%H$O(B25000) $B4D6-%9%?%C%/(B: Prolog$BH?G};~$N4D6-!#(B $BBg$-$5$O(BESP_SIZE ($B%G%U%)%k%H$O(B500000) $B%f!<%6%9%?%C%/(B: Prolog$BH?G};~$N%]%$%s%?$N$D$1$+$(Ey!#(B $BBg$-$5$O(BUSTACK_SIZE ($B%G%U%)%k%H$O(B10000) $BJ8;zNs%R!<%W(B: $BJ8;zNs$N3JGH$N$3$H(B ---------------------------------- $B0J>e(B ($B$h$j>\$7$/$O(B ./doc/cu3man.tex $B$r;2>H$N$3$H(B) ing jurisdiction over the README 644 10266 36 6135 6076673324 5057 (C)1992 Institute for New Generation Computer Technology (Read COPYRIGHT for detailed information.) ICOT Free Software "Constraint Logic Programming Lanuguage cu-Prolog" 1. Introduction cu-Prolog is an experimental constraint logic programming language. Unlike most conventional CLP systems, cu-Prolog allows user-defined predicates as constraints and is suitable for implementing a natural language processing system based on the unification-based grammar. As an application of cu-Prolog, we developed a JPSG (Japanese Phrase Structure Grammar) parser with the JPSG Working Group (the chairman is Prof. GUNJI, Takao of Osaka University) at ICOT. cu-Prolog is also the complete implementation of the constraint unification and its name (cu) comes from the technique. 2. Environment Originally, cu-Prolog is implemented in the C language of UNIX 4.2/3BSD. Later, prof.Sirai of Chukyo-University implemented cu-Prolog in Apple Macintosh and DJ's GPP (80386/486 MS-DOS machine with the DOS extender). 3. Content of this free software INSTALL README doc/ INSTALL.j README.j src/ /sample doc/ cu3eman.bbl cu3man.bbl cup3.index cup3e.xref cu3eman.tex cu3man.tex cup3.xref src/ defsysp.c main.c print.c syspred1.c unify.c funclist.h mainsub.c read.c syspred2.c varset.h globalv.h makefile refute.c tr_split.c include.h modular.c sysp.h tr_sub.c jpsgsub.c new.c syspdef.h trans.c sample/ eisele.p jpsg.p jpsg2.p kasper.p memap.p 4. How to install? Read INSTSALL and doc/cu3eman.tex. You have only to compile all the C programs by typing "make" after UNIX shell prompt. 5. Port cu-Prolog into other systems. Originally, cu-Prolog is implemented in the C language of UNIX 4.2/3BSD. Later, prof.Sirai of Chukyo-University implemented cu-Prolog in Apple Macintosh and DJ's GPP (80386/486 MS-DOS machine with the DOS extender). They are available from FTP host name: csli.stanford.edu Directory: pub/MacCup. or ftp.icot.or.jp pub/cuprolog 6. Reference Hiroshi Tsuda, Hasida Koiti and Sirai Hidetosi, JPSG Parser on Constraint Logic Programming, In Proceedings of 4th ACL European Chapter, pp 95--102, 1989. Hiroshi Tsuda, Hasida Koiti and Sirai Hidetosi, cu-Prolog and its application to a JPSG parser, In K.Furukawa,H.Tanaka,and T.Fujisaki(eds.), Logic Programming'89, pp.134--143, Springer-Verlag, LNAI-485. Hiroshi Tsuda, cu-Prolog for Constraint-Based Grammar, Proceedings of FGCS'92, 1992. Hiroshi Tsuda, Hasida Koiti and Sirai Hidetosi, cu-PrologIII system. Technical Report ICOT-TM1160, 1992. 7. Patch Information Oct5-1992: main.c (set global vars) :thanks to Mr.Horikawa. syspred1.c (reaad_pred bug) :thanks to Dr.Fontanini cu3eman.tex (delete lingmacros.sty) :thanks to Mr.Utsumi Oct29-1992: main.c (reset termset log) :thanks to Dr.Sivand Lakmazaheri Jan10-1996: update jpsg.p : thanks to John Fry 8. Q&A Q: How to run cu-Prolog on Linux: A: Add the following lines in the end of src/include.h #undef is_readable #undef is_writable #define is_readable(FP) (!((FP)->_flags & _IO_NO_READS)) #define is_writable(FP) (!((FP)->_flags & _IO_NO_WRITES)) (by Yukihiro Oda in fj.os.linux, fj.lang.prolog, 16 Dec 1995) F ANY INFRINGEMENT OR VIOLATION OF ANY RIGHT OF ANY THIRD PARTY. EACH USER OF THE PROGRAM WILL AGREE AND UNDERSTAND, AND BE DEEMED TO HAVE AGREED AND UNDERSTOOD, THAT THERE IS NO WARRANTY WHATSOEVER FOR THE PROGRAM AND, ACCORDINGLY, THE ENTIRE RISK ARISING FROM OR OTHERWISE CONNECTED WITH THE PROGRAM IS ASSUMED BY THE USER. THEREFORE, NEITHER ICOT, THE COPYRIGHT HOLDER, OR ANY OTHER ORGANIREADME.j 644 10266 36 10471 6076673324 5325 (C)1992 Institute for New Generation Computer Technology (¾Ü¤·¤¯¤Ï COPYRIGHT ¤ò»²¾È¤·¤Æ²¼¤µ¤¤) ICOT ¥Õ¥ê¡¼¥½¥Õ¥È¥¦¥§¥¢ "Constraint Logic Programming Lanuguage cu-Prolog" 1. ¤Ï¤¸¤á¤Ë À©ÌóÏÀÍý·¿¸À¸ìcu-Prolog¤Ï¡¢¼«Á³¸À¸ì½èÍý¤Îñ°ì²½Ê¸Ë¡¤ÎÆÃħ¤Ç¤¢¤ëÀë¸ÀŪ ¤Êʸˡµ­½Ò¤Î¼ÂÁõ¤òÌÜŪ¤È¤·¤¿¡¢µ­¹æÅª¡¦Áȹ礻Ū¤ÊÀ©Ìó¤ò²ò¤¯¤Î¤ËŬ¤·¤¿¸À ¸ì¤Ç¤¢¤ë¡£¤³¤³¤Ç¤¤¤¦À©Ìó¤È¤Ï¡¢ÊÑ¿ô¶¦Í­¤äÊÑ¿ô«Çû¤Ê¤É¤Ë¤è¤ë°Í¸´Ø·¸¤ò¤¤ ¤¦¡£cu-Prolog¤Ï¡¢½¾Íè¤ÎCLP¤Î¿¤¯¤¬Âå¿ôÊýÄø¼°¡¦ÉÔÅù¼°¤Ë¤è¤ëÀ©Ìó¤ò°·¤¦¤Î ¤ËÂФ·¤Æ¡¢¼«Á³¸À¸ì½èÍýʤӤËAIÁ´È̤ؤαþÍѤËŬ¤¹¤ë¥×¥í¥°¥é¥à¸À¸ì¤Ç¤¢¤ë ¤È¤¤¤¨¤ë¡£ cu-Prolog¤ÏICOT¤ÎPSG-WG¤Ë¤Æ¡¢JPSG(Japanese Phrase Structre Grammar:Æü Ëܸì¶ç¹½Â¤Ê¸Ë¡)¤Î¥Ñ¡¼¥¶¤ò¼Â¸½¤¹¤ëÌÜŪ¤Ç¹Í°Æ¤µ¤ì¤¿¡£JPSG¤Ç¤Ï¡¢¾ðÊó¤òÁÇ À­(¥é¥Ù¥ë)¤È¤½¤ÎÃͤÎÂФÎÉÔÄê¸Ä¤ÎʤӤˤè¤ëÁÇÀ­¹½Â¤¤Ë¤è¤ê³ÊǼ¤·¡¢¤½¤ì¤é ¤ò¥Î¡¼¥É¤È¤¹¤ë¶ç¹½Â¤¤Ë¤è¤Ã¤Æ¼«Á³¸À¸ì¤Î¹½Â¤¤òɽ¸½¤¹¤ë¡£JPSG¤Î¤è¤¦¤ÊÀ©Ìó ¥Ù¡¼¥¹¤Îñ°ì²½Ê¸Ë¡¤Ç¤Ï¡¢¼«Á³¸À¸ì¤Îʸˡ¤Ï¤¹¤Ù¤ÆÀ©Ìó¤ÇÀë¸ÀŪ¤Ëµ­½Ò¤µ¤ì¤ë¡£ JPSG¤Ë¤ª¤±¤ëÀ©Ìó¤È¤Ï¡¢ÆóʬÌڤγƥΡ¼¥É¤Ë¤ª¤±¤ëÁÇÀ­Ãͤε­¹æÅª¡¦Áȹ礻Ū ´Ø·¸¤Ç¤¢¤ë¡£ cu-Prolog¤ÏProlog¤Î¥æ¡¼¥¶ÄêµÁ½Ò¸ì¤Ë¤è¤ë¹à¤òÀ©Ìó¤È¤·¤Æ°·¤¦¤³¤È¤¬¤Ç¤­¤ë ¤Î¤Ç¡¢JPSG¤Ê¤É¤Î¼«Á³¸À¸ì½èÍý¤Ë¤ª¤±¤ëÀ©Ìó¤ò¼«Á³¤Ëµ­½Ò¤·¡¢¤½¤Î¤Þ¤ÞÀ©Ìó¤È ¤·¤Æ¼Â¹Ô¤¹¤ë¤³¤È¤¬²Äǽ¤Ç¤¢¤ë¡£cu-Prolog¤ÎÀ©Ìó²ò¾Ã·Ï¤Ï¡¢ÏÀÍý¥×¥í¥°¥é¥à ¤Îunfold/foldÊÑ´¹¤ò´ðËÜÁàºî¤È¤·¡¢ÊÑ¿ô¶¦Í­¤ä«Çû¤Ê¤É¤Ë¤è¤ë¥Ò¥å¡¼¥ê¥¹¥Æ¥£¥Ã ¥¯¥¹¤ò²Ã¤¨¤¿¤È¤³¤í¤ËÆÃħ¤¬¤¢¤ë¡£ cu-PrologÂè»°ÈǤǤϡ¢À©Ìó¥Ù¡¼¥¹¤Îñ°ì²½Ê¸Ë¡¤Îµ­½Ò¤Ë¤è¤êŬ¤·¤¿¤â¤Î¤È¤¹ ¤ë¤¿¤á¡¢¥Ç¡¼¥¿¹½Â¤¤È¤·¤ÆÉôʬ¹à(Partially Specified Term)¤ò¤È¤êÆþ¤ì¤¿¡£ ¤³¤ì¤Ë¤è¤ê¡¢ÁÇÀ­¹½Â¤¤ò¤½¤Î¤Þ¤Þ°·¤¦¤³¤È¤¬¤Ç¤­¤ë¡£¤µ¤é¤Ë¡¢À©Ìó²ò¾Ã·Ï¤âÉô ʬ¹à¤ÎƳÆþ¤È¤È¤â¤Ë¼«Á³¤Ë³ÈÄ¥¤ò¹Ô¤Ê¤¤¡¢Ã±°ì²½Ê¸Ë¡¤Ç½ÅÍפȤʤëÁª¸ÀŪÁÇÀ­ ¹½Â¤¤ËÂФ·¤Æ¤âÂбþ¤Ç¤­¤ë¤è¤¦¤Ë¤Ê¤Ã¤¿¡£Áª¸ÀŪÁÇÀ­¹½Â¤¤Îñ°ì²½¤ÏËÜÍè·×»» Î̤ÎÂ礭¤ÊÌäÂê¤Ç¤¢¤ê¡¢¤è¤ê¼ÂºÝŪ¤Ê¥¢¥ë¥´¥ê¥º¥à¤¬¸¦µæ¤µ¤ì¤Æ¤¤¤ë¡£ cu-PrologÂè»°ÈǤǤϡ¢¤½¤ì¤¬¥Ò¥å¡¼¥ê¥¹¥Æ¥£¥Ã¥¯¥¹¤â´Þ¤á¤ÆÀ©ÌóÊÑ´¹¤È¤¤¤¦ ¶¦Ä̤·¤¿ÏÈÁȤDzò·è¤µ¤ì¤Æ¤¤¤ë¡£ 2. ¼Â¹Ô´Ä¶­ UNIX 4.2/3BSD¾å¤ÎC¸À¸ì¤Ë¤è¤ê¼ÂÁõ¤µ¤ì¤Æ¤¤¤ë¡£ 3. ¥Õ¥¡¥¤¥ë¹½À® INSTALL README doc/ INSTALL.j README.j src/ /sample doc/ cu3eman.bbl cu3man.bbl cup3.index cup3e.xref cu3eman.tex cu3man.tex cup3.xref src/ defsysp.c main.c print.c syspred1.c unify.c funclist.h mainsub.c read.c syspred2.c varset.h globalv.h makefile refute.c tr_split.c include.h modular.c sysp.h tr_sub.c jpsgsub.c new.c syspdef.h trans.c sample/ eisele.p jpsg.p jpsg2.p kasper.p memap.p 4. ¥¤¥ó¥¹¥È¡¼¥ë¤Ë´Ø¤¹¤ë¥³¥á¥ó¥È ¾Ü¤·¤¯¤Ï INSTSALL.j ¤Þ¤¿¤Ï doc/cu3eman.tex¤ò»²¾È¤Î¤³¤È. Á´¤Æ¤ÎC¥×¥í¥°¥é¥à¤ò¥³¥ó¥Ñ¥¤¥ë¤¹¤ë¤À¤±¤Ç¤¢¤ë¡£ 5. ¾µ¡¼ï¤Ø¤Î°Ü¿¢ cu-Prolog¤Ïµ¡¼ï°Í¸¤Î¥é¥¤¥Ö¥é¥ê¤ò¤Û¤È¤ó¤É»È¤Ã¤Æ¤¤¤Ê¤¤¤Î¤Ç¡¢Â¾µ¡¼ï¥Ø¤Î °Ü¿¢¤ÏÈæ³ÓÅªÍÆ°×¤Ç¤¢¤ë¡£ ÃæµþÂç³Ø¤ÎÇò°æ±Ñ½Ó½õ¶µ¼ø¤Ë¤è¤ê¡¢MacintoshÈǤª¤è¤Ó¡¢80386/486MS-DOS¥Þ¥· ¥óÈÇ(DOS¥¨¥¯¥¹¥Æ¥ó¥À DJ's GPP»ÈÍÑ)¤¬¤¢¤ë¡£ ¤³¤ì¤é¤Ï¡¢ FTP host name: csli.stanford.edu Directory: pub/MacCup. or ftp.icot.or.jp pub/cuprolog ¤è¤êÆþ¼ê²Äǽ¤Ç¤¢¤ë¡£ 6. »²¹Íʸ¸¥ Hiroshi Tsuda, Hasida Koiti and Sirai Hidetosi, JPSG Parser on Constraint Logic Programming, In Proceedings of 4th ACL European Chapter, pp 95--102, 1989. Hiroshi Tsuda, Hasida Koiti and Sirai Hidetosi, cu-Prolog and its application to a JPSG parser, In K.Furukawa,H.Tanaka,and T.Fujisaki(eds.), Logic Programming'89, pp.134--143, Springer-Verlag, LNAI-485. Hiroshi Tsuda, cu-Prolog for Constraint-Based Grammar, proceedings of FGCS'92, 1992. Hiroshi Tsuda, Hasida Koiti and Sirai Hidetosi, cu-PrologIII system (cu-PrologÂè»°ÈǽèÍý·Ï»ÅÍͽñ). Technical Report ICOT-TM1160, 1992. (In Japanese) ¶¶ÅĹÀ°ì, Çò°æ±Ñ½Ó, ¾ò·ïÉÕñ°ì²½. ¥³¥ó¥Ô¥å¡¼¥¿¥½¥Õ¥È¥¦¥§¥¢, vol3 number4, pp.28--38, 1986.(In Japanese) ÄÅÅŨ, ¶¶ÅĹÀ°ì, Çò°æ±Ñ½Ó, À©Ìó½¼Â­¤È¤·¤Æ¤Î¹½Ê¸²òÀÏ --- À©ÌóÏÀÍý·¿¸À¸ìcu-Prolog¤Î±þÍÑ. ÆüËÜ¥½¥Õ¥È¥¦¥§¥¢²Ê³Ø²ñÂè6²óÂç²ñÏÀʸ½¸, pp.257--260, 1989.(In Japanese) ÄÅÅŨ, cu-Prolog¤Ë¤è¤ëÁª¸ÀŪÁÇÀ­¹½Â¤. ÆüËÜ¥½¥Õ¥È¥¦¥§¥¢²Ê³Ø²ñÂè8²óÂç²ñÏÀʸ½¸, pp.505--508, 1991.(In Japanese) 7.¥Ñ¥Ã¥Á¾ðÊó Oct5-1992: main.c (set global vars) :thanks to Mr.Horikawa syspred1.c (reaad_pred bug) :thanks to Dr.Fontanini cu3eman.tex (delete lingmacros.sty) :thanks to Mr.Utsumi Oct29-1992: main.c (reset termset log) :thanks to Dr.Sivand Lakmazaheri Jan10-1996: update jpsg.p : thanks to John Fry 8. Q&A Q: How to run cu-Prolog on Linux: A: Add the following lines in the end of src/include.h #undef is_readable #undef is_writable #define is_readable(FP) (!((FP)->_flags & _IO_NO_READS)) #define is_writable(FP) (!((FP)->_flags & _IO_NO_WRITES)) (by Yukihiro Oda in fj.os.linux, fj.lang.prolog, 16 Dec 1995) ¯¤Î¤ËŬ¤·¤¿¸À ¸ì¤Ç¤¢¤ë¡£¤³¤³¤Ç¤¤¤¦À©Ìó¤È¤Ï¡¢ÊÑ¿ô¶¦Í­¤äÊÑ¿ô«Çû¤Ê¤É¤Ë¤è¤ë°Í¸´Ø·¸¤ò¤¤ ¤¦¡£cu-Prolog¤Ï¡¢½¾Íè¤ÎCLP¤Î¿¤¯¤¬Âå¿ôÊýÄø¼°¡¦ÉÔÅù¼°¤Ë¤è¤ëÀ©Ìó¤ò°·¤¦¤Î ¤ËÂФ·¤Æ¡¢¼«Á³¸À¸ì½èÍýʤӤËAIÁ´È̤ؤαþÍѤsample/ 775 10266 36 0 6076672541 5370 sample/eisele.p 644 10266 36 1545 5570050702 7072 %%% Example in %%% Eisele and Dorre, Unification of Disjunctive Feature Structure, %%% 26th ACL, 1988. %%% %%% Disjunctive feature unification between %%% [a:{[b:+,c:-],[b:-,c+]}] and [a:[b:],d:_]. %%% --> [a:[b:+,c:-],d:+] or [a:[b:-,c:+],d:-] %%% f({a/X}):-cc1(X). cc1({b/plus,c/minus}). cc1({b/minus,c/plus}). @ f(U),U={a/{b/X},d/X}. %% --> c0(U,....) %% then, solve :-c0(U,_,_). This goal has two solutions. %% ------------------------------ %% solution = c0(U_0, X_1, {a/{b/X_1}, d/X_1}) %% c1(plus, {b/plus, c/minus}). %% c1(minus, {b/minus, c/plus}). %% c0(_p1, V0_0, _p1) :- c1(V0_0, {b/V0_0});_p1={a/{b/V0_0}, d/V0_0}. %% CPU time = 0.017 sec (Constraints Handling = 0.000 sec) %% %% _:-c0(U,_,_). %% U = {a/{b/plus, c/minus}, d/plus}; %% U = {a/{b/minus, c/plus}, d/minus}; %% %% CPU time = 0.000 sec (Constraints Handling = 0.000 sec) ¸Ë¡¤Ï¤¹¤Ù¤ÆÀ©Ìó¤ÇÀë¸ÀŪ¤Ëµ­½Ò¤µ¤ì¤ë¡£ JPSG¤Ë¤ª¤±¤ëÀ©Ìó¤È¤Ï¡¢ÆóʬÌڤγƥΡ¼¥É¤Ë¤ª¤±¤ëÁÇÀ­Ãͤε­¹æÅª¡¦Áȹ礻Ū ´Ø·¸¤Ç¤¢¤ë¡£ cu-Prolog¤ÏProlog¤Î¥æ¡¼¥¶ÄêµÁ½Ò¸sample/jpsg.p 644 10266 36 73062 6074645334 6625 %%%%%%%%%%%%%%%%%%%%%%%%% rel.p %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% JPSG parser ver1.3 %%% 1992.6.6 %%% JPSG Parser Sample %%% 1995.12 commented by John Fry (ETL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Category : %%% {core/{pos/Pos, form/Form, asp/View}, %% ajc/Adjacent, sc/Subcat, ajn/Adjoin, %% psl/PSlash, slash/Slash, refl/Refl, sem/Sem (,temp/Temp)} %%% Pos: part of speech p,n,v,vs(sahen-dousi),adn(rentai-si),adv(fuku-si) %%% Form: when Pos=n, n,ns(sahen-meisi) %%% when Pos=v, vv,vk,vcw,... (verb form), %%% adj(adjective), na(adjective-verb) %%% Temp: Temp feature for proto-lexicon %% write_dl(L1,L2):-write("["),w_dl(L1,L2),write("]"). %% w_dl(X,X). %% w_dl([A|L1],L2):-write(A),write(" "),w_dl(L1,L2). %%% Left Corner Parser p2(S):-parse0(A,B,S,[],[idx(s,speaker)]),write(A),nl,pcon,nl. p(Sentence):- parse0(Cat,H,Sentence,[],[idx(s,speaker)]),nl, tree(H),nl, write("category= "),write(Cat),nl, write("constraint= "),project_cstr(Cat),nl. nil_or_speaker([]). nil_or_speaker([{sem/speaker}]). parse0(MCat,MHist,Str,Rest,Idxlist):- lookup(Str,SubStr,Cat,Hist,Idxlist,Nidx),!, parse1(Cat,Hist,MCat,MHist,SubStr,Rest,Nidx). parse1(LCat,LHist,GCat,GHist,[Word|SubStr],Rest,Idxlist):- lookup_post(LCat,Word,RCat,RHist,RuleName), psr_adj(LCat,RCat,MCat), parse1(MCat, t(t(MCat,RuleName,[]),LHist,RHist), GCat,GHist,SubStr,Rest,Idxlist). parse1(Cat,H,Cat,H,Str,Str,N). parse1(LCat,LHist,GCat,GHist,Str,Rest,Idxlist):- psr(LCat,RCat,MCat,RN), parse0(RCat,RHist,Str,SubStr,Idxlist), parse1(MCat,t(t(MCat,RN,[]),LHist,RHist), GCat,GHist,SubStr,Rest,Idxlist). %%% phrase structure rules %%% psr(LeftCat,RightCat,MotherCat) %%% 1. Adjacent Structure: psr_adj(Left,Head,Mother) psr_adj({core/Cc,sc/Csc,refl/Cref,slash/Csl,psl/Cpsl,sem/SEM0,ajn/[]}, {core/Hc,ajc/[{core/Cc,sc/Asc,refl/ReflAC,sem/SEM0}], ajn/Adj, sc/Hsc, refl/Href, slash/Hsl, sem/SEM}, {core/Hc,ajc/[],ajn/Adj,sc/Msc,refl/Mref,slash/Msl,psl/Cpsl, sem/SEM}); adjacent_sc_p(Csc,Asc,Hsc,Msc), slash_p(Csl,Hsl,Msl), refl_cond(Cref,Href,Mref,Hsc). %%% slash feature principle: %%% slash_p(LeftS,RightS,MotherS) %%% LeftS=C.slash, RightS=H.slash, MotherS=M.slash slash_p([],[],[]). slash_p([S],[],[S]). slash_p([],[S],[S]). slash_p([S],[RS],[RS]):-sem_unify(S,RS). sem_unify({sem/X},{sem/X}). %% adjacent-subcat principle for adjacent structure %% adjacent_sc_p(CSC,ASC,HSC,MSC). %% CSC=C.sc, ASC=H.ajc.sc, HSC=H.sc, MSC=M.sc %% adjacent_sc_p(CSC,[],HSC,MSC):-merge(CSC,HSC,MSC). adjacent_sc_p([],[],SC,SC). adjacent_sc_p([SC|R],[],[],[SC|R]). adjacent_sc_p(CSC,[AS],HSC,SC):-one_of(CSC,AS,Rest),append(HSC,Rest,SC). adjacent_sc_p([A1,A2|R],[A1,A2],SC,MSC):-append(SC,R,MSC). /* for ukemi */ %%% 2. relative clause structure : psr(R,H,M) psr({core/{form/rel},sc/Rsc,slash/Rsl,psl/Rps,sem/Rs,ajc/[],ajn/[]}, {core/Hc,ajc/Ha,slash/Hsl,sem/Hs}, {core/Hc,sc/[],slash/Msl,psl/[],sem/[Hs,Rs]},[relative_s]); {pos/n}=Hc,sc_sl(Rsc,Rsl,Rps,Ha,Hsl,Msl,Hs). sc_sl([],[{sem/Hsm}],Rps,[],Hsl,Msl,Hsm):-slash_p(Rps,Hsl,Msl). sc_sl([],Rsl,Rps,[{core/{form/rel}}],Hsl,Msl,Hsm):-sl_psl_p(Rsl,Hsl,Msl,Rps). sc_sl([{sem/Hsm}],[Rsl],Rps,[],Hsl,Msl,Hsm):-sl_psl_p([Rsl],Hsl,Msl,Rps). %% sl_psl_p(Csl,Hsl,Msl,Psl) sl_psl_p([],[],[P],[P]). sl_psl_p(Csl,Hsl,Msl,[]):-slash_p(Csl,Hsl,Msl). sl_psl_p(Csl,Hsl,Msl,[{sem/X}]):-slash_p(Csl,Hsl,[{sem/X}]). %%% 3. Subcategorization Structure : psr(C,H,M) psr(Comp, {core/Hc, ajn/Hn, ajc/Hac, sc/HC, refl/Hr, slash/Hsl, sem/Hs}, {core/Hc, ajn/Hn, ajc/Hac, sc/Rest, refl/Mr, slash/Msl,psl/Cps,sem/Hs}, [subcat_p] ); {core/Cc, ajc/[], refl/Cr,slash/Csl,psl/Cps, ajn/[]}=Comp, one_of(HC,Comp,Rest), slash_p(Csl,Hsl,Msl), refl_cond(Cr,Hr,Mr,Rest), sc_cond(Cc,Hc). sc_cond({pos/p},{pos/v}). sc_cond({pos/adn},{pos/n}). refl_cond([],[],[],Rt). refl_cond([],[Cat],[Cat],Rt). refl_cond([Cat],[],[Cat],Rt). refl_cond([Cat],[],[],SC) :- memb3(Cat,SC). %%% 4. Adjunction Structure: psr(An,H,M) psr({core/_,ajn/[Head], slash/Asl,refl/ReflA,psl/Apsl,sem/As}, Head, {core/C,ajn/A,ajc/[],sc/Hsc,slash/Msl,refl/ReflM,psl/Apsl,sem/As}, [adjunct_p] ); {core/C,ajn/A,ajc/[],sc/Hsc,slash/Hsl,refl/ReflH,sem/Hs}=Head, refl_cond(ReflA,ReflH,ReflM,Hsc), slash_p(Asl,Hsl,Msl). %%%%% lexical rule (for general dictionary) %%% lex_rule(OrigCat,NewCat) lex_rule(C,Cat):- same_feature(C,Cat), sc_to_sl(C,Cat),default(Cat,{},{ajc/[],ajn/[],refl/[]}). %% core,sem same_feature({core/C,sem/S},{core/C,sem/S}). %% adjacent default(defaul value is [], if it is not specified) %% ajc_default({ajc/[]},{ajc/[]}):-!. %% ajc_default({ajc/X},{ajc/X}). %% adjoin default(defaul value is [], if it is not specified) %% ajn_default({ajn/[]},{ajn/[]}):-!. %% ajn_default({ajn/X},{ajn/X}). %% refl default(defaul value is [], if it is not specified) %% refl_default({refl/[]},{refl/[]}):-!. %% refl_default({refl/X},{refl/X}). %% sc,slash (subcat to slash movement, sc,slash,psl default) sc_to_sl({sc/[]},{sc/[],slash/[],psl/[]}):-!. sc_to_sl({sc/S},{sc/Nsc,slash/Nsl,psl/[]});sc_sl_move(S,Nsc,Nsl). sc_sl_move(Sc,Sc,[]). sc_sl_move(Sc,Nsc,[{sem/Sl}]):-one_of(Sc,{sem/Sl},Nsc). %% temp,asp (temp to aspect conversion, asp default) %% temp_to_asp({temp/[]},{core/{asp/[]}}):-!. %% temp_to_asp({temp/t(S,F,R,DSF,DRF)},{core/{view/asp(AB,AE,AD,AT)}}); %% temp_cstr(S,F,R,DSF,DRF,AB,AE,AD,AT). temp_cstr(S,F,T0,DSF,T1,S,F,DSF,basic). temp_cstr(T0,F,R,T1,f,F,R,f,result). temp_cstr(T0,F,T1,T2,T3,F,i,i,exp). temp_cstr(T0,T1,R,T2,f,R,i,i,exp). %%%%% general dictionary %%%%% lookup(Str,RestStr,Cat,Hist,OldIdx,NewIdx) %%%%% lookup([nil|X],X,_,_):-fail,!. %%lookup([idx([Sent|Cont],I)|X],X,Cat,Hist):- %% parse0(Cat,Hist,[Sent|Cont],[]). lookup([idx(Word,I)|X],X,Cat,t(Cat,[Word,I],[]),OldIdx,OldIdx) :-member(idx(I,Sem),OldIdx),!, %% write("lookup "),write(idx(I,Sem)),write(" in "),write(OldIdx),nl, dict1(Word,C),lex_rule(C,Cat);{sem/Sem}=Cat. lookup([idx(Word,I)|X],X,Cat,t(Cat,[Word,I],[]),OldIdx,[idx(I,Sem)|OldIdx]) :-!, dict1(Word,C),lex_rule(C,Cat);{sem/Sem}=C. lookup([[Sent|Cont]|X],X,Cat,Hist,Idx,Idx):- parse0(Cat,Hist,[Sent|Cont],[],Idx). lookup([Word|X],X,Cat,t(Cat,[Word],[]),Idx,Idx) :-dict1(Word,C),lex_rule(C,Cat). %%%%% pp, suffix, auxiliary verb dictionary %%%%% lookup_post(PreCat, Word, PostCat, PostHist,RuleName) lookup_post({core/{pos/v,form/Form}},Word, Cat,t(Cat,[Word],[]),[suff_p]) :-search_suffix(Form,Word,Cat); {slash/[],psl/[],refl/[]}=Cat. lookup_post(_,Word,Cat,t(Cat,[Word],[]),[adjacent_p]) :-dict_pos(Word,Cat); {slash/[],psl/[],refl/[]}=Cat. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%% jconst.p %%%%%%%%% constraints %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% general constraint %%% %%% constraint (finite predicate) %%% one_of(List, One, Rest) |List|<=3 one_of([X|Y],X,Y). one_of([X,Y|Z],Y,[X|Z]). one_of([X,Y,Z],Z,[X,Y]). %%% member(X,List) |List|<=3 memb3(X,[X|Y]). memb3(X,[Y,X|Z]). memb3(X,[Y,Z,X]). %%% finite permutation perm2([A,B],[A,B]). perm2([A,B],[B,A]). perm3([A,B,C],[A|X]):-perm2([B,C],X). perm3([A,B,C],[B|X]):-perm2([A,C],X). perm3([A,B,C],[C|X]):-perm2([A,B],X). %%%%%%% constraint (recursive predicate) merge([],[],[]). merge([],[A|X],[A|X]). merge([A|X],[],[A|X]). merge([A|X],[B|Y],[A|Z]):-merge(X,[B|Y],Z). merge([B|X],[A|Y],[A|Z]):-merge([B|X],Y,Z). append([],X,X). append([A|X],Y,[A|Z]):-append(X,Y,Z). member(X,[X|Y]). member(X,[Y|Z]):-member(X,Z). %%%%%%%%%%%%% sahen constraint %%%%%%%%%%%%%%%%%%% su_handler(Adjacent,v_su,[],SC,Sem) :- suru(Adjacent,SC,Sem). su_handler([{core/{pos/v,form/vcs},ajc/[],ajn/[],sc/[],sem/Sem}], Form,[],[],Sem). suru([{core/{pos/n,form/ns},sc/Subc,sem/[Pred|SRest]}], SC,[Pred|SRest]):- suru_correspond(SRest,Subc,SC). suru([],[{core/{pos/p,form/wo}, sc/[{core/{pos/adn,form/ga},refl/RF,sem/Sbj}|Sc], refl/RF,sem/[Pred,Sbj,Obj|SRest]}|SC], [Pred,Sbj,Obj|SRest] ):- suru_correspond([Sbj|SRest], [{core/{pos/adn,form/ga},refl/RF,sem/Sbj}|Sc],SC). suru([], [{core/{pos/p,form/ga},refl/RF,sem/Sbj}, {core/{pos/p,form/wo}, sc/[{core/{pos/adn,form/ga},refl/RF,sem/Sbj}|SC], sem/[Pred,Sbj,Obj|SRest]}|SC], BR,RF,[Pred,Sbj,Obj|SRest]) :- suru_correspond(SRest,Sc,SC). suru_correspond([],[],[]). suru_correspond([Sbj], [{core/{form/F},sem/Sbj}], [{core/{pos/p,form/F},sem/Sbj}]). suru_correspond([Sbj,Obj], [{core/{form/FO},sem/Obj},{core/{form/FS},sem/Sbj}], [{core/{pos/p,form/FS},sem/Sbj},{core/{pos/p,form/FO},sem/Obj}]). suru_correspond([Sbj,Obj,Iob], [{core/{form/FO},sem/Obj}, {core/{form/FI},sem/Iob},{core/{form/FS},sem/Sbj}], [{core/{pos/p,form/FS},sem/Sbj}, {core/{pos/p,form/FI},sem/Iob}, {core/{pos/p,form/FO},sem/Obj}]). adn_2([{core/{pos/adn,form/First},sem/Obj}, {core/{pos/adn,form/Second},sem/Sbj}], First,Second,Obj,Sbj). adn_2([{core/{pos/adn,form/First},sem/Obj}, {core/{pos/adn,form/Second},sem/Sbj}], Second,First,Obj,Sbj). adn_wo_ga(SC,Obj,Sbj):-adn_2(SC,wo,ga,Obj,Sbj). adn_1([{core/{pos/adn,form/First},sem/Sem}],Form,Sem). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% post.p %%% PP, aux , etc. (have ADJACENT feature) %%% dict_pos( 1word, Cat) : pp, aux, etc. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Post Positions dict_pos(nado, {core/{pos/n,form/Form},ajn/[],sc/[], ajc/[{core/{pos/n,form/Form},sc/[],sem/SEM}],sem/etc(SEM)} ). %%%%% Postpositional particles (joshi) %%%%%%%%%%%%%%%%%%%% %%% --wo,ga,ni,de,to,no,ha,ba general_pp(Form, {core/{pos/p,form/Form},ajn/[],sc/[], ajc/[{core/{pos/n},sc/[],sem/SEM}],sem/SEM} ). dict_pos(wo, Cat):-general_pp(wo, Cat). dict_pos(ga, Cat):-general_pp(ga, Cat). dict_pos(ni, Cat):-general_pp(ni, Cat). dict_pos(de, {core/{pos/adn,form/de},sc/[], ajc/[{core/{pos/n},sc/[],sem/SEM1}], ajn/[{core/{pos/v},sem/SEM2}],sem/de(SEM1,SEM2)} ). dict_pos(to, {core/{pos/Pos,form/to},sc/[], ajc/[{core/{pos/Cat1,form/Form},sc/[],sem/SEM1}], ajn/[{core/{pos/Cat2},sem/SEM2}], sem/SEM} ); to_compl(Pos,Cat1,Form,SEM1,Cat2,SEM2,SEM). to_compl(adj,n,_,S1,v,S2,[with(S1)|S2]). to_compl(adn,n,_,S1,n,S2,[S1,and|S2]). to_compl(adj,v,Inf,S1,v,S2, [with,S1,S2] ):-sentence_end(Inf). sentence_end(inf). sentence_end(a_inf). to_compl(adj,v,imp,S1,nil,S2,S1). dict_pos(no, {core/{pos/adn,form/Form},sc/[], ajc/[{core/{pos/CP,form/CF},sc/[],sem/CS}],ajn/Adjoin,sem/SEM} ); no_handler(CP,CF,Form,Adjoin,CS,SEM). no_handler(p,Form,Form,[],Sem,Sem):- with_case(Form). no_handler(n,n,no, [{core/{pos/n,form/n},ajc/[],ajn/[],sc/[],sem/inst(Obj,Type)}], Atr,inst(Obj,[rel,Atr,Type])). %%no_handler(n,n,Form,[],Sem,Sem):- %% without_case(Form). dict_pos(ha, {core/{pos/p,form/Form},ajn/[],sc/[], ajc/[{core/{pos/Cat,form/F},sc/[],sem/SEM}],sem/SEM} ); wa_compl(Cat,F,Form). wa_compl(p,Form,Form):-with_case(Form). wa_compl(n,_,Form) :- without_case(Form). with_case(to). with_case(he). with_case(ni). with_case(no). without_case(ga). without_case(wo). dict_pos(mo, {core/{pos/p,form/Form},ajn/[],sc/[], ajc/[{core/{pos/Cat,form/F},sc/[],sem/SEM}],sem/SEM} ); mo_compl(Cat,F,Form). mo_compl(p,wo,wo). mo_compl(n,F,ga). mo_compl(p,Form,Form):-with_case(Form). %%%%%%% general constraint v_renyou(conj). v_renyou(vv). v_renyou(v_y). v_renyou(v_si). inf_form(inf). inf_form(a_inf). %%%%%%%%%%%%%%% fuku-joshi %%%%%%%---ba,temo,demo,te,de,tari,dari,shi dict_pos(ba, {core/{pos/adv,form/katei},sc/[], ajc/[{core/{pos/v,form/katei},sc/[],sem/SEM1}], ajn/[{core/{pos/v},ajc/[],ajn/[],sem/SEM2}], sem/if(SEM1,SEM2) } ). %%%% --temo,demo (even if) temo_demo(Form, {core/{pos/adj,form/temo},sc/[], ajc/[{core/{pos/v,form/Form},sc/[],sem/SEM1}], ajn/[{core/{pos/v},ajc/[],ajn/[],sem/SEM2}], sem/even_if(SEM1,SEM2) } ). dict_pos(temo,Cat):-temo_demo(Form,Cat);te_form(Form). dict_pos(demo,Cat):-temo_demo(Form,Cat);demo_form(Form). demo_form(conj_de). demo_form(na). %%%%% --te, de + iru,miru, etc. te_de(Form, {core/{pos/v,form/conj2},sc/[], ajc/[{core/{pos/v,form/Form},sc/[],sem/SEM}],sem/SEM} ). dict_pos(te,Cat):-te_de(Form,Cat);te_form(Form). dict_pos(de,Cat):-te_de(conj_de,Cat). te_form(vv). te_form(v_y). te_form(conj_te). te_form(v_si). %%%% --tari,dari tari_dari(Form, {core/{pos/adj,form/tari},sc/[], ajc/[{core/{pos/v,form/Form},sc/[],sem/SEM1}], ajn/[{core/{pos/vs},ajc/[],ajn/[],sem/SEM2}], sem/[SEM1|SEM2]} ). dict_pos(tari,Cat):-tari_dari(Form,Cat);te_form(Form). dict_pos(dari,Cat):-tari_dari(conj_de,Cat). %%%% --shi (--shi,--shi) dict_pos(shi, % {core/{pos/adj,form/and},sc/[], (J.Fry) {core/{pos/adj,form/adn},sc/[], ajc/[{core/{pos/v,form/Form},sc/[],sem/SEM1}], ajn/[{core/{pos/v,form/Form},ajc/[],ajn/[],sc/[],sem/SEM2}], sem/[SEM1|SEM2] } ); inf_form(Form). %%%%%%%%%%% weak verbs %%%%% --(te/de)iru,iku,kuru,miru,shimawu: stative verbs stative_verb(F, {core/{pos/v,form/F},ajn/[],sc/[], ajc/[{core/{pos/v,form/conj2},sc/[],sem/Sem}],sem/[stative|Sem]}). dict_pos(i,Cat):-stative_verb(vv,Cat). dict_pos(ik,Cat):-stative_verb(vck,Cat). dict_pos(k,Cat):-stative_verb(vk,Cat). dict_pos(mi,Cat):-stative_verb(vv,Cat). dict_pos(shimaw,Cat):-stative_verb(vcw,Cat). %%%% --dasu,kakeru,hajimeru,owaru,tuzukeru :v(renyou) + v sub-verb sub_verb(F,A, {core/{pos/v,form/F},ajn/[],sc/[], ajc/[{core/{pos/v,form/Form},sc/[],sem/Sem}],sem/[A|Sem]} ); % tai_set(Form). (J.Fry 95.12) v_renyou(Form). dict_pos(das,Cat):-sub_verb(vcs,begin,Cat). dict_pos(kake,Cat):-sub_verb(vv,nearly,Cat). dict_pos(hajime,Cat):-sub_verb(vv,begin,Cat). dict_pos(owar,Cat):-sub_verb(vcr,end,Cat). dict_pos(tuzuke,Cat):-sub_verb(vv,continue,Cat). %%%%%%%%%%%%% Auxiliary verbs (jyo-doushi) %%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% --seru, --saseru : Causative verb (shieki) shieki_verb(Form, {core/{pos/v,form/vv},ajn/[], ajc/[{core/{pos/v,form/Form},sc/[{core/{pos/p,form/ga},sem/Iob}], sem/Act}], sc/[{core/{pos/p,form/ga},sem/Sbj}, {core/{pos/p,form/ni},sem/Iob}], sem/[cause,Sbj,Iob,Act]} ). dict_pos(sase,Cat):-shieki_verb(Form,Cat);sara_set(Form). dict_pos(se,Cat):-shieki_verb(Form,Cat);sere_set(Form). sara_set(vv). sara_set(vk). sere_set(vc_m). sere_set(v_sa). %%%%% --re(ru), --rare(ru) : Passive verb (ukemi) dict_pos(rare,Cat):-ukemi_verb(Form,Cat);sara_set(Form). dict_pos(re,Cat):-ukemi_verb(Form,Cat);sere_set(Form). ukemi_verb(Form, {core/{pos/v,form/vv},ajn/[], ajc/[{core/{pos/v,form/Form}, sc/[{core/{pos/p,form/ga},sem/Agt}, {core/{pos/p,form/F},sem/Pat}], sem/Act}], sc/[{core/{pos/p,form/ga},sem/Pat},{core/{pos/p,form/ni},sem/Agt}], sem/[passive,Pat,Agt,Act]} ); obj_case(F). control_passive([],Sbj,[]). control_passive( [{core/{pos/p,form/Form},ajc/[],ajn/[],sc/[],sem/Sbj}|Rest], Sbj,Rest):-obj_case(Form). obj_case(ni). obj_case(wo). %%% general auxirialy verb (syusi,rentai form & others) %%% nu, ta,u,you,mai aux_syu_ren(Form,A, {core/{pos/v,form/Fm},ajn/X,sc/[],sem/Z, ajc/[{core/{pos/v,form/Form},sc/Y,sem/Sem}]} ); syu_ren(Fm,X,Y,Z,[A,Sem]). aux_verb(Fm,Form,A, {core/{pos/v,form/Fm},ajn/[],sc/[],sem/[A,Sem], ajc/[{core/{pos/v,form/Form},sc/[],sem/Sem}]}). %%% rel_clause(Form,HSC,CSC,HAdjoin,Csem,Hsem) syu_ren(inf,[],[],Z,Z). syu_ren(rel,[{core/{pos/n},sem/inst(A,B)}],[{core/{pos/p},sem/A}], inst(A,[B,Z]),Z). %%%%% --na(i),--nu : Not dict_pos(na,Cat):-aux_verb(adj,Form,no,Cat); nai_set(Form). nai_set(vc_m). nai_set(vv). nai_set(vk). nai_set(v_si). nai_set(mizen). dict_pos(nu,Cat):-aux_syu_ren(Form,no,Cat);nu_set(Form). dict_pos(n,Cat):-aux_syu_ren(Form,no,Cat);nu_set(Form). dict_pos(zu,Cat):-aux_verb(renyou,Form,no,Cat);nu_set(Form). dict_pos(ne,Cat):-aux_verb(katei,Form,no,Cat);nu_set(Form). nu_set(vc_m). nu_set(vv). nu_set(vk). nu_set(v_se). %%%%% --ta,da : Past dict_pos(ta,Cat):-aux_syu_ren(Form,past,Cat);ta_form(Form). dict_pos(da,Cat):-aux_syu_ren(conj_de,past,Cat). dict_pos(tara,Cat):-aux_verb(katei,Form,past,Cat);ta_form(Form). dict_pos(dara,Cat):-aux_verb(katei,conj_de,past,Cat). ta_form(adj_tt). ta_form(na_tt). ta_form(X):-te_form(X). %%%%% --u, --you : suiryou (guess) or ishi(will) dict_pos(u,Cat):-aux_syu_ren(Form,may,Cat);u_set(Form). u_set(vc_o). u_set(mizen). dict_pos(you,Cat):-aux_syu_ren(Form,may,Cat);you_set(Form). you_set(vv). you_set(vk). you_set(v_si). %%%%% --rashii : suitei dict_pos(rashi,Cat):-aux_verb(adj,Form,polite,Cat);rashii_set(Form). rashii_set(na). rashii_set(F):-inf_form(F). %%%%%% --mai : not+guess, not+will dict_pos(mai,Cat):-aux_syu_ren(Form,no,Cat);mai_set(Form). mai_set(inf). mai_set(vv). mai_set(vk). mai_set(v_si). %%%%%% --ta(i) : hope dict_pos(ta,Cat):-aux_verb(adj,Form,hope,Cat);v_renyou(Form). %%%%% --sou(da). : may & I hear dict_pos(sou,Cat):-aux_verb(na,Form,A,Cat); souda_set(Form,A). souda_set(F,may):-souda_may_set(F). souda_may_set(F):-v_renyou(F). souda_may_set(adj). souda_may_set(na). souda_set(inf,hear). souda_set(a_inf,hear). %%%%% --desu, masu. : teinei desu(Inf,Cat):-aux_verb(Inf,Form,polite,Cat);desu_set(Form). desu_set(rel). desu_set(adj). desu_set(na). dict_pos(desho,Cat):-desu(vc_o,Cat). dict_pos(deshi,Cat):-desu(v_y,Cat). dict_pos(desu,Cat):-aux_syu_ren(Form,polite,Cat);desu_set(Form). masu(Inf,Cat):-aux_verb(Inf,Form,polite,Cat);v_renyou(Form). dict_pos(mase,Cat):-masu(v_se,Cat). dict_pos(masho,Cat):-masu(vc_o,Cat). dict_pos(mashi,Cat):-masu(v_y,Cat). dict_pos(masu,Cat):-aux_syu_ren(Form,polite,Cat);v_renyou(Form). dict_pos(masure,Cat):-masu(katei,Cat). dict_pos(mase,Cat):-masu(imp,Cat). %%%%% --nagara, --tsutsu : cont. adverb dict_pos(nagara, {core/{pos/adv,form/adv},sc/[], ajc/[{core/{pos/v,form/Form},sc/[],sem/SEM}], ajn/[{core/{pos/v1},ajc/[],ajn/[],sem/SEM1}], sem/[with,SEM,SEM1]} ); nagara_set(Form). nagara_set(a_inf). nagara_set(F):-v_renyou(F). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%% suffix.p %%%%%%%%%%%%%% %%%%%%%%%%%%%%%% verb suffix %%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% search_suffix(Form,Word,Cat) %%%%%%%%%%%%%% %% << Example >> %% mizen/ renyou/ syusi/ rentai/ katei/ imp/ %% %% vc? yom-mu ma mi mu mu me me %% mo(+u) n %% vv iki-ru _ _ ru ru re ro %% vk kuru ko ki kuru kuru kure koi %% vs1 tanjyou-suru si si suru suru sure seyo %% sa siro %% se %% vs2 ai-suru sa si suru suru sure seyo %% adj haya-i karo katt i i kere _ %% ku %% na kirei-da daro datt da na nara _ %% de %% ni %% << Form Table >> %% vc?: vc_m conj inf rel katei imp %% (vck,vcs,vct,vcn, vc_o conj_te (k,t,r,w,ik) %% vcr,vcw,vcg,vcb, conj_de (g,n,m,b) %% vcik) %% vv: vv vv inf rel katei imp %% vk: mizen v_y inf rel katei imp %% vs1: v_si v_si inf rel katei imp %% v_se %% v_sa %% vs2: vc_m v_y inf rel katei imp %% adj: mizen adj_tt a_inf rel katei __ %% adj_ku %% na: mizen na_tt a_inf rel katei __ %% na_de %% na_ni %%% exception search_suffix(adj,i, {core/{pos/v,form/Form},ajn/X,sc/[],sem/Z, ajc/[{core/{pos/v,form/adj},sc/Y,sem/Sem}]} ); syu_ren(Form,X,Y,Z,[neg,Sem]). search_suffix(na,na, {core/{pos/v,form/rel},sc/[], ajc/[{core/{pos/v,form/na}, sc/[{core/{pos/p},ajc/[],ajn/[],sc/[],sem/Obj}], sem/Sem}], ajn/[{core/{pos/n,form/n},ajc/[],ajn/[],sc/[],sem/inst(Obj,Type)}], sem/inst(Obj,[and,Type,Sem])} ). %%% suffix search search_suffix(Fm,Word, {core/{pos/v,form/Form},ajn/X,sc/[],sem/Z, ajc/[{core/{pos/v,form/Fm},sc/Y,sem/Sem}]} ) :-suff_s(Word,Fm);syu_ren(Form,X,Y,Z,Sem). search_suffix(Form2,Word, {core/{pos/v,form/Form1},ajn/[],sc/[], ajc/[{core/{pos/v,form/Form2},sc/[],sem/Sem}],sem/Sem} ) :-suff(Word,Form1,Form2). %%%%% suffix - syusi, rentai suff_s(su,vcs). suff_s(nu,vcn). suff_s(mu,vcm). suff_s(bu,vcb). suff_s(ku,vck). suff_s(ku,vcik). suff_s(tu,vct). suff_s(u,vcw). suff_s(ru,vcr). suff_s(ru,vv). suff_s(kuru,vk). suff_s(suru,vs1). suff_s(suru,vs2). %%%%% Suffix ( mizen, renyou, meirei ) %%% adj, na suff(karo,mizen,adj). suff(katt,adj_tt,adj). suff(ku,adj_ku,adj). suff(daro,mizen,na). suff(datt,na_tt,na). suff(de,na_de,na). suff(ni,na_ni,na). suff(da,a_inf,na). %%% vs, vk - mizen, renyou suff(se,v_se,vs1). suff(si,v_si,vs1). suff(sa,v_sa,vs1). suff(si,v_y,vs2). suff(ko,mizen,vk). suff(ki,v_y,vk). %%% v5 mizen suff(Suf,vc_m,Inf):-vc_m_suff(Suf,Inf). vc_m_suff(sa,vcs). vc_m_suff(sa,vs2). vc_m_suff(na,vcn). vc_m_suff(ma,vcm). vc_m_suff(ba,vcb). vc_m_suff(ka,vck). vc_m_suff(ka,vcik). vc_m_suff(ta,vct). vc_m_suff(wa,vcw). vc_m_suff(ra,vcr). suff(Suf,vc_o,Inf):-vc_o_suff(Suf,Inf). vc_o_suff(so,vcs). vc_o_suff(so,vs2). vc_o_suff(no,vcn). vc_o_suff(mo,vcm). vc_o_suff(bo,vcb). vc_o_suff(ko,vck). vc_o_suff(ko,vcik). vc_o_suff(to,vct). vc_o_suff(wo,vcw). vc_o_suff(ro,vcr). %%% v5 renyou suff(si,v_y,vcs). suff(Suf,conj,Inf):-vc_conj_suff(Suf,Inf). vc_conj_suff(ni,vcn). vc_conj_suff(mi,vcm). vc_conj_suff(bi,vcb). vc_conj_suff(wi,vcw). vc_conj_suff(gi,vcg). vc_conj_suff(ki,vck). vc_conj_suff(ki,vcik). vc_conj_suff(ti,vct). vc_conj_suff(ri,vcr). %%% v5 renyou - onbin suff(i,conj_te,vck). suff(i,conj_de,vcg). suff(t,conj_te,vct). suff(t,conj_te,vcw). suff(n,conj_de,vcb). suff(n,conj_de,vcm). suff(t,conj_te,vcr). % suff(n,conj_te,vcn). sin de, not sin te (FRY) suff(n,conj_de,vcn). suff(t,conj_te,vcik). %%% katei ( only -ba) suff(Suf,katei,Inf):-suff_ba(Suf,Inf). suff_ba(se,vcs). suff_ba(ne,vcn). suff_ba(me,vcm). suff_ba(be,vcb). suff_ba(ke,vck). suff_ba(ke,vcik). suff_ba(te,vct). suff_ba(we,vcw). suff_ba(re,vcr). suff_ba(re,vv). suff_ba(kure,vk). suff_ba(sure,vs1). suff_ba(sure,vs2). suff_ba(kere,adj). suff_ba(nara,na). %%% meirei suff(Suf,imp,Inf):-imp_suff(Suf,Inf). imp_suff(se,vcs). imp_suff(ne,vcn). imp_suff(me,vcm). imp_suff(be,vcb). imp_suff(ke,vck). imp_suff(ke,vcik). imp_suff(te,vct). imp_suff(we,vcw). imp_suff(re,vcr). imp_suff(ro,vv). imp_suff(koi,vk). imp_suff(siro,vs1). imp_suff(sero,vs1). imp_suff(seyo,vs2). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%% noun.dic %%%%%%%%%%%%%%%%%%%%%% %%%%%%% common noun, proper nouns %%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%% common nouns. c_noun(Sem,{core/{pos/n,form/n},sem/inst(Obj,Sem)}). dict1(ari,Cat):-c_noun(ant,Cat). dict1(esa,Cat):-c_noun(food,Cat). dict1(gakusha,Cat):-c_noun(scholar,Cat). dict1(gyouretsu,Cat):-c_noun(row,Cat). dict1(hana,Cat):-c_noun(flower,Cat). dict1(hatarakiari,Cat):-c_noun(worker_ant,Cat). dict1(hito,Cat):-c_noun(person,Cat). dict1(hon,Cat):-c_noun(book,Cat). dict1(ishi,Cat):-c_noun(stone,Cat). dict1(jimen,Cat):-c_noun(ground,Cat). dict1(katamari,Cat):-c_noun(block,Cat). dict1(michi,Cat):-c_noun(road,Cat). dict1(michishirube,Cat):-c_noun(row,Cat). dict1(michisuji,Cat):-c_noun(road,Cat). dict1(mokutekichi,Cat):-c_noun(goal,Cat). dict1(natsu,Cat):-c_noun(summer,Cat). dict1(niwa,Cat):-c_noun(garden,Cat). dict1(satou,Cat):-c_noun(sugar,Cat). dict1(soto,Cat):-c_noun(out,Cat). dict1(sumi,Cat):-c_noun(corner,Cat). dict1(tsubu,Cat):-c_noun(grain,Cat). dict1(yousu,Cat):-c_noun(yousu,Cat). dict1(yukute,Cat):-c_noun(way,Cat). %%%%%%% proper nouns. p_noun(Sem,{core/{pos/n,form/n},sem/Sem}). % dict1(america,Cat):-p_noun(america,Cat). (Fry) dict1(amerika,Cat):-p_noun(america,Cat). dict1(hiroshi,Cat):-p_noun(hiroshi,Cat). dict1(ken,Cat):-p_noun(ken,Cat). dict1(naomi,Cat):-p_noun(naomi,Cat). dict1(wilson,Cat):-p_noun(wilson,Cat). %%%%% jibun (self) dict1(jibun, {core/{pos/n,form/n}, refl/[{core/{pos/p,form/ga},sem/Sem}], sem/Sem}). dict1(jken, {core/{pos/n,form/n}, refl/[{core/{pos/p,form/ga},sem/ken}], sem/ken}). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%% verb.dic %%%%%%% %%%%%% Verbs except sahen-v %%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% vi (|subcat|==1: --ga) ga_verb(F,Act, {core/{pos/v,form/F}, sc/[{core/{pos/p,form/ga},sem/Sbj}], sem/[Act,Sbj]}). %%%%% vt (|subcat|==2:) %% --ga --wo ga_wo_verb(F,Act, {core/{pos/v,form/F}, sc/[{core/{pos/p,form/ga},sem/Sbj}, {core/{pos/p,form/wo},sem/Obj}], sem/[Act,Sbj,Obj]}). %% --ga --ni ga_ni_verb(F,Act, {core/{pos/v,form/F}, sc/[{core/{pos/p,form/ga},sem/Sbj}, {core/{pos/p,form/ni},sem/Obj}], sem/[Act,Sbj,Obj]}). %% --ga --wo --ni ga_wo_ni_verb(F,Act, {core/{pos/v,form/F}, sc/[{core/{pos/p,form/ga},sem/Sbj}, {core/{pos/p,form/wo},sem/Iob}, {core/{pos/p,form/ni},sem/Dob}], sem/[Act,Sbj,Iob,Dob]}). %%% temp feature %% kiru,akeru temp1({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,2,2,f,f,AB,AE,AD,AT). %% anki-suru temp2({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,2,0,f,u,AB,AE,AD,AT). %% aruku,yomu temp3({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,2,2,f,0,AB,AE,AD,AT). %% matu,damaru temp4({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,1,1,f,0,AB,AE,AD,AT). %% suwaru,kekkon-suru temp5({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,2,2,0,f,AB,AE,AD,AT). %% suwaru,sinu temp6({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,2,0,0,f,AB,AE,AD,AT). %% niru,tadayou temp7({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(0,0,0,0,u,AB,AE,AD,AT). %% odoroku,tumaduku temp8({core/{view/asp(AB,AE,AD,AT)}}); temp_cstr(3,2,2,0,0,AB,AE,AD,AT). %%% lexical entry dict1(age,Cat):-ga_wo_ni_verb(vv,give,Cat). dict1(ai,Cat):-ga_wo_verb(vs2,love,Cat). dict1(ake,Cat):-ga_wo_verb(vv,open,Cat),temp1(Cat). % dict1(aruku,Cat):-ga_verb(vck,walk,Cat). (Fry) dict1(aruk,Cat):-ga_verb(vck,walk,Cat). dict1(chigaw,Cat):-ga_verb(vcw,differ,Cat). dict1(chirijirininar,Cat):-ga_verb(vcr,scatter,Cat). dict1(deki,Cat):-ga_verb(vv,can,Cat). % dict1(der,Cat):-ga_ni_verb(vv,go_out,Cat). (Fry) dict1(de,Cat):-ga_ni_verb(vv,go_out,Cat). % dict1(hashi,Cat):-ga_verb(vcr,run,Cat). (Fry) dict1(hashir,Cat):-ga_verb(vcr,run,Cat). dict1(hazure,Cat):-ga_wo_verb(vv,be_off,Cat). dict1(i,Cat):-ga_verb(vv,be,Cat). dict1(ik,Cat):-ga_ni_verb(vck,go_to,Cat). dict1(isog,Cat):-ga_verb(vcg,hurry,Cat). dict1(kaer,Cat):-ga_ni_verb(vcr,return,Cat). dict1(kag,Cat):-ga_wo_verb(vcg,smell_of,Cat). dict1(kak,Cat):-ga_wo_verb(vck,write,Cat). dict1(kaw,Cat):-ga_wo_verb(vcw,buy,Cat). dict1(kawar,Cat):-ga_verb(vcr,lose,Cat). dict1(kat,Cat):-ga_ni_verb(vct,win,Cat). % dict1(ker,Cat):-ga_wo_verb(vv,kick,Cat). (Fry) dict1(ke,Cat):-ga_wo_verb(vv,kick,Cat). dict1(ki,Cat):-ga_wo(vv,wear,Cat),temp1(Cat). dict1(majiwar,Cat):-ga_verb(vcr,cross,Cat). dict1(manab,Cat):-ga_wo_verb(vcb,learn,Cat). dict1(mayow,Cat):-ga_verb(vcw,be_lost,Cat). dict1(mi,Cat):-ga_wo_verb(vv,see,Cat). dict1(midare,Cat):-ga_verb(vv,be_confused,Cat). dict1(mitsuke,Cat):-ga_wo_verb(vv,find,Cat). dict1(mot,Cat):-ga_wo_verb(vct,have,Cat). % dict1(nar,Cat):-ga_ni_verb(vv,become,Cat). (Fry) dict1(na,Cat):-ga_ni_verb(vv,become,Cat). dict1(nor,Cat):-ga_ni_verb(vcr,get_on,Cat). dict1(ok,Cat):-ga_wo_ni_verb(vck,put,Cat). dict1(omow,Cat):-ga_wo_verb(vcw,think,Cat). dict1(os,Cat):-ga_wo_verb(vcs,push,Cat). % dict1(saegi,Cat):-ga_wo_verb(vcr,interrupt,Cat). (Fry) dict1(saegir,Cat):-ga_wo_verb(vcr,interrupt,Cat). dict1(sagas,Cat):-ga_wo_verb(vcs,seek,Cat). dict1(shir,Cat):-ga_wo_verb(vcr,know,Cat). dict1(shin,Cat):-ga_verb(vcn,die,Cat). dict1(susum,Cat):-ga_ni_verb(vcm,advance,Cat). dict1(tador,Cat):-ga_wo_verb(vcr,follow,Cat). % dict1(tasuker,Cat):-ga_wo_verb(vv,help,Cat). (Fry) dict1(tasuke,Cat):-ga_wo_verb(vv,help,Cat). dict1(toor,Cat):-ga_ni_verb(vcr,pass,Cat). % dict1(tsuger,Cat):-ga_wo_ni_verb(vv,tell,Cat). (Fry) dict1(tsuge,Cat):-ga_wo_ni_verb(vv,tell,Cat). dict1(tsuk,Cat):-ga_ni_verb(vck,reach,Cat). dict1(tsuzuku,Cat):-ga_verb(vck,continue,Cat). dict1(wakar,Cat):-ga_wo_verb(vcr,understand,Cat). dict1(yom,Cat):-ga_wo_verb(vcm,read,Cat). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% sahen.dic %%%%% sahen-n,v dictionary %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% verb : SURU suru_verb(F, {core/{pos/vs,form/F},ajc/Adj,sc/SC,sem/Sem}); suru(Adj,SC,Sem). dict1(shi,Cat):-suru_verb(v_si,Cat). dict1(se,Cat):-suru_verb(v_se,Cat). dict1(sa,Cat):-suru_verb(v_sa,Cat). dict1(sure,Cat):-suru_verb(katei,Cat). dict1(shiro,Cat):-suru_verb(imp,Cat). dict1(sero,Cat):-suru_verb(imp,Cat). %%%%% sa-hen verbs (do) sahen_verb(F,Act, {core/{pos/v,form/F},sc/[{core/{pos/p,form/ga},sem/Sbj}], sem/[Act,Sbj]} ). dict1(tanjou,Cat):-sahen_verb(vs1,be_born,Cat). %%%%% sa-hen nouns. %% dict1(chousa, %% {pos/n,NFORM,[],[],SC,[],[],Sem} ); %% sahen_noun(NFORM,investigate,SC,SEM). %% sahen_noun(n,SEM,[],SEM). %% sahen_noun(ns,SEM1,SC,[SEM1,Sbj,Obj]):-adn_wo_ga(SC,Obj,Sbj). dict1(chousa, {core/{pos/n,form/ns},sc/SC,sem/[investigate,Sbj,Obj]} ); adn_wo_ga(SC,Obj,Sbj). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% adject.dic %%%%% adjective, adjective-verb %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% Adjectives %%%%%%%%%%%%% adjective(A, {core/{pos/v,form/adj}, sc/[{core/{pos/p,form/ga},sem/Obj}], sem/[A,Obj]} ). dict1(aka,Cat):-adjective(red,Cat). dict1(siro,Cat):-adjective(white,Cat). dict1(kuro,Cat):-adjective(black,Cat). dict1(ooki,Cat):-adjective(big,Cat). dict1(yo,Cat):-adjective(good,Cat). %%%%% na (adjective-verb) ajverb(A, {core/{pos/v,form/na}, sc/[{core/{pos/p,form/ga},sem/Obj}], sem/[A,Obj]} ). dict1(kirei,Cat):-ajverb(beautifle,Cat). dict1(kaiteki,Cat):-ajverb(comfortable,Cat). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%% etc.dic %%%%%%% dictionary of other words %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%% rentai-shi rentaishi(A, {core/{pos/adn, form/adn}, ajn/[{core/{pos/n,form/n},ajc/[],ajn/[],sc/[],sem/SEM}], % sem/[A|SEM]} sem/[A|[SEM]]} ). dict1(sono,Cat):-rentaishi(the,Cat). dict1(kono,Cat):-rentaishi(this,Cat). dict1(ano,Cat):-rentaishi(that,Cat). dict1(ippikino,Cat):-rentaishi(one,Cat). %%%%%%% fuku-shi (adverb) adverb(MODIFY, {core/{pos/adv, form/adv}, ajn/[{core/{pos/v},sem/SEM}], sem/[MODIFY|SEM]}). dict1(yoku,Cat):-adverb(often,Cat). dict1(zutto,Cat):-adverb(continue,Cat). dict1(hajimeni,Cat):-adverb(first,Cat). dict1(sukoshi,Cat):-adverb(slightly,Cat). dict1(yagate,Cat):-adverb(in_the_end,Cat). dict1(tsugitsugito,Cat):-adverb(continue,Cat). dict1(dandanni,Cat):-adverb(gradually,Cat). dict1(komakani,Cat):-adverb(minutely,Cat). dict1(kesshite, % {core/{pos/adv,form/adv}, ajn/[{core/{pos/v},sem/[not|SEM]}],(Fry) {core/{pos/adv,form/adv}, ajn/[{core/{pos/v},sem/[no|SEM]}], sem/[never|SEM]}). %% Examples %% ?-p([ken,ga,naomi,wo,ai,suru]). %% ?-p([ken,ga,naomi,ni,ai,sa,re,ta]). %% %%%%%%%%%%%%%%%%% %%%%%%% common nouns. c_noun(Sem,{core/{pos/n,form/n},sem/inst(Obj,Sem)}). dict1(ari,Cat):-c_noun(ant,Cat). dict1(esa,Cat):-c_noun(food,Cat). dict1(gakusha,Cat):-c_noun(scholar,Cat). dict1(gyouretsu,Cat):-c_noun(row,Cat). dict1(hana,Cat):-c_noun(flower,Cat). dict1(hatarakiari,Cat):-c_noun(worker_ant,Cat). dict1(hito,Cat):-c_noun(person,Cat). dict1(hon,Cat):-c_noun(book,Cat). dict1(ishi,Cat):-c_noun(stone,Cat). dict1(jimen,Cat):-c_noun(grosample/README 644 10266 36 730 5712104033 6271 cu-Prolog example programs: memap.p: Unfold/fold constraint transformation examples using predicates member/2 and append/3. kasper.p: Disjunctive feature structure unification ex. 1 eisele.p: Disjunctive feature structure unification ex. 2 jpsg.p : JPSG (Japanese Phrase Structure Grammar) parser example hpsg.p : HPSG (Head-driven Phrase Structure Grammar) parser example marcus.p: simple CFG English grammar based on Marcus's book bagof.p : bag_of/3 in cu-Prolog %% Examples %% ?-p([ken,ga,naomi,wo,ai,sample/kasper.p 644 10266 36 3530 5570051130 7101 %% Example in %% Kasper, A Unification Method for Disjunctive Feature Descriptions, %% 25th ACL, 1987. %% Disjunctive feature unification between %% [rank:clause,subj:case:nom]^ %% {[voice:passive,transitivity:trans,=] or %% [voice:active,=]} ^ %% {[transitivity:intrans,actor:person:3] or %% [trnsitivity:trans,goal:person:3]} ^ %% {[number:sing,subj:number:sing] or [number:pl, subj:number:pl]} %% and %% [subj:[lex:y'all,person:2,number:pl]] %% --> %% [rank:clause,subj:[case:nom,lex:y'all,person:2,number:pl], %% number:pl,voice:active,=,transitivity:trans,goal:person,3] %% cc1({voice/passive,trans/trans,subj/X,goal/X}). cc1({voice/active, subj/X,actor/X}). cc2({trans/intrans, actor/{person/third}}). cc2({trans/trans, goal/{person/third}}). cc3({numb/sing, subj/{numb/sing}}). cc3({numb/pl, subj/{numb/pl}}). %% %p > %% spy constraint transformation %% %s %% step trace on @ U={rank/clause, subj/{case/nom}},cc1(U),cc2(U),cc3(U), U={subj/{lex/yall,person/second,numb/pl}}. %% --> c0(...) %% then solve :-c0(U,_,_). U is the solution. %% ---------------------------------------------- %% solution = c0(U_0, {subj/{person/second, numb/pl, lex/yall}}, %% {subj/{case/nom}, rank/clause}) %% c0(_p1, {subj/{person/second, numb/pl, lex/yall}}, {subj/{case/nom}, %% rank/clause}) :- cc2(_p1), cc1(_p1), fail;_p1={subj/{numb/sing}, %% numb/sing}. %% c0(_p1, _p1, _p1) :- cc2(_p1), cc1(_p1);_p1={subj/{person/second, %% numb/pl, case/nom, lex/yall}, numb/pl, rank/clause}. %% %% CPU time = 0.000 sec (Constraints Handling = 0.000 sec) %% %% _:-c0(U,_,_). %% U = {voice/active, trans/trans, subj/{person/second, numb/pl, %% case/nom, lex/yall}, goal/{person/third}, actor/{person/second, %% numb/pl, case/nom, lex/yall}, numb/pl, rank/clause}; %% %% CPU time = 0.017 sec (Constraints Handling = 0.000 sec) %% _ ,form/n}, refl/[{core/{pos/p,form/ga},sem/Sem}], sem/Sem}). dict1(jken, {core/{pos/n,form/n}, refl/[{core/{pos/p,form/ga},sem/ken}], sem/ken}). %%%%%%%%%%%%%%%%%%%sample/memap.p 644 10266 36 1401 5570050533 6714 %%% %%% test programs of the UNFOLD/FOLD constraint transformer %%% member(X,[X|Y]). member(X,[Y|Z]):-member(X,Z). append([],X,X). append([A|X],Y,[A|Z]):-append(X,Y,Z). %% %% constraint transformation examples %% @ member(X,[a,b,c]),member(X,[b,c,d]). % solution = c0(X_0) % c0(b). % c0(c). @ member(X,[a,b,c]),member(X,[j,k,l]). %% -> transformation fails % solution = fail. @ member(A,X),append(X,Y,Z). %% needs fold transformation % solution = c2(X_1, Y_2, Z_3, A_0) % c4(V0_0, V1_1, V2_2, [V0_0 | V3_3]) :- append(V1_1, V2_2, V3_3). % c3(V0_0, V1_1, V2_2, [V0_0 | V3_3], V4_4) :- c2(V1_1, V2_2, V3_3, V4_4). % c2([V0_0 | V1_1], V2_2, V3_3, V0_0) :- c4(V0_0, V1_1, V2_2, V3_3). % c2([V0_0 | V1_1], V2_2, V3_3, V4_4) :- c3(V0_0, V1_1, V2_2, V3_3, V4_4). {trans/trans, goal/{person/third}}). cc3({numb/sing, subj/{numb/sing}}). cc3({numb/pl, subj/{numb/pl}}). %% %p > %% spy constraint transformation %% %s %% step trace on @ U={rank/clause, subj/{case/nom}},cc1(U),cc2(U),cc3(U), U={subj/{lex/yall,personsample/marcus.p 644 10266 36 7664 5454477514 7145 %%%%%%%%%%%%%%%%%%%%%%%%% marcus.p %%%%%%%%%%%%%%%%%%%%%%%%%% %%% A simple English parser %%% for examples of Marcus, 1980 %%% 1993.9.21 H.Tsuda (tsuda@icot.or.jp) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Category : %%% {pos/POS, sc/SC, slash/SL, sem/SEM} %%% POS: part of speech %%% SC: subcat (list of categories) %%% SL: slash (list of categories) %%% SEM: semantics (term) %%% Left Corner Parser p(Sentence) :- parse(Sentence,[],Cat,H),nl, tree(H),nl, write("category= "),write(Cat),nl, write("constraint="),project_cstr(Cat,NewCstr),write(NewCstr),nl. parse(Str,Rest,Cat,Tree) :- lookup(Str,SubStr,WordSem,Tree1),!, parse1(WordSem,Tree1,SubStr,Rest,Cat,Tree). parse1(Cat,Tree,Str,Str,Cat,Tree). parse1(LCat,LTree,Str,Rest,Cat,Tree) :- parse(Str,SubStr,RCat,Tree1), psr(LCat,RCat,MCat,RNo), parse1(MCat,t(t(MCat,RNo,[]),LTree,Tree1),SubStr,Rest,Cat,Tree). %% semantic_preference(Cat,P) animate_pref({kind/high_animate},sem_very_good). animate_pref({kind/animate},sem_good). animate_pref({kind/inanimate},sem_bad). lookup([Word|Rest],Rest,Cat,t(Cat,[Word],[])) :- lexicon(Word,Cat). noun(Sem,{pos/n,sc/[],slash/[],sem/Sem}). lexicon(which,{pos/p,sc/[{pos/n,sem/X}],slash/[],sem/X}). lexicon(who,{pos/p,sc/[],slash/[],sem/"?"}). lexicon(him,{pos/p,sc/[],slash/[],sem/{name/he,sex/male,kind/high_animate}}). lexicon(boy,Cat):- noun({name/boy,kind/high_animate},Cat). lexicon(knight,Cat):- noun({name/knight,kind/high_animate},Cat). lexicon(dragon,Cat):- noun({name/dragon,kind/animate},Cat). lexicon(cannibals,Cat):- noun({name/cannibal,kind/high_animate},Cat). lexicon(sword,Cat) :- noun({name/sword,kind/inanimate},Cat). lexicon(the,{pos/p,sc/[{pos/n,sem/X}],slash/[],sem/X}). lexicon(a,{pos/p,sc/[{pos/n,sem/X}],slash/[],sem/X}). lexicon(give,{pos/v,sc/SC,slash/SL, sem/{act/give,agt/SBJ,do/DO,io/IO,sem_pref/SP,syn_pref/P}}); slash_intro([{pos/p,sem/IO},{pos/p,sem/DO},{pos/p,sem/SBJ}],SC,SL,P), animate_pref(IO,SP). lexicon(gave,{pos/v,sc/SC,slash/SL, sem/{act/gave,agt/SBJ,do/DO,io/IO,sem_pref/SP,syn_pref/P}}); slash_intro([{pos/p,sem/IO},{pos/p,sem/DO},{pos/p,sem/SBJ}],SC,SL,P), animate_pref(IO,SP). lexicon(hit,{pos/v,sc/SC,slash/SL, sem/{act/hit,agt/SBJ,obj/Obj}}); slash_intro([{pos/p,sem/Obj},{pos/p,sem/SBJ}],SC,SL,_). lexicon(run,{pos/v,sc/SC,slash/SL,sem/{act/run, agt/SBJ}}); slash_intro([{pos/p,sem/SBJ}],SC,SL,_). lexicon(did,{pos/aux,sc/[{pos/v,slash/SL,sc/[],sem/X}],slash/SL,sem/X}). %% slash_introduction(SC,NewSC,NewSL,Pref) slash_intro([E],[E],[],0). slash_intro([E1,E2],[E1,E2],[],0). slash_intro([E1,E2],[E2],[E1],0). slash_intro([E1,E2,E3],[E1,E2,E3],[],next_as_io). slash_intro([E1,E2,E3],[E2,E3],[E1],wh_as_io). slash_intro([E1,E2,E3],[E1,E3],[E2],next_as_io). psr(L,R,M,No) :- sc_p(L,R,M,No). %%% p-np, aux-vp sc_p({pos/P,sc/[R|Rest],slash/SL,sem/X},R, {pos/P,sc/Rest,slash/SL,sem/X},[1]); left_head(P). left_head(p). left_head(aux). %%% vp-obj sc_p({pos/v,sc/[R,E|Rest],slash/SL,sem/X},R, {pos/v,sc/[E|Rest],slash/SL,sem/X},[2]). %%% sbj-vp sc_p(L,{pos/v,sc/[L],slash/SL,sem/X},{pos/v,sc/[],slash/SL,sem/X},[3]). %%% relative clause sc_p(L,{pos/aux,sc/[],slash/[L],sem/X},{pos/aux,sc/[],slash/[],sem/X},[4]) ;L={pos/p}. %%% Examples %%% (*) :-p([which,boy,did,the,knight,give,the,dragon]). %%% :-p([the,knight,gave,the,dragon,a,boy]). %%% :-p([which,dragon,did,the,knight,give,the,boy]). %%% :-p([the,knight,gave,the,boy,a,dragon]). %%% (?) :-p([which,boy,did,the,knight,give,the,sword]). %%% :-p([the,knight,gave,a,boy,the,sword]). %%% :-p([which,sword,did,the,knight,give,the,boy]). %%% :-p([the,knight,gave,the,boy,a,sword]). %%% (?) :-p([which,boy,did,the,knight,give,the,cannibals]). %%% :-p([what,did,the,knight,give,the,dragon]). %%% (*) :-p([which,boy,did,the,knight,give,the,dragon]). %%% :-p([which,dragon,did,the,knight,give,the,boy]). %%% (?) :-p([which,boy,did,the,knight,give,the,sword]). %%% :-p([the,knight,gave, the, dragon, the, boy]). %%% :-p([the, knight, gave, the, boy, the, dragon]). % --ga --ni ga_ni_verb(F,Act, {core/{pos/v,form/F}, sc/[{core/{pos/p,forsample/hpsg.p 644 10266 36 4335 5570047275 6600 %%%%%%%%%%%%%%%%%%%%%%%%% hpsg.p %%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Simple HPSG parser %% 1994.5.20 %% grammar by G.Smolka %% programmed by H.Tsuda %% {head/_, sc/_, ph/_} %% ---------------------------------------------------- %% head: head feature %% sc: subcat feature %% ph: phnological feature %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Example. %% ?-p([mary,meets,john]). %% ?-p([the,girl,is,mary]). %% ?-p([mary,is,embarrassed]). %% %% Left Corner Parser p(Sentence):- parse0(Cat,H,Sentence,[]),nl, tree(H),nl, write("category= "),write(Cat),nl, write("constraint= "),pcon,nl. parse0(MCat,MHist,Str,Rest):- lookup(Str,SubStr,Cat,Hist),!, parse1(Cat,Hist,MCat,MHist,SubStr,Rest). parse1(Cat,H,Cat,H,Str,Str). parse1(LCat,LHist,GCat,GHist,Str,Rest):- psr(LCat,RCat,MCat,RN), parse0(RCat,RHist,Str,SubStr), parse1(MCat,t(t(MCat,RN,[]),LHist,RHist), GCat,GHist,SubStr,Rest). %%% phrase structure rules %%% psr(LeftCat,RightCat,MotherCat) psr(Head,D,P,1); % Right head sc_p(Head,D,P), head_p(Head,P), ph_p(Head,D,P). psr(D,Head,P,2); % Left head sc_p(Head,D,P), head_p(Head,P), ph_p(D,Head,P). %% head feature principle %% head_p(HeadDaughter, Mother) head_p({head/H},{head/H}). %% phonology feature principle %% ph_p(LeftDaughter, RightDaughter, Mother) ph_p({ph/LP},{ph/RP},{ph/PP}) :- append(LP,RP,PP). %% subcat feature principle %% sc_p(Head,Daughter,Mother) sc_p({sc/[RH|PSC]},{head/RH,sc/[]},{sc/PSC}). %%% dictionary %%% lookup(Str,RestStr,Cat,History) lookup([Word|X],X,{ph/[Word],head/Cat,sc/SC},t(Cat,[Word],[])) :-dict(Word,Cat,SC). dict(mary, noun, []). dict(john, noun, []). dict(girl, noun, [determiner]). dict(nice,adjective,[]). dict(pretty,adjective,[]). dict(the,determiner,[]). dict(laughs,verb,[noun]). dict(meets,verb,[noun,noun]). dict(kisses,verb,[noun,noun]). dict(embarrasses,verb,[noun,noun]). dict(thinks,verb,[verb,noun]). dict(is,verb,[adjective,noun]). dict(met,adjective,[]). dict(kissed,adjective,[]). dict(embarrassed,adjective,[]). %%% constraints definition append([],X,X). append([A|X],Y,[A|Z]):-append(X,Y,Z). member(X,[X|Y]). member(X,[Y|Z]):-member(X,Z). %%%%%%%%%%%%% sahen constraint %%%%%%%%%%%%%%%%%%% . %%% :-p([which,dragon,did,the,knight,give,the,boy]). %%% (?) :-p([which,boy,did,the,knight,give,the,sword]). %%% :-p([the,knight,gave, the, dragon, the, boy]). %%% :-p([the, knight, gave, the, boy, the, dragon]). % --ga --ni ga_ni_verb(F,Act, {core/{pos/v,form/F}, sc/[{core/{pos/p,forsample/bagof.p 644 10266 36 473 5712104011 6650 % Example: bag_of/3 in cu-Prolog bagof(T,G,S) :- assert(bagOfTmp([])), apnd(G,[retract(bagOfTmp(U)),assert(bagOfTmp([T|U])),fail],NG), not(execute(NG)), retract(bagOfTmp(S)). %% :-bagof(X,[memb(X,[a,b,c])],S). %% X = T_10 S = [c,b,a] %%_:-bagof(f(X),[memb(X,[a,b,c])],S). %% X = X_10 S = [f(c),f(b),f(a)] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Example. %% ?-p([mary,meets,john]). %% ?-p([the,girl,is,mary]). %% ?-p([mary,is,embarrassed]). %% %% Left Corner Parser p(src/ 775 10266 36 0 5712105615 4663 src/defsysp.c 644 10266 36 66104 5712121410 6605 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << defsysp.c >> * (define system predicate entry) * 93.7.15 add dummy in defsyspred() * 1994.9.27 atom_to_str * 1995.1.27 retract (type2-->type1), not (debug) --------------------------------------------------------------------*/ #define SYSPRED 1 #include "include.h" #if SUN4 == 1 #include #else #if CPUTIME != 0 #include #include #endif #endif #define XF 0210 #define YF 0200 #define FX 0101 #define FY 0100 #define XFY 0310 #define YFX 0301 #define XFX 0311 #define Def1(F,N,A,P) (F = Nfunc(TYPE1SYS,N,A))->def.f_sysfunc=P #define Def1Red(F,N,A,P) (F = Nfunc(TYPE1SYS_REDUCED,N,A))->def.f_sysfunc=P #define Def2(F,N,A,P) (F = Nfunc(TYPE2SYS,N,A))->def.f_sysfunc=P #define Def2Red(F,N,A,P) (F = Nfunc(TYPE2SYS_REDUCED,N,A))->def.f_sysfunc=P #define Deftemp(F,N,A) F = Nfunc(TEMPFUN,N,A) #define Defatom(T,N) \ ((T = Nterm(0,ETERNAL))->type.t_func = Nfunc(TYPE1SYS,N,0)) #define Npstobj(Head,Env,Tail,Flag) Neclause(Head,Env,Tail,Flag) long OLD_TIME = 0L; /* cf. TYPE1SYS : system functional predicate (has only one solution) TYPE2SYS : system non-functional predicate (has many solutions) */ /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ init_syspted() initialize system predicates : called by init_status() ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void init_syspred () { /* initialize system predicates */ void init_froles(); defsyspred (); /* define system predicate */ init_atoms(); /* init atoms */ init_operator(); /* init operator */ init_category(); /* init cat() functor */ init_froles(); /* init components */ } void defsyspred() /* define system embedded predicate */ { salloc((sizeof(struct func) / sizeof(int))); /* dummy 93.7.15*/ Def1Red(ABOMB_P,"aTomIcbOmb",0,abomb_pred); Def1Red(ABOLISH_P,"abolish",2,abolish_pred); /* abolish of def */ Def2Red(APND_P,"apnd",3,apnd_pred); /* system append */ Def1Red(ARG_P,"arg",3,arg_pred); /* arg(Pos,Term,Argument) */ Def1Red(ASSERT_P,"assert",1,assert_pred); /* assert(PredName) */ Def1Red(ASSERTA_P,"asserta",1,assert_pred); Def1Red(ASSERTZ_P,"assertz",1,assertz_pred); Def1Red(ASSERT_P,"assert",2,assert_pred); /* assert(Pred,Defs) */ Def1Red(ASSERTA_P,"asserta",2,assert_pred); Def1Red(ASSERTZ_P,"assertz",2,assertz_pred); Def1Red(ASSERT_P,"assert",3,assert_pred); /* assert(Pred,Defs,Const) */ Def1Red(ASSERTA_P,"asserta",3,assert_pred); Def1Red(ATOMTOSTR_P,"atom_to_str",2,atom_to_str_pred); /* atom_to_str(Atom,^Str) */ Def2(ATTACH_P,"attach_constraint",1,attach_pred); Def1Red(ASSERTZ_P,"assertz",3,assertz_pred); /* cat(Pos,Form,Adjacent,Adjunct,Subcat,Sem) */ Def1Red(CNAME_P,"condname",2, cname_pred); /* constraint name */ Def2Red(CLAUSE_P,"clause",3, clause_pred); /* clause(head,body,const) */ Def1Red(CLOSE_P,"close",1,close_pred); /* file close */ Def1Red(CMP_P,"compare",3,compare_pred); Def2Red(CONCAT_P,"concat",3, concat_pred); /* string concatenate */ Def1Red(CONCAT2_P,"concat2", 2, concat2_pred); Def1Red(COUNT_P,"count",1, count_pred); /* counter */ Def1Red(CUNIFY,"unify",2, cunify_pred); Def1(CUT_P,"!", 0, cut_pred); Def1Red(DEFAULT_P,"default",3,default_pred); Def1Red(DIVSTR_P,"divstr",4,divstr_pred); Def1Red(EQUAL_P,"equal",2, equal_pred); /* = (check, substitution) */ Def1Red(NEQ_P,"neq",2, nequal_pred); /* t1=\=t2 */ Def1Red(EQ_P,"eq",2, eq_pred); Def2(EXECUTE_P,"execute",1,or_pred); /* execute(List) */ Def1Red(FAIL_P,"fail", 0, NULL); /* fail, forever */ Def1Red(GENSYM_P,"gensym",2, gensym_pred); Def1Red(FUNCTOR_P,"functor",3, functor_pred); /* functor(a(X,Y),a,2) */ Def1Red(GENSYM_P,"gensym",1, gensym_pred); /* gensym */ Def1Red(GEQ_P,"geq",2,geq_pred); /* >= */ Def1Red(GREATER_P,"greater",2,greater_pred); /* > */ Def1Red(HALT_P,"halt",0, halt_pred); Def2Red(ISOP_P,"isop",3,isop_pred); Def1Red(LEQ_P,"leq",2,leq_pred); /* <= */ Def1Red(LESS_P,"less",2,less_pred); /* < */ Def1Red(MAKELIST_P,"ml",2, makelist_pred); /* a(X,Y)=..[a,X,Y] */ /* Def1(MODULAR_P,"modularize",2, cunify_pred);*/ Def2Red(MEMB_P,"memb",2,memb_pred); /* system 'member' */ Def1Red(MULTIPLY_P,"multiply",3, multiply_pred); /*multiply(X,Y,Z) is X*Y=Z */ Def1Red(NAME_P,"name",2, name_pred); /* array<->string */ Def1Red(NL_P,"nl",0, nl_pred); /* print CR */ Def1Red(NL_P,"nl",1, nl_pred); /* print CR */ Def1Red(OP_P,"op",3,op_pred); /* operator def */ Def1Red(OPEN_P,"open",3,open_pred); /* file open */ Def2(OR_P,"or",2, or_pred); /* or */ Def2(OR_P,"or",3,or_pred); Def2(OR_P,"or",4,or_pred); Def2(OR_P,"or",5,or_pred); Def1(PROJECT_P ,"project_cstr",1, project_pred); /* print constraint */ Def1(PROJECT_P ,"project_cstr",2, project_pred); /* print constraint */ Def1(PCONSTRAINT_P ,"pcon",0, pcon_pred); /* print constraint */ Def1Red(READ_P,"read",1,read_pred); /* read TERM */ Def1Red(READ_P,"read",2,read_pred); Def1Red(RETRACT_P,"retract",1,retract_pred); /* retract(Head) */ Def1Red(RETRACT_P,"retract",2,retract_pred); /* retract(Head,Defs) */ Def1Red(RETRACT_P,"retract",3,retract_pred); /* retract(H,D,Constr) */ Def1Red(STAY_P,"stayflag",3,stay_pred); /* set stayflag */ Def1Red(SEE_P,"see",1,see_pred); /* input file open */ Def1Red(SEEN_P,"seen",0,seen_pred); /* input file close */ Def1Red(STRLEN_P,"strlen",2,strlen_pred); /* length of string */ Def1Red(STRCMP_P,"strcmp",3,strcmp_pred); Def1Red(SUBSTR_P,"substring",3,substr_pred); /* substring(Str,F,S) */ Def1Red(SUBSTR_P,"substring",4,substr_pred); /* substring(Str,F,N,S) */ Def1Red(SUM_P,"sum",3,sum_pred); /* sum(X,Y,Z) is X+Y=Z */ Def1Red(TAB_P,"tab",0,tab_pred); /* print tab */ Def1Red(TAB_P,"tab",1,tab_pred); /* print tab */ Def1Red(TELL_P,"tell",1,tell_pred); /* output file open */ Def1Red(TOLD_P,"told",0,told_pred); /* output file close */ Def1Red(TREE_P,"tree",1,tree_pred); /* tree print */ Def2Red(TRUE_P,"true",0,true_pred); /* true, forever */ Def1Red(UNBREAK_P,"unbreak",0,unbreak_pred); /* back to tracemode */ Def1Red(VAR_P,"var",1, var_pred); /* var() pred */ Def1Red(WRITE_P,"write",1,write_pred); /* write TERM */ Def1Red(WRITE_P,"write",2,write_pred); Def1Red(PNAMES_P,"pnames",2,pnames_pred); /* get Property Names */ Def1Red(PVALUE_P,"pvalue",3,pvalue_pred); /* pvalue(PST,PNAME,VAL) */ Def1Red(TYPE_P,"type",2,type_pred); /* what type is it? */ Def1Red(RESET_TIMER_P,"reset_timer",0,reset_timer_pred); Def1Red(TIMER_P,"timer",2,timer_pred); /* predicate not in hash-table */ Deftemp(MODULAR_P,"modularize",2); Deftemp(INTEG_P,"integrate",2); } void init_atoms() { Def1(CAT_P,"cat",6, NULL); /* category */ Def1(T_P,"t",3,NULL); /* three list t(M,L,R) */ Def1(LIST,".",2,NULL); /* list */ NIL = Nterm(0,ETERNAL); /* NIL = [] : end of list*/ NIL ->type.t_func = Nfunc(ETERNAL,"NIL", 0); NIL->type.ident = ATOMIC_TYPE; (FAIL = Nterm(0,ETERNAL))->type.t_func = FAIL_P; Defatom(END_OF_FILE, "end_of_file"); Anonymous_var = (struct term *)(snew(var)); Anonymous_var->type.ident = VAR_VOID_TYPE; ((struct var *)Anonymous_var)->v_name = "_"; (Anonymous_env = snew(pair))->p_body = NULL; MFAIL = Nclause(FAIL,NULL_CL,ETERNAL); Defatom(S_GLOBAL_VAR,"global_var"); Defatom(S_VAR,"var"); Defatom(S_INTEGER,"integer"), Defatom(S_FLOAT,"float"); Defatom(S_STRING,"string"); Defatom(S_FILE_POINTER,"file_pointer"); Defatom(S_PST,"pst"); Defatom(S_PSTOBJ,"pst_proplist"); Defatom(S_CLAUSE,"clause"); Defatom(S_LIST,"list"); Defatom(S_FUNCTOR,"functor"); Defatom(S_ATOM,"atom"); S_GREATER = Nterm(0,ETERNAL); S_GREATER->type.t_func = Nfunc(TYPE1SYS,">",0); S_LESS = Nterm(0,ETERNAL); S_LESS->type.t_func = Nfunc(TYPE1SYS,"<",0); S_EQ = Nterm(0,ETERNAL); S_EQ->type.t_func = Nfunc(TYPE1SYS,"==",0); } void init_operator() { Defatom(XF_P, "xf"); Defatom(YF_P, "yf"); Defatom(FX_P, "fx"); Defatom(FY_P, "fy"); Defatom(XFX_P, "xfx"); Defatom(XFY_P, "xfy"); Defatom(YFX_P, "yfx"); Def1(DEF_P, ":-",2,NULL); Def1(QUERY1_P, ":-",1,NULL); Def1(QUERY2_P, "?-",1,NULL); Def1Red(NOT_P, "not",1,not_pred); Def1(EQSIGN_P, "<=>",2, NULL); Def1Red(EQ2_P, "=",2,equal_pred); Def1Red(MKLIST_P, "=..",2,makelist_pred); Def1(CONSTRAINT_P, ";",2,NULL); Def1(CONSTRAINT2_P, "where",2,NULL); Def1Red(GREATER2_P, ">",2,greater_pred); Def1Red(GEQ2_P,">=",2,geq_pred); Def1Red(LESS2_P,"<",2,less_pred); Def1Red(LEQ2_P,"<=",2,leq_pred); Def1Red(EQUAL2_P,"==",2,eq_pred); /* Def1Red(NEQ_P,"=\=",2,nequal_pred); */ Def1(PNAME_P,"/",2,NULL); /* property/value */ index_op(DEF_P, XFX ,1200); index_op(QUERY1_P, FX , 1200); index_op(QUERY2_P, FX, 1200); index_op(CONSTRAINT_P, YFX, 1200); index_op(CONSTRAINT2_P, YFX, 1200); index_op(EQSIGN_P, XFX, 1200); index_op(NOT_P, FY, 900); index_op(MKLIST_P, XFX, 700); index_op(GREATER2_P, XFX, 700); index_op(GEQ2_P, XFX, 700); index_op(LESS2_P, XFX, 700); index_op(LEQ2_P, XFX, 700); index_op(EQUAL2_P, XFX, 700); index_op(EQ2_P, XFX, 700); /* index_op(NEQ_P, XFX, 700); */ index_op(PNAME_P,XFY, 900); } /* execution of system predicate: (t,e) : goal literal return value : SYSNO :: 't' is not system pred. SYSTRUE :: (t,e) succeed SYSFAIL :: (t,e) fail */ /*-------- initialize components of system predicates ---------- */ struct component *NOT_VACUOUS; void init_froles() { void init_system_component(); MEMORY_ALLOC(NOT_VACUOUS,component,ETERNAL); NOT_VACUOUS->c_label=NOPSTLABEL; NOT_VACUOUS->c_next=(struct component *)NULL; init_system_component(ARG_P,07); init_system_component(APND_P,03); init_system_component(CLAUSE_P,06); init_system_component(CONCAT_P,07); init_system_component(CONCAT2_P,03); init_system_component(COUNT_P,01); init_system_component(EQ2_P,01); init_system_component(FUNCTOR_P,07); init_system_component(GENSYM_P,01); init_system_component(ISOP_P,07); init_system_component(MAKELIST_P,03); init_system_component(MEMB_P,02); init_system_component(MULTIPLY_P,07); init_system_component(NAME_P,03); init_system_component(STRLEN_P,02); /* init_system_component(SUM_P,07); */ init_system_component(PNAMES_P,02); init_system_component(PNAME_P,02); init_system_component(TYPE_P,02); } void init_system_component(f,a) /* initialize system component */ struct func *f; unsigned long a; /* non vacuous bit pattern */ { register int i,arity; for (arity = f->f_arity, i = 0; i < arity; i++, a >>= 1) if ((a & 01) != 0) Component(f,i) = NOT_VACUOUS; } int system_function(t,e,n) /* solve system functional predicate */ struct term *t; struct pair *e; struct node *n; { SYSFUNC comp; struct func *f; f = t->type.t_func; comp = f->def.f_sysfunc; if (comp == NULL) { if (f == FAIL_P) return(SYSFAIL); if (Handle_Undefined == TRUE) { sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name); error(nbuf); } else return(SYSFAIL); } if (isreduced(f)) return((*comp)(t,e)); else return((*comp)(t,e,n)); } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ system_pred() process system predicates ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int system_pred(t,e,n,m,status) /* system (multi valued) predicate */ struct term *t; struct pair *e; struct node *n, *m; int status; /* search status UP,DOWN,BACKTRACK */ { SYSFUNC comp; struct func *f; f = t->type.t_func; comp = f->def.f_sysfunc; if (comp == NULL) { if (Handle_Undefined == TRUE) { sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name); error(nbuf); } else return(SYSFAIL); } if (isreduced(f)) return((*comp)(t,e,n,status)); else return((*comp)(t,e,n,m,status)); } int cut_pred(t,e,n) struct term *t; struct pair *e; struct node *n; { if (n->n_link != NULL) n->n_link->n_set = NULL; /* OR-cut */ n->n_last = n->n_link; Last_BT = n->n_link; return(SYSTRUE); } /* always fail */ /* int fail_pred(t,e) struct term *t; struct pair *e; { return(SYSFAIL); } */ int halt_pred(t,e) struct term *t; struct pair *e; { quit_prolog(); return(SYSTRUE); } int abomb_pred(t,e) struct term *t; struct pair *e; { tprint0("\n Quit cu-prolog !!!!!\n"); exit(1); } int true_pred(t,e,n,status) struct term *t; struct pair *e; struct node *n; int status; { n->n_set = DUMMY_DEF; return(SYSTRUE); } int op_pred(t,e) register struct term *t; register struct pair *e; { struct term *tt; register struct pair *p, *ee; register struct func *f; int prec, otype; tt = Arg1(t); ee = e; down(p,tt,ee); if (! is_int(tt)) error_detail(t,e, "op/3: Illegal Argument --- Precedence should be integer"); prec = num_value(tt); if ((prec < 0) || (prec > 1000)) error_detail(t,e, "op/3: Illegal Argument --- Precedence should be from 0 to 1000"); tt = Arg2(t); ee=e; down(p,tt,ee); if ((p != NULL) || (! is_functor(tt)) || (! isatom(tt))) error_detail(t,e,"op/3: Illegal Argument as type"); f = Pred(tt); if (f == Pred(XF_P)) otype = XF; else if (f == Pred(YF_P)) otype = YF; else if (f == Pred(FX_P)) otype = FX; else if (f == Pred(FY_P)) otype = FY; else if (f == Pred(XFX_P)) otype = XFX; else if (f == Pred(XFY_P)) otype = XFY; else if (f == Pred(YFX_P)) otype = YFX; else error_detail(t,e,"op/3:Illegal Argument as type"); tt = Arg3(t); down(p,tt,e); while (is_list(tt)) { t = head_of_list(tt); down(p,t,e); if ((p != NULL) || (! is_functor(t)) || (! isatom(t))) error_detail(t,e, "op/3: Illegal Argument --- operator should be functor"); index_op(t->type.t_func, otype, prec); tt = tail_of_list(tt); down(p,tt,e); } if (tt != NIL) if (is_functor(tt) && isatom(tt)) index_op(tt->type.t_func, otype, prec); else error_detail(t,e, "op/3: Illegal Argument --- operator should be functor"); return(SYSTRUE); } void index_op(f, type, prec) register struct func *f; int type, prec; { register struct operator *o, *olast; if ((type & INFIX) == INFIX) { /* INFIX operator */ if (f->f_arity != 2) f = Predicate(f->f_name,2); } else if (f->f_arity != 1) f = Predicate(f->f_name,1); for(olast = o = o_list; o!=NULL; olast = o, o=o->o_link) if ((f == o->o_func) && ((type & INFIX) == (o->o_type & INFIX))) { if (prec==0) if (o==o_list) o_list=o->o_link; else olast->o_link=o->o_link; else o->o_prec=prec; break; } if ((o == NULL) && (prec != 0)) { o=snew(operator); o->o_func = f; o->o_prec = prec; o->o_type = type; o->o_link = o_list; o_list = o; } } int isop_pred(t,e,n,status) struct term *t; struct pair *e; struct node *n; int status; { struct operator *o; struct ustack *usave; int *hsave; struct pair *esave; struct term *tt; if (status == BACKTRACK) o = (struct operator *)n->n_set; else o = o_list; usave = usp; hsave = hp; esave = ep; while (o != NULL) { tt = Nterm(0,TEMPORAL); tt->type.t_func = Predicate(o->o_func->f_name,0); if (tunify(Arg3(t),e,tt,NULL_ENV,0) == FALSE) { undo(usave); hp = hsave; ep = esave; o=o->o_link; continue; } tt = Nnum_val((float)o->o_prec,TEMPORAL); if (tunify(Arg1(t),e,tt,NULL_ENV,0) == FALSE) { undo(usave); hp = hsave; ep = esave; o=o->o_link; continue; } switch (o->o_type) { case FX: tt = FX_P; break; case FY: tt = FY_P; break; case XF: tt = XF_P; break; case YF: tt = YF_P; break; case XFX: tt = XFX_P; break; case XFY: tt = XFY_P; break; case YFX: default : tt = YFX_P; } if (tunify(Arg2(t),e,tt,NULL_ENV,0) == FALSE) { undo(usave); hp = hsave; ep = esave; o=o->o_link; continue; } n->n_set = (struct set *)o->o_link; return(SYSTRUE); } return(SYSFAIL); } int not_pred(t,e) struct term *t; struct pair *e; { struct node *goal,*lbsave,*lssave; int *hsave = hp; struct pair *esave; struct ustack *usave = usp; struct term *tt = Arg1(t); int refute(); lbsave = Last_BT; /* 95.1.27 by Seki-san */ lssave = Last_SKIP; esave = ep; if (is_clause(tt)) goal = Newnode((struct clause *)tt,NULL_ECL, e,NULL_NODE,NULL_NODE); else if (is_functor(tt)) goal = Newnode(Nclause(tt,NULL_CL,TEMPORAL), NULL_ECL, e,NULL_NODE, NULL_NODE); else error_detail(t,e,"not/1: Illegal Argument"); if (refute(goal,goal,DOWN)==FALSE) { Last_BT=lbsave; Last_SKIP = lssave; return(SYSTRUE); } /* else */ undo(usave); hp = hsave; ep = esave; Last_BT=lbsave; Last_SKIP = lssave; return(SYSFAIL); } int unbreak_pred(t,e) struct term *t; struct pair *e; { longjmp(unbreak_reset,1); } /* pnames({a/1,b/2,c/X}, Y) -> Y=[a,b,c]) */ int pnames_pred(t,e) struct term *t; struct pair *e; { register struct term *ps; register struct eclause *pl; struct pst_item *target; struct pair *pp, *ee; struct term *ls = NIL; ps = Arg1(t); ee = e; down(pp, ps, ee); if (! is_pst(ps)) error_detail(t,e,"pnames/2: 1st arg is not PST"); target = find_pstitem(ps,ee); if (target != NULL_PSTIT) pl = target->p_lists; else pl = ((struct pst *)ps)->p_lists; while (pl != NULL_ECL) { ls = (struct term *)Nlist(Arg1(pl->c_form), (struct clause *)ls,TEMPORAL); pl = pl->c_link; } return(equalpred(Arg2(t),e,ls,NULL_ENV)); } /* pvalue({a/1,b/2,c/x},b,Z) -> Z=2 */ int pvalue_pred(t,e) struct term *t; struct pair *e; { register struct term *ps; register struct pair *pp; register struct eclause *pl; struct term *pn; struct pair *ee, *etemp; struct pst_item *target; int f,i; ps = Arg1(t); pn = Arg2(t); ee = e; down(pp, ps, ee); if (! is_pst(ps)) error_detail(t,e,"pvalue/3: 1st arg is not PST"); etemp = e; down(pp, pn, etemp); if ((! is_functor(pn))|| (pn->t_arity != 0)) error_detail(t,e,"pvalue/3: 2nd arg is not ATOM"); f = Pred(pn)->f_number; target = find_pstitem(ps,ee); if (target != NULL_PSTIT) { pl = target->p_lists; while(pl != NULL_ECL) { i = Pred(Arg1(pl->c_form))->f_number - f; if (i==0) return(equalpred(Arg3(t),e, Arg2(pl->c_form),pl->c_env)); if (i > 0) return(SYSFAIL); pl = pl->c_link; } } else { pl = ((struct pst *)ps)->p_lists; while (pl != NULL_ECL) { i = Pred(Arg1(pl->c_form))->f_number - f; if (i==0) return(equalpred(Arg3(t),e,Arg2(pl->c_form),ee)); if (i > 0) return(SYSFAIL); pl = pl->c_link; } } return(SYSFAIL); } int default_pred(t,e) struct term *t; struct pair *e; { struct term *ps, *templ, *dfs; struct pair *p, *ee, *et, *ed; static char *emessage = "default/3: %s arg is not PST"; ps = Arg(t,0); templ = Arg(t,1); dfs = Arg(t,2); et = ed = ee = e; down(p,templ,et); if (! is_pst(templ)) { sprintf(nbuf,emessage,"2nd"); error_detail(t,e, nbuf); } down(p,dfs,ed); if (! is_pst(dfs)) { sprintf(nbuf,emessage,"3rd"); error_detail(t,e,nbuf); } down(p,ps,ee); if (! is_pst(ps)) { sprintf(nbuf,emessage,"1st"); error_detail(t,e,nbuf); } if (subsume(ps, ee, templ, et, FALSE)==FALSE) return(SYSFAIL); pst_add_unify(ps,ee,dfs,ed); return(SYSTRUE); } int subsume(t, e, u, f, flag) register struct term *t, *u; register struct pair *e, *f; int flag; /* TRUE if Var subsumes everything, otherwise FALSE */ { register struct pair *p, *q; int i, j; down(p, t, e); down(q, u, f); if(p != NULL) if ((q != NULL) || (flag == TRUE)) return(TRUE); else return(FALSE); if (q != NULL) return(FALSE); switch (u->type.ident) { case ATOMIC_TYPE: /* t,u: atomic (string,num,quote) */ if ((t==u) || (atomic_equal(u,t))) return(TRUE); else return(TRUE); case LIST_TYPE: case CONST_LIST_TYPE: if (is_list(t)) if (subsume(head_of_list(t),e,head_of_list(u),f,flag)==TRUE) return(subsume(tail_of_list(t),e,tail_of_list(u),f,flag)); return(FALSE); case CLAUSE_TYPE: if (is_clause(t)) { while ((t != NULL) && (u != NULL)) { if (subsume(((struct clause *)t)->c_form,e, ((struct clause *)u)->c_form,f,flag) == FALSE) return(FALSE); t=(struct term *)((struct clause *)t)->c_link; u=(struct term *)((struct clause *)u)->c_link; } if (t == u) return(TRUE); } return(FALSE); case PST_TYPE: if (is_pst(t)) return(subsume_pst(t,e,u,f,flag)); return(FALSE); default : /* functor */ if(Pred(t) == Pred(u)) {/* t,u: complex term */ for(i = 0, j = Pred(t)->f_arity; i < j; i++) { if (subsume(Arg(t,i), e, Arg(u,i), f,flag) == FALSE) return(FALSE); } return(TRUE); } return(FALSE); } } int subsume_pst(t,e,u,f,flag) register struct term *t,*u; register struct pair *e,*f; int flag; { struct pst_item *target, *object; target = find_pstitem(t,e); if (target == NULL_PSTIT) target = record_pstobjects((struct pst *)t,e); object = remove_pstitem(u,f); if (object != NULL_PSTIT) return(subsume_pstlist(target->p_lists,object->p_lists, NULL_ENV,flag)); return(subsume_pstlist(target->p_lists,((struct pst *)u)->p_lists, f,flag)); } int subsume_pstlist(x,y,e,flag) struct eclause *x,*y; struct pair *e; int flag; { int i,fnum; while (y != NULL_ECL) { fnum = Pred(Arg1(y->c_form))->f_number; while (x->c_link != NULL_ECL) { i = Pred(Arg1(x->c_form))->f_number - fnum; if (i == 0) { if (e != NULL_ENV) { if (subsume(x->c_form,x->c_env,y->c_form,e,flag)==FALSE) return(FALSE); } else { if (subsume(x->c_form,x->c_env,y->c_form,y->c_env,flag)==FALSE) return(FALSE); } break; } else if (i > 0) return(FALSE); x = x->c_link; } y = y->c_link; x = x->c_link; } return(TRUE); } void pst_add_unify(t,e,u,f) register struct term *t,*u; register struct pair *e,*f; { struct pst_item *target, *object; target = find_pstitem(t,e); if (target == NULL_PSTIT) target = record_pstobjects((struct pst *)t,e); object = remove_pstitem(u,f); if (object != NULL_PSTIT) pst_add_unify_sub(target,object->p_lists,NULL_ENV); else pst_add_unify_sub(target,((struct pst *)u)->p_lists, f); } void pst_add_unify_sub(entry, ol, e) struct pst_item *entry; struct eclause *ol; struct pair *e; { int i, fnum; struct eclause *pl; if (ol==NULL_ECL) return; pl=entry->p_lists; if (pl == NULL_ECL) { upush(&(entry->p_lists)); entry->p_lists=record_pstlists(ol,e); return; } i = Pred(Arg1(pl->c_form))->f_number - Pred(Arg1(ol->c_form))->f_number; if (i == 0) ol = ol->c_link; else if (i > 0) { upush(&(entry->p_lists)); entry->p_lists = Npstobj(ol->c_form,e,pl,MEDIUM); ol = ol->c_link; pl=entry->p_lists; } while (ol != NULL_ECL) { fnum = Pred(Arg1(ol->c_form))->f_number; while (pl->c_link != NULL_ECL) { i = Pred(Arg1(pl->c_link->c_form))->f_number - fnum; if (i == 0) break; else if (i > 0) { upush(&(pl->c_link)); pl->c_link = Npstobj(ol->c_form,e,pl->c_link,MEDIUM); break; } pl = pl->c_link; } if (pl->c_link == NULL_ECL) { upush(&(pl->c_link)); pl->c_link = record_pstlists(ol,e); break; } else pl=pl->c_link; ol = ol->c_link; } } int type_pred(t,e) struct term *t; struct pair *e; { struct term *tt,*type; struct pair *p, *et = e; tt = Arg(t,0); down(p,tt,et); switch(tt->type.ident) { case VAR_VOID_TYPE: case VAR_PST_TYPE: case VAR_GLOBAL_TYPE: return(equalpred(Arg(t,1),e,S_VAR,NULL_ENV)); case ATOMIC_TYPE: switch(tt->t_arity) { case FLOAT_NUM: return(equalpred(Arg(t,1),e,S_FLOAT,NULL_ENV)); case INT_NUM: return(equalpred(Arg(t,1),e,S_INTEGER,NULL_ENV)); case STRING: return(equalpred(Arg(t,1),e,S_STRING,NULL_ENV)); default: return(equalpred(Arg(t,1),e,S_FILE_POINTER,NULL_ENV)); } case PST_TYPE: return(equalpred(Arg(t,1),e,S_PST,NULL_ENV)); case ECLAUSE_TYPE: return(equalpred(Arg(t,1),e,S_PSTOBJ,NULL_ENV)); case CLAUSE_TYPE: return(equalpred(Arg(t,1),e,S_CLAUSE,NULL_ENV)); case LIST_TYPE: case CONST_LIST_TYPE: return(equalpred(Arg(t,1),e,S_LIST,NULL_ENV)); default : if (t->t_arity == 0) return(equalpred(Arg(t,1),e,S_ATOM,NULL_ENV)); return(equalpred(Arg(t,1),e,S_FUNCTOR,NULL_ENV)); } } int reset_timer_pred(t,e) struct term *t; struct pair *e; { #if SUN4 == 1 OLD_TIME = clock(); #else #if CPUTIME == 0 OLD_TIME = 0L; #else struct tms TIMES; /* cf. times() */ times(&TIMES); OLD_TIME = TIMES.tms_stime + TIMES.tms_utime; #endif #endif CONSTRAINT_HANDLING_TIME = 0L; return(SYSTRUE); } int timer_pred(t,e) struct term *t; struct pair *e; { #if CPUTIME != 0 struct tms TIMES; #endif static char *emsg = "timer*/2: %s is not VAR"; register struct pair *p1, *p2, *ee; struct term *t1, *t2; ee = e; t1 = Arg1(t); down(p1,t1,ee); if (p1 == NULL) { sprintf(nbuf,emsg,"1st"); error_detail(t,e,nbuf); } ee = e; t2 = Arg2(t); down(p2,t2,ee); if (p2 == NULL) { sprintf(nbuf,emsg,"2nd"); error_detail(t,e,nbuf); } #if SUN4 == 1 t1 = Nnum_val(((float)((clock())-OLD_TIME))/1000000.0,TEMPORAL); t2 = Nnum_val(((float)CONSTRAINT_HANDLING_TIME)/1000000.0,TEMPORAL); #else #if CPUTIME == 0 t1 = t2 = Nnum_val(0.0,TEMPORAL); #else times(&TIMES); t1 = Nnum_val(((float)(TIMES.tms_stime+TIMES.tms_utime-OLD_TIME))/CPUTIME.0, TEMPORAL); t2 = Nnum_val(((float)CONSTRAINT_HANDLING_TIME)/CPUTIME.0,TEMPORAL); #endif #endif upush(&(p1->p_body)); upush(&(p1->p_env)); upush(&(p2->p_body)); upush(&(p2->p_env)); p1->p_body = t1; p1->p_env = NULL_ENV; p2->p_body = t2; p2->p_env = NULL_ENV; return(SYSTRUE); } int stay_pred(t,e) register struct term *t; register struct pair *e; { struct term *t1, *tt; register struct pair *p, *ee; register struct func *f; int prec, otype; t1 = Arg1(t); ee = e; down(p,t1,ee); if ((p != NULL) || (! is_functor(t1)) || (! isatom(t1))) error_detail(t,e,"stayflag/3: Illegal Argument as functor"); tt = Arg2(t); ee = e; down(p,tt,ee); if (! is_int(tt)) error_detail(t,e, "stayflag/3: Illegal Argument as Arity"); f = funcsearch(Pred(t1)->f_name,(int)num_value(tt)); if (f == NULL) error_detail(t,e,"stayflag/3: No such a predicate"); tt = Arg3(t); ee = e; down(p,tt,ee); if (p != NULL) { /* 2nd arg is a variable */ if (((f->f_mark) & NON_UNFOLDABLE) != 0) { if (((f->f_mark) & STAY_IF) == 0) { /* stay if false */ t1 = Nterm(0,TEMPORAL); Pred(t1) = FAIL_P; return(equalpred(tt,ee,t1,NULL_ENV)); } else { /* stay if true */ t1 = Nterm(0,TEMPORAL); Pred(t1) = TRUE_P; return(equalpred(tt,ee,t1,NULL_ENV)); } } return(SYSFAIL); } if (Pred(tt) == TRUE_P) f->f_mark |= STAY_IF_TRUE_PRED; else if (Pred(tt) == FAIL_P) f->f_mark |= STAY_IF_FALSE_PRED; else error_detail(t,e,"stayflag/3: Illegal Argument as TRUE/FAIL"); return(SYSTRUE); } error_detail(t,e, nbuf); } down(p,dfs,ed); if (! is_pst(dfs)) { sprintf(nbuf,emessage,"3rd"); error_detail(t,e,nbuf); } down(p,ps,ee); if (! is_pst(ps)) { sprintf(nbuf,emessage,"1st"); error_detail(t,e,nbuf); } if (subsume(ps, ee, templ, et, FALSE)==FALSE) return(SYSFAIL); pst_add_unify(ps,ee,dfs,ed); return(SYSTRUE); } int subsume(t, e, u, f, flag) register struct term *t, *u; register struct pairsrc/funclist.h 644 10266 36 17401 5712121410 6760 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<< funclist.h >>> * external function definitions --------------------------------------------------------------------*/ /* extern function def */ /* main.c */ void prepare(),error_detail(), error(),systemcommand(); void oscommand(),set_inputfile(),readfile(),set_eof(),trans_routine(); void questionclause(),defclause(),push_status(),pop_status(),init_status(); void garbagecollect(),edit_predicate(); void open_title(), prolog_execution(); void defnewfunc(), rename_var_names(), truncate_varname(); void renum_pvars(), preprocess_constraints(); /* mainsub.c */ void traceswitch(),stepswitch(),spyswitch(),showdef(),loghandle(); void check_recursion(); void recalc_f_roles(); int not_vacuous(); void reduceswitch(),putcursor(),disp_func_def(); void allspy(),helpmenu(),filewrite(); void freeheap(); void printtime(),settimer(),quit_prolog(); void delete_tmp(); /* defsysp.c */ void init_syspred(); void init_atoms(); void init_operator(); void defsyspred(); int system_function(); int cut_pred(); int fail_pred(); int halt_pred(); int abomb_pred(); int true_pred(); int op_pred(); int isop_pred(); void index_op(); int not_pred(); int unbreak_pred(); int pnames_pred(), pvalue_pred(), type_pred(); int default_pred(), subsume(), subsume_pst(); int subsume_pstlist(); void pst_add_unify(), pst_add_unify_sub(); int reset_timer_pred(), timer_pred(); int stay_pred(); /* syspred1.c */ int memb_pred(); int apnd_pred(); int execute_pred(); int or_pred(); int read_pred(); int open_pred(); int see_pred(); int seen_pred(); int tell_pred(); int told_pred(); int close_pred(); int project_pred(); int pcon_pred(); int attach_pred(); int cunify_pred(); int write_pred(); int nl_pred(); int tab_pred(); int var_pred(); int equal_pred(); int nequal_pred(); int eq_pred(); int eq_pred_sub(); int equalpred(); int assertz_pred(); int assert_pred(); void general_assert(); struct clause *list_to_clause(); int retract_pred(); int retract_pred_sub(); void clear_predicate(); int abolish_pred(); int makelist_pred(); int Llevel(); void LtoP(); struct clause *PtoL(); int name_pred(); void LtoC(); struct term *CtoL(); int arg_pred(); int functor_pred(); int make_func(); int match_func(); int clause_pred(); struct term *Clause_to_List(); /* syspred2.c */ int sum_pred(); int multiply_pred(); int calc_pred(); int calc_1(); int calc_2(); int greater_pred(); int less_pred(); int geq_pred(); int leq_pred(); int numcomp_pred(); int compare_pred(); int concat_pred(); int app_str(); int diff_str(); int concat2_pred(); int divstr_pred(); int strlen_pred(); int strcmp_pred(); int atom_to_str_pred(); int count_pred(); int gensym_pred(); int default_pred(); int substr_pred(); /* jpsgsub.c */ void show_category(); void init_category(); void list_to_cat(); void set_category(); int tree_pred(); void Ptree(); void oldlink(); void treeprint(); int null_or_nil(); void PCat(); void Psubcat(); char *termname(); int pickname(); struct term *cnlistmake(); int cname_pred(); /* new.c */ int *salloc(),*alloc(); struct pair *ealloc(); char *nalloc(); int hash(); void print_hash_table(); /* name flag for nalloc() */ char *nalloc(); void index_func(), index_funclist(); struct itrace *index_newflist(); void reset_voccurrence(),recalc_voccurrence(); void recalc_pred_value(); struct operator *op_search(); struct term *Nvar(),*Nterm(); struct term *Nnum(), *Nnum_val(), *Nstr(), *Nfile(); struct pst *Npst(); struct term *Npst_item(); void initialize_psttable(), clear_psttable(); struct pst_item *find_pstitem(); struct pst_item *remove_pstitem(),*remove_pstitem_if_not_equal(), *record_pstobjects(); struct eclause *record_pstlists(); struct clause *Nlist(), *Nclause(); struct func *Nfunc(),*funcsearch(); struct func *Predicate(),*exist_fname(); struct term *varsearch(); struct pair *Nenv(); struct node *Nnode(); struct cnode *Ncnode(); struct eclause *Neclause(); struct allvar *Nallvars(); void check_pred_defcount(); void upush(),undo(),add_set(),index_set(); struct term *literalcopy(); void show_heap_max(),init_heap_max(); /* print.c */ void Pterm(),Pterm_core(),Psequence(),Pallvar(),Pvar(), Pfunctor(); void writenewfunc(), Ppst(); void Pclause(),P_var(), P_dclause(); void Showhorn(),Showfunc(),Shownewfunc(); void Pgoal(); int quote_needed(); void Peclause(); /* read.c */ void adv(); int check(), skip(), keyread(), alldigit(); void period(), next(), read_hexa(), read_digits(); void read_comments(), read_spechar(); int Rtoken(), is_term_end(), prefix_is_atom(); struct term *Rlist(),*Rterm(), *Rterm_half(), *Rterm_leftover(); struct term *Rform(),*Rhead(); struct clause *Rclause(); struct clause *Rconstraint(); struct term *Rliteral(), *Rvar(), *Rpst(); void register_psttable(); struct eclause *insert_pstobj(); /* modular.c */ void modular(); int cu(); struct term *tolist(),*termset(), *up_pst(); struct eclause *termset_pstobj(), *termset_pstobj_sub(); void up_init(); void up_restore(); struct clause *up_eclause(); struct clause *up_list_to_clause(); struct clause *up_itrace_clause(); struct set *up_func_def(); struct eclause *onestep_reduce(), *eclause_append(); struct term *up_atomic(), *up_const(), *up_const_functor(); struct term *try_fold(); struct eclause *transform(); int match_term(); /* refute.c */ int refute(); struct node *Newnode(); struct node *backtrack_node(); struct set *init_set(); int Panswer(); /* unify.c */ int tunify(); int ocheck(),unify(),safe_unify(); int pst_unify(); int unify_pstlist_objects(), unify_merge_psts(); /* transform.c */ int check_INITDEF(); void clear_up_DEF(); void add_to_set(); struct clause *startmodular(); struct clause *modular_form(); struct compartment *Ncomp(); struct clause *copy_clause(); struct term *copy_term(); struct term *var_trans(); struct clause *new_constraint(); struct clause *new_pred_def(); void set_new_def(); int need_trans(); /* struct clause *restore_head(); */ struct term *restore_term(); struct term *var_reverse(); struct cset *target_clause(); struct cset *target_def(); void delete_csets(); int foldunfold(); int unfold(); int apply(); struct set *one_def_literal(); void register_newpred(); void Pvpair(); void Pcomp(); int stat(); void Pcset_def(); void Pcset_cstr(); void P_csnumber(); void P_status(); struct vpair *Nvpair(); struct cset *Ncset(); void add_clause(); void add_cs_to_set(); struct eclause *reduce_clause(); void reorder_clause(); int satisfiable(); struct clause *target_literal(); int energy(); struct clause *surface_copy_clause(); struct clause *ctail(); struct eclause *ectail(); int has_pred(); int is_vacuous(); int is_modular_clause(); int is_modular_literal(); int has_no_var(); /* struct clause *Nhornclause(); */ struct eclause *eclause_conc(); struct clause *sort_clause(); struct clause *insert_clause(); int greater_term(); int arg_type(); int greater_arg(); int cmp_var(); int cmp_cplxt(); int cmp_list(); int cmp_flt(); int cmp_int(); int cmp_str(); int cmp_fp(); int have_def(); void init_unfoldfold(); void end_unfoldfold(); int step_asking(); struct cset *nth_cset(); struct clause *nth_literal(); void abandon_transformation(); void quit_transformation(); void skip_cr(); void show_newdefs(); struct compartment *split(); void clear_vconstraint(); void delete_constraint(); int attach(); void attach_term(); void attach_arg(); void replace_terms(); ); void init_category(); void list_to_cat(); void set_category(); int tree_pred(); void Ptree(); void oldlink(); void treeprint(); int null_or_nil(); void PCat(); void Psubcat(); char *termname(); int pickname(); struct term *cnlistmake(); int cname_pred(src/globalv.h 644 10266 36 6616 5712121410 6545 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << globalv.h >> * global variable external reference * 93.7.30 heap, stack * 94.8.10 unsigned char for Kanji --------------------------------------------------------------------*/ extern long CONSTRAINT_HANDLING_TIME; extern FILE *fp,*wfp,*lfp; /* read file pointer, write fp, log fp */ extern int tty; extern int cbuf; /* character buffer */ extern struct ustack *utop; /* save user stack pointer */ extern int ECHO_BACK; extern int Handle_Undefined; /* handling undefined predicates */ extern int Print_Depth; /* maximum depth of printing */ extern int tflag; /* trace flag 0-> off, 1-> on 2->step trace on */ extern int sflag; /* solution mode flag 1->all solutions, 0->one solution */ extern int CTmode; /* trace mode 0,1,2 */ extern int refute_node_count; /* refute counter using in c.t. */ extern int char_type[128]; extern unsigned char nbuf[]; /* name buffer */ extern int tokentype, reread; extern char genname[8]; /* generated function name */ extern char logfile[32]; /* log file name */ extern char Anonymous_VarName[4]; extern int GENSYM; extern int v_number, p_number; /* temporary var number */ extern struct term *v_list, *pv_list; /* temporary var list */ extern struct func *f_list; /* new function list entry */ extern struct operator *o_list; extern struct node *n_last; /* node list */ extern struct itrace *newf_list; /* new function definition */ extern struct pst_item *psttable; extern int FNUMBER; /* function number seed */ extern int Def_Modified; /* def modified flag */ extern int Refcount; /* maximum of refute counter */ extern int MODULARMAX; /* maximum number of Variables in Trans */ /* system predicates in cu-prolog */ struct func *LIST,*CUNIFY; struct term *NIL, *FAIL, *END_OF_FILE; struct term *Anonymous_var; struct pair *Anonymous_env; struct clause *MFAIL; struct term *XF_P, *YF_P, *FX_P, *FY_P, *XFX_P, *XFY_P, *YFX_P; struct term *S_GLOBAL_VAR, *S_VAR, *S_INTEGER, *S_FLOAT; struct term *S_STRING, *S_FILE_POINTER, *S_PST, *S_CLAUSE; struct term *S_LIST, *S_FUNCTOR, *S_ATOM, *S_PSTOBJ; struct term *S_EQ, *S_GREATER, *S_LESS; extern struct node *Last_BT, *Last_SKIP; /* default heap size */ extern int HEAP_SIZE,SHEAP_SIZE,ESP_SIZE,CHEAP_SIZE,USTACK_SIZE,NAME_SIZE; /* heap/stack pointers */ extern int *sheap, *shp, *SHEAPTOP; /* system heap */ extern int *heap, *hp, *Heap_Max, *HEAPTOP; /* local heap */ extern int *cheap, *chp, *Cheap_Max, *CHEAPTOP; /* constrains heap */ extern struct pair *eheap, *ep, *Esp_Max, *ESPTOP; extern struct ustack *ustack, *usp, *Stack_Max, *STACKTOP; extern char *nheap, *nhp, *NHEAPTOP; #include extern jmp_buf reset; extern jmp_buf unbreak_reset; /* trace --- unbreak */ /* for statistics */ extern int STAT_BACKTRACK_DEEP, STAT_BACKTRACK_SHAL, STAT_REFUTE; extern int STAT_UNFOLD, STAT_FOLD, STAT_DEF; r_nil(); void PCat(); void Psubcat(); char *termname(); int pickname(); struct term *cnlistmake(); int cname_pred(src/include.h 644 10266 36 44413 5712121410 6557 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * header files: include.h, funclist.h, varset.h, globalv.h, sysp.h, * syspdef.h * Prolog: main.c, mainsub.c, new.c, read.c, print.c, refute.c, unify.c * System predicates: defsysp.c, syspred1.c, syspred2.c, jpsgsub.c * Constraint: modular.c, trans.c, tr_sub.c, tr_split.c ==================================================================== */ /*-------------------------------------------------------------------- * << include.h >> * (define structures, macros, etc) * * 91.12 cu-Prolog III release * 92.7 refine for ICOT Free Software release * 93.7.30 --------------------------------------------------------------------*/ #include #include /* CPUTIME : print CPU time for UNIX 4.2 BSD * if your system has times() function #define CPUTIME 60 * if your system is SUN4 #define SUN4 1 * else #define CPUTIME 0 */ #define SUN4 1 #define KANJI 1 /* 1: allow EUC Kanji for str functions */ /* Tee print macro */ #define tputc(X) {if (wfp) putc(X,wfp);if (lfp) putc(X,lfp);} #define tprint0(X) {if (wfp) fprintf(wfp,X);if (lfp) fprintf(lfp,X);} #define tprint1(X,V) {if (wfp) fprintf(wfp,X,V);if (lfp) fprintf(lfp,X,V);} #define tprint2(X,V1,V2) {if (wfp) fprintf(wfp,X,V1,V2);\ if (lfp) fprintf(lfp,X,V1,V2);} #define tprint3(X,V1,V2,V3) {if (wfp) fprintf(wfp,X,V1,V2,V3);\ if (lfp) fprintf(lfp,X,V1,V2,V3);} #define tprint4(X,V1,V2,V3,V4) {if (wfp) fprintf(wfp,X,V1,V2,V3,V4);\ if (lfp) fprintf(lfp,X,V1,V2,V3,V4);} #define NL tputc('\n') #define readword(S) fscanf(fp,"%s",S);if (lfp) fprintf(lfp,"%s",S); #define skipline while (cbuf != '\n') next() #define KEYIN (fp == stdin) #define advance (next(), adv()) /* string equal */ #define streq(p,q) (*(p) == *(q) && strcmp(p,q) == 0) /* type of token */ #define NAME 0 #define NUMBER 1 #define STRING 2 #define FILE_TYPE 3 #define VARNAME 4 #define BRACKET 5 /* ()[]| */ #define COMMA 6 /* , */ #define FULLSTOP 7 /* . */ #define CONST_MARK 8 /* ; */ /* VT-100 Escape Sequence */ #define C_HIGHLIGHT "\033[01m" #define C_UNDER "\033[04m" #define C_BLINK "\033[05m" #define C_REVERSE "\033[07m" #define C_NORMAL "\033[0m" #define C_SAVE "\033[s" #define C_LOAD "\033[u" #define C_CLS "\033[2J" /* storage type */ #define TEMPORAL 0 #define MEDIUM 1 #define ETERNAL 2 #define STINGY 3 /* flag for checking constant term used in Rterm and termset */ #define CONSTANT_TERM 1 #define NOT_CONSTANT_TERM 0 /* discrimination of term */ #define VAR_VOID_TYPE 1 #define VAR_PST_TYPE 2 #define VAR_GLOBAL_TYPE 3 #define ATOMIC_TYPE 4 #define PST_TYPE 5 #define PST_ITEM_TYPE 6 #define CLAUSE_TYPE 7 #define ECLAUSE_TYPE 8 #define LIST_TYPE 9 #define CONST_LIST_TYPE 10 struct term { /* atomic formula (literal) */ union { int ident; /* descriminated accordint to this */ struct func *t_func; /* functor(predicate) name */ } type; int t_arity; /* arity. when < 0 complex const */ union { struct term *t_arg[1]; /* args */ float n_value; char *s_value; FILE *f_value; } tag; }; #define NULL_TERM (struct term *)NULL #define FLOAT_NUM 0 #define INT_NUM 1 /* #define STRING 2 */ #define FILE_POINTER 3 /* num,string,file */ #define is_atomic(Term) (Term->type.ident == ATOMIC_TYPE) #define is_num(Term) (is_atomic(Term) && (Term->t_arity <= INT_NUM)) #define is_string(Term) (is_atomic(Term) && (Term->t_arity == STRING)) #define EUCOS 0x80 /* EUC offset */ #define is_int(Term) (is_atomic(Term) && (Term->t_arity == INT_NUM)) #define is_file(Term) (is_atomic(Term) && (Term->t_arity == FILE_POINTER)) #define is_pst(Term) ((Term)->type.ident == PST_TYPE) #define is_pstitem(Term) ((Term)->type.ident == PST_ITEM_TYPE) #define is_list(Term) (((Term)->type.ident == LIST_TYPE) ||\ ((Term)->type.ident == CONST_LIST_TYPE)) #define is_clause(Term) ((Term)->type.ident == CLAUSE_TYPE) #define is_eclause(Term) ((Term)->type.ident == ECLAUSE_TYPE) #define num_value(Term) ((Term)->tag.n_value) #define str_value(Term) ((Term)->tag.s_value) #define filep_value(Term) ((Term)->tag.f_value) #define head_of_list(Term) (((struct clause *)Term)->c_form) #define tail_of_list(Term) ((struct term *)((struct clause *)Term)->c_link) #define is_readable(FP) (FP->_flag & _IOREAD) #define is_writable(FP) (FP->_flag & _IOWRT) #define is_functor(Term) ((Term)->type.ident > CONST_LIST_TYPE) #define isconst_functor(Term) ((Term)->t_arity <= 0) #define isconst(Term) (is_atomic(Term) || \ (is_functor(Term) && (isconst_functor(Term)))) #define notconst(Term) (isvar(Term) || is_pst(Term) ||\ ((! is_atomic(Term)) && (Term->t_arity > 0))) #define isatom(Term) (is_atomic(Term) || (Term->t_arity == 0)) #define Arg(T,N) (T)->tag.t_arg[N] /* N+1 th argument of term T */ #define Arg1(T) Arg(T,0) #define Arg2(T) Arg(T,1) #define Arg3(T) Arg(T,2) #define Arg4(T) Arg(T,3) #define Arg5(T) Arg(T,4) #define Pred(T) (T)->type.t_func /* predicate symbol */ #define Predname(T) (T)->type.t_func->f_name /* predicate symbol name */ #ifndef FLT_EPSILON /* ==2^-23 */ /* #define FLT_EPSILON 1.19209290E-07 */ #define FLT_EPSILON 2E-07 #endif #define atomic_equal(u,t) \ (is_atomic(t) && (t->t_arity == u->t_arity) &&\ ( (is_int(t) && ((int)num_value(t) == (int)num_value(u))) || \ (is_num(t) && \ ((float)fabs(num_value(t)-num_value(u)) \ <= FLT_EPSILON*fabs(num_value(t)))) ||\ (is_string(t) && (strcmp(str_value(t),str_value(u)) == 0)) ||\ (is_file(t) && (filep_value(t) == filep_value(u))))) struct var { int v_type; /* v_type = VAR_TYPE */ int v_number; char *v_name; struct var *v_link; struct clause *v_constraint; /* constraint of CAHC */ struct component *v_component; /* used in the component check */ short int v_head_occur; /* var occurrence in head */ short int v_occurrence; /* var occurrence */ }; #define isvar(t) ( ((struct var *)t)->v_type <= VAR_GLOBAL_TYPE \ && ((struct var *)t)->v_type >= VAR_VOID_TYPE ) #define novar(Term) (is_atomic(Term) ||\ (Term->type.ident == CONST_LIST_TYPE) ||\ ((! isvar(Term)) && (Term->t_arity <= 0))) #define is_voidvar(t) (((struct var *)t)->v_type == VAR_VOID_TYPE) #define is_notvoidvar(t) (((struct var *)t)->v_type == VAR_GLOBAL_TYPE ||\ ((struct var *)t)->v_type == VAR_PST_TYPE) #define vname(t) (((struct var *)t)->v_name) #define vnumber(t) (((struct var *)t)->v_number) #define voccurrence(t) (((struct var *)t)->v_occurrence) #define vheadoccurrence(t) (((struct var *)t)->v_head_occur) #define vincrement(t) ((struct var *)t)->v_occurrence++ #define vdecrement(t) ((struct var *)t)->v_occurrence-- #define vconstraint(t) (((struct var *)t)->v_constraint) #define vcomponent(t) (((struct var *)t)->v_component) #define vlink(t) ((struct term *)(((struct var *)t)->v_link)) typedef int (*SYSFUNC)(); /* for system predicate */ struct component /* component of arguments */ { struct func *c_label; struct component *c_next; }; #define Component(F,N) (F)->f_component[N] /* N+1 th argument of func F */ #define NOPSTLABEL (struct func *)NULL /* label of non-PST term */ struct func { /* predicate (functor) */ unsigned short int f_arity, f_number, f_mark; unsigned short int f_setcount; /* number of definitions */ char *f_name; union { struct set *f_set; /* definition clauses */ SYSFUNC f_sysfunc; /* system function */ } def; struct func *f_link; struct itrace *f_integ; /* integrate() history */ int f_unitcount; /* number of unit defs */ struct component *f_component[1]; /* component of arguments */ }; /* predicate(functor) type definition */ #define USERFUN 0 /* user function, default value */ #define SYSFUN 1 /* system pred */ #define SPYFUN 2 /* spy fun. or not */ #define REDUCEDFUN 4 /* reduced fun. or not */ #define FINITEFUN 8 /* finete fun. or not */ #define TEMPFUN 16 /* temporary func */ #define NEWPRED 32 /* new predicate */ #define NONFUNC 64 /* non-functional (many solutions) */ #define TYPE1SYS 9 /* system (functional) pred */ #define TYPE1SYS_REDUCED 13 /* reduced # of arguments system pred */ #define TYPE2SYS 65 /* system (non-functional) pred */ #define TYPE2SYS_REDUCED 69 /* reduced # of arguments system non-functional */ #define NON_UNFOLDABLE 128 /* non unfoldable pred at the unfold/fold */ #define STAY_IF 256 /* stay if TRUE/FALSE for NON_UNFOLDABLE pred */ #define STAY_IF_TRUE_PRED 384 #define STAY_IF_FALSE_PRED 128 #define VACUITY_NOCHECK 512 /* vacuity non check flag */ #define COMPONENT_CHECKED 1024 /* component checked */ /* #define systemfun(F) (F->f_mark) != SYSFUN #define userfun(F) (F->f_mark) &= (^SYSFUN) */ #define issystem(F) ( ((F->f_mark) & SYSFUN) != 0 ) #define isuser(F) ( ((F->f_mark) & SYSFUN) == 0 ) #define isnonfunc(F) ( ((F->f_mark) & NONFUNC) != 0 ) #define isfunc(F) ( ((F->f_mark) & NONFUNC) == 0 ) #define is_funcsys(F) (issystem(F) && isfunc(F)) #define is_nofuncsys(F) (issystem(F) && isnonfunc(F)) #define spyfun(F) (F->f_mark) |= SPYFUN #define nospyfun(F) (F->f_mark) &= (~SPYFUN) #define spychange(F) (F->f_mark) ^= SPYFUN #define isspy(F) ( ((F->f_mark) & SPYFUN) != 0 ) #define isnospy(F) ( ((F->f_mark) & SPYFUN) == 0 ) #define reducedfun(F) (F->f_mark) |= REDUCEDFUN #define isreduced(F) ( ((F->f_mark) & REDUCEDFUN) != 0) #define isnoreduced(F) ( ((F->f_mark) & REDUCEDFUN) == 0) #define finitefun(F) (F->f_mark) |= FINITEFUN #define recursivefun(F) (F->f_mark) &= (~FINITEFUN) #define isfinite(F) ( ((F->f_mark) & FINITEFUN) != 0) #define isrecursive(F) ( ((F->f_mark) & FINITEFUN) == 0) #define newpred(F) (F->f_mark) |= NEWPRED #define isnewpred(F) ( ((F->f_mark) & NEWPRED) != 0) #define isnotnewpred(F) ( ((F->f_mark) & FINITEFUN) == 0) #define isallunit(F) (F->f_setcount == F->f_unitcount) #define component_checked(F) (F->f_mark) |= COMPONENT_CHECKED #define component_not_checked(F) (F->f_mark) &= (~COMPONENT_CHECKED) #define is_component_checked(F) ( ((F->f_mark) & COMPONENT_CHECKED) != 0 ) #define is_component_not_checked(F) ( ((F->f_mark) & COMPONENT_CHECKED) == 0 ) /* type of operator */ #define PREFIX 0100 #define POSTFIX 0200 #define INFIX 0300 struct operator { struct func *o_func; int o_prec; /* precedence of operator 0-1200 */ int o_type; /* type of operator: xf,yf,fx,fy,xfy,yfx,xfx */ /* bit pattern of o_type is: PREFIX=0100, POSTFIX=0200, INFIX=0300, leftdown = 0010, rifgtdown = 0001 xf -- 0210, yf -- 0200, fx -- 0101, fy -- 0100, xfy -- 0310, yfx -- 0301, xfx -- 0311 */ struct operator *o_link; /* link to another operator */ }; struct clause { /* sequence of atomic formula */ int c_type; /* CLAUSE_TYPE or LIST_TYPE */ struct term *c_form; /* atomic formula */ struct clause *c_link; }; #define NULL_CL (struct clause *)NULL struct set { /* definition horn clause */ unsigned short int s_anumber; unsigned short int s_bodynumber; /* number of body literals */ int s_ground_head; /* the head is ground or not : TRUE/FALSE */ struct clause *s_clause; /* Horn clause */ struct set *s_link; /* next def */ struct term *s_vlist; /* variables */ struct clause *s_constraint; /* constraint clause */ }; struct cset{ /* clause stack */ struct clause *cs_clause; struct term *cs_vlist; unsigned short int cs_anumber; /* v_number + p_number */ unsigned short int cs_status; /* 0: not unfolded 1: unfolded */ unsigned short int cs_cnum; /* the number of literals in the body */ unsigned short int cs_number; /* set number */ struct cset *cs_mother; /* mother derivation clause */ struct cset *cs_link; }; #define is_unitclause(Set) (Set->s_bodynumber == 0) /* dummy definition (for non-functional system predicate) */ #define DUMMY_DEF (struct set *)1 struct pair { /* environment for SS */ struct term *p_body; /* term */ struct pair *p_env; /* environment */ }; #define NULL_ENV (struct pair *)NULL struct ustack { /* user stack */ int *u_addr; /* address */ int u_val; /* content */ }; struct node { /* node for Prolog refutation */ struct clause *n_clause; /* goal */ struct pair *n_env; /* variable environment */ struct set *n_set; /* OR-program clauses */ struct node *n_link, *n_last; struct eclause *n_constraint; /* constraint of CAHC */ unsigned short int n_count, n_spy, n_tmp, n_scount; int *n_hp; struct pair *n_ep; struct ustack *n_usp; }; #define NULL_NODE (struct node *)NULL struct eclause { /* environment + clause(copy) */ int c_type; struct term *c_form; /* atomic formula */ struct eclause *c_link; /* equiv eclause link */ struct pair *c_env; /* formular environment */ }; #define NULL_ECL (struct eclause *)NULL struct itrace{ /* integrate trace */ unsigned short int it_anumber, it_cnumber; /* #of var,literals (key) */ struct clause *it_clause; /* Horn clause (history) */ struct itrace *it_link; }; struct pst { /* Partial Specified Term */ int type; /* PST_TYPE */ struct term *p_var; /* var comes here */ struct eclause *p_lists; /* property lists */ }; struct pstvar { int v_type; /* v_type = VAR_PST_TYPE */ int v_number; char *v_name; struct term *v_link; struct term *old_var; }; struct pst_item { struct pair *p_var; /* PST var */ struct eclause *p_lists; /* property lists */ struct pst_item *p_link; /* link to other items */ }; #define NULL_PSTIT (struct pst_item *)NULL /* deref: if (t,e) is var ,then p != NULL, else p == NULL */ /* t,p,e must be variables !!!! */ #define down(p, t, e)\ while(1){ \ if (is_notvoidvar(t)) {\ p = &e[vnumber(t)];\ if (p->p_body == NULL_TERM) break;\ t = p->p_body;\ e = p->p_env;\ }\ else if (is_voidvar(t)) {p = Anonymous_env; break; }\ else { p = NULL_ENV; break; } } /* various modes of cu-Prolog */ #define Notrace_mode tflag = 0 #define Normaltrace_mode tflag = 1 #define Steptrace_mode tflag = 2 #define Leap_mode tflag = 3 #define Is_Notrace (tflag == 0) #define Is_Normaltrace (tflag == 1) #define Is_Steptrace (tflag == 2) #define Is_Leap (tflag == 3) #define Is_Trace (tflag != 0) #define Msolvable_mode sflag = 0 #define Modular_mode sflag = 1 #define Is_Msolvable (sflag == 0) #define Is_Modular (sflag == 1) #define Is_ctnotrace (CTmode == 0) #define Is_ctnormal (CTmode == 1) #define Is_ctstep (CTmode == 2) #define CTnotrace CTmode = 0 #define CTnormal CTmode = 1 #define CTstep CTmode = 2 /* c.t. trace(normal, step) begin&end */ #define TTB if (CTmode != 0){ #define TTE TE /* c.t. step trace begin&end */ #define TSTB if Is_ctstep { #define TSTE TE /* c.t. normal trace begin&end */ #define TNTB if Is_ctnormal { #define TNTE TE /* trace begin & end */ #define TB if (Is_Trace) { #define STB(F) if (Is_Trace && isspy(F) ) { #define TE NL; } #define STE TE /* modularize fail */ /* #define MFAIL (struct clause *)1 */ /* return value of the execution of system predicate */ #define SYSNO 1 /* is not system pred. */ #define SYSTRUE 2 /* system pred. success */ #define SYSFAIL 3 /* system pred. fail */ #define SUSPEND 4 #define TRUE 1 #define FALSE 0 /* refutation search staus flag used in syspred.c, refute.c */ #define DOWN 1 #define UP 2 #define BACKTRACK 3 /* predicate symbol hash table size */ #define HASH_SIZE 478 #define NAMELEN_MAX 1024 /* size of name buffer */ #define REFMAX 10000 /* refutation max (Refcount) default */ #define Modmax_def 50 /* modularize max (MODULAR_MAX) default */ /* struct allocation macro s:struct name */ #define snew(s) (struct s *)salloc(sizeof (struct s) / sizeof (int)) #define cnew(s) (struct s *)challoc(sizeof (struct s) / sizeof (int)) #define new(s) (struct s *)alloc(sizeof (struct s) / sizeof (int)) #define MEMORY_ALLOC(X,Y,F) \ switch (F) { \ case TEMPORAL: \ X=new(Y); break;\ case MEDIUM: \ X=cnew(Y); break; \ default:\ X=snew(Y); } #define in_sheap(X) (( &sheap[0] <= ((int *)X)) && (((int *)X) < shp)) #define Npstobj(Head,Env,Tail,Flag) Neclause(Head,Env,Tail,Flag) /* the maximum number of variables */ #define VMAX 30 /* for constraint transformation (trans.c tr_sub.c tr_split.c) */ /* values of cs->cs_status */ #define REMOVED 1 /* for CSTR_list */ #define UNTOUCHED 0 #define MODULAR_DEFINED 2 #define UNIT_DEFINED 3 /* for DEF_list */ #define DERIVATION 4 #define REGISTERED 5 #define FALSE_REGISTERED 6 #define REDUCED_DEF 7 /* for M-solvability */ #define TEMPORAL_DEFINED 8 struct compartment{ struct clause *cmp_clause; struct compartment *cmp_link; }; struct vpair{ /* link between v1 and v2 */ struct term *v1; /* original var or pst */ struct term *v2; /* variant var or pst */ struct vpair *v_link; }; struct variant { struct clause *v_clause; /* variant clause */ struct term *v_var; /* variable list in v_clause */ struct vpair *v_pair; /* variable correspondence */ int v_anum; /* # of v+ # of pst */ }; /* maximum number of open files */ #define MAX_OPEN_FILES 20 #define FILE_NAME_LEN 128 /* heap units */ #define SHEAP_UNIT (sizeof(int)) #define HEAP_UNIT (sizeof(int)) #define CHEAP_UNIT (sizeof(int)) #define ESP_UNIT (sizeof(struct pair)) #define USTACK_UNIT (sizeof(struct ustack)) #define NAME_UNIT (sizeof(char)) /**************** global functions *************/ #include "funclist.h" /**************** global vars ******************/ #if MAIN == 1 #include "varset.h" struct func *hash_list[HASH_SIZE]; /* predicate hash table */ #else #include "globalv.h" extern struct func *hash_list[]; #endif /*************** system predicate *************/ #if SYSPRED == 1 #include "syspdef.h" #else #include "sysp.h" #endif F) ( ((F->f_mark) & FINITEFUN) == 0) #define isallunit(F) (F->f_setcount == F->f_unitcount) #define component_checked(F) (F->f_mark) |= COMPONENT_CHECKED #define component_not_checked(F) (F->f_mark) &= (~COMPONENT_CHECKED) #define is_componensrc/jpsgsub.c 644 10266 36 14447 5712121410 6610 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << jpsgsub.c >> * (system predicates for JPSG parser) --------------------------------------------------------------------*/ #include "include.h" /* tree() system predicate */ void Ptree(),treeprint(),oldlink(),PCat(),Psubcat(); int null_or_nil(); #define TREEMAX 20 /* tree depth max */ int treehist[TREEMAX]; int Category_size = 0; #define CATMAX 30 int cattype[CATMAX]; char catname[CATMAX][10]; /* category name */ /* category type */ #define Normal 1 #define CatSingle 2 #define CatSet 3 void show_category() /* for debug */ { register int i; tputc('['); for (i = 0; ;) { tprint2("%s,%d",catname[i],cattype[i]); i++; if (i >= Category_size) break; tputc(','); } tputc(']'); } void init_category() { Category_size = CAT_P->f_arity = 6; strcpy(catname[0],"POS");cattype[0] = Normal; strcpy(catname[1],"FORM");cattype[1] = Normal; strcpy(catname[2],"AJA");cattype[2] = CatSingle; strcpy(catname[3],"AJN");cattype[3] = CatSingle; strcpy(catname[4],"SC");cattype[4] = CatSet; strcpy(catname[5],"SEM");cattype[5] = Normal; } void list_to_cat(t0,n) /* set cattype[],catname[] */ struct term *t0; int n; { register int i; register struct term *t; for (t = t0, i = 0; i < n; i++, t = Arg(t,1)) { if (! is_list(t)) error("illegal format (feature type)"); if (!isvar(head_of_list(t))) error("illegal feature name"); strcpy(catname[i],vname(head_of_list(t))); t = tail_of_list(t); if (! is_list(t)) error("illegal format (feature type)"); if (!is_num(head_of_list(t))) error("illegal feature type"); cattype[i] = num_value(head_of_list(t)); } } void set_category() /* %C command */ { struct term *t; v_number = 0; v_list = NULL; advance; t = Rterm(1200,TEMPORAL); skipline; if ((v_number < 3) || (v_number > 30)){ tprint0("illegal feature number (>3,<30)"); init_category(); return; } list_to_cat(t,v_number); Category_size = v_number; CAT_P->f_arity = v_number; } int tree_pred(t,e) struct term *t; struct pair *e; { Ptree(Arg(t,0),e); return(SYSTRUE); } void Ptree(t,e) /* print tree entry */ struct term *t; struct pair *e; { int i; struct pair *p; down(p,t,e); if (t->type.t_func != T_P) { Pterm(t,e); return; } for (i = 0; i < TREEMAX; i++) treehist[i] = 0; /* array initialize */ treeprint(t,e,0);NL; } void oldlink(n) /* print old link in depth n */ int n; { int i; tprint0(" "); for (i = 0; i < n; i++) { if (treehist[i] != 0) { tprint0("| "); } else { tprint0(" "); } } } void treeprint(t,e,n) /* print tree main */ struct term *t; struct pair *e; int n; /* depth */ { struct pair *p; down(p,t,e); if ((t->type.t_func != T_P) || (n > TREEMAX) ){ PCat(t,e,0); return; } treeprint(Arg(t,0),e,n + 1); if (Arg(t,2) == NIL) { tprint0("---"); Pterm(Arg(t,1),e); return; } NL; treehist[n] = 1; oldlink(n);tprint0("| ");NL; oldlink(n);tprint0("|--");treeprint(Arg(t,1),e,n + 1);NL; oldlink(n);tprint0("| ");NL; treehist[n] = 0; oldlink(n);tprint0("|__");treeprint(Arg(t,2),e,n + 1); } int null_or_nil(t,e) register struct term *t; register struct pair *e; { register struct pair *p; down(p,t,e); if (t == NULL) return(TRUE); else if (t == NIL) return(TRUE); else return(FALSE); } void PCat(t,e,f) /* print category */ struct term *t; struct pair *e; int f; /* if f = 1 ,does not print SEM */ { struct pair *p; register int i; down(p,t,e); if (t->type.t_func != CAT_P) { Pterm(t,e); return; } Pterm(Arg(t,0),e); /* print pos */ tprint0("["); Pterm(Arg(t,1),e); /* print form */ if (f == 1) { tputc(']'); return; } for (i = 2; i < (Category_size -1); i++) { if (null_or_nil(Arg(t,i),e)) continue; tprint1(", %s:",catname[i]); if (cattype[i] == CatSingle) Psubcat(Arg(t,i),e); else if (cattype[i] == CatSet) { tputc('{'); Psubcat(Arg(t,i),e); tputc('}'); } else Pterm(Arg(t,i),e); /* type = Normal */ } tprint0("]:"); Pterm(Arg(t,Category_size - 1),e); /* print sem */ } void Psubcat(t,e) /* print subcat etc. */ struct term *t; struct pair *e; { struct pair *p; down(p,t,e); if (t == NIL) return; if (t == NULL) return; if (p != NULL){ /* if t is var */ /* Pterm(t,e); */ tprint1("%s",vname(t)); return; } if (! is_list(t)) { tputc('?'); /* Pterm(t,e); */ return; } PCat(head_of_list(t),e,1); if (tail_of_list(t) == NIL) return; tprint0(", "); Psubcat(tail_of_list(t),e); } #define CnstMax 20 char *cnametmp[CnstMax]; /* work array */ char *termname(t,e) /* return functor name of t */ struct term *t; struct pair *e; { struct pair *p; down(p,t,e); if (p != NULL) return(vname(t)); /* if t is var */ return(t->type.t_func->f_name); } int pickname(t,e) /* pick up constraint name in cnametmp[] */ struct term *t; struct pair *e; { struct pair *p; int i; for (i = 0;;i++){ down(p,t,e); if (t == NIL) return(i); if (t == NULL) return(i); if (! is_list(t)){ tprint0("constraint error"); return(0); } cnametmp[i] = termname(head_of_list(t),e); t = tail_of_list(t); } } struct term *cnlistmake(n) int n; { int i; struct term *listtop; struct term *t,*ct; for(i = 0,listtop = NIL; i < n; i++){ ct = Nterm(0,ETERNAL); ct->type.t_func = Nfunc(USERFUN,cnametmp[i],0); t = (struct term *)Nlist(ct,(struct clause *)listtop,TEMPORAL); listtop = t; } return(listtop); } int cname_pred(t,e,nn) /* construct constraint list cnst->cn */ struct term *t; struct pair *e; struct node *nn; { struct term *cnst,*cn; struct pair *e1,*q; int n; cnst = Arg(t,0); cn = Arg(t,1); e1 = e; down(q,cn,e1); if (q == NULL) return(SYSFAIL); /* if cn isn't var */ n = pickname(cnst, e); if (n > CnstMax) n = CnstMax; q->p_body = cnlistmake(n); return(SYSTRUE); } ]'); } void init_category() { Category_size = CAT_P->f_arity = 6; strcpy(catname[0],"POS");cattype[0] = Normal; strcpy(catname[1],"FORM");cattype[1] = Normal; strcpy(catname[2],"AJA");cattype[2] = CatSingle; stsrc/main.c 644 10266 36 51074 5712121410 6054 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*-------------------------------------------------------------------- * cu-Prolog III (Constraint Unification Prolog) * ICOT in Cooperation with SIRAI@sccs.chukyo-u.ac.jp * << main.c >> * 88.11.23 Ver.2.00 OS command * 90.4.1 rewrite refute, syspred (ver.3.0) * 91.12 cu-Prolog III * 92.7 ICOT Free Software Release * 92.10.5 patch (init_status(): set globval vars) * 92.10.29 patch (up_init(): reset termset log) * 93.7.15 init_status() shp %Z(hash list) * 93.7.30 add decode_args(),heap_alloc() * 93.8.2 speedup 93.8.31 initialize_pointer() * 93.9.22 gc, sample/marcus.p * 94.5.20 PST unify, sample/hpsg.p * 94.7.6--13 speedup, unify.c etc. * 94.9.2 statistics (%S command) * 94.9.27 atom_to_str/2 * 94.10.25,27 for HELIOS, debug maisub.c --------------------------------------------------------------------*/ #include "version.h" #define COPYRIGHT "Institute for New Generation Computer Technology (ICOT)\n\t\tTokyo, Japan 1991-94" #define MAIN 1 #define HELIOS 0 /* if used as substance in Helios, 1 */ #include "include.h" #include struct itrace *newflist_save; void main(argc,argv) int argc; char *argv[]; { void on_interrupt(),decode_args(); int i; fp=stdin; /* default input */ for(argv++, i = 1; i < argc; i++, argv++) decode_args(*argv); /* decode arguments */ prepare(); /* set flag etc. */ utop = &ustack[0]; signal(SIGINT, on_interrupt); setjmp(reset); setjmp(unbreak_reset); while(1){ f_list = NULL; usp = utop; chp = &cheap[1]; /* save constraints heap pointer */ hp = &heap[1]; /* save user heap pointer */ ep = &eheap[1]; /* save user stack pointer */ newflist_save = newf_list; /* save old c.t. trace */ prolog_execution(); fflush(stdout); /* for HELIOS */ } } void decode_args(arg) /* decode arguments */ char *arg; { int size; if (arg[0] == '-') { size = atoi(arg+2)*1000; if (size > 0) switch (arg[1]) { case 'H': HEAP_SIZE=size; break; case 'S': SHEAP_SIZE=size; break; case 'E': ESP_SIZE=size; break; case 'C': CHEAP_SIZE=size; break; case 'U': USTACK_SIZE=size; break; case 'N': NAME_SIZE=size; break; } } else if ((fp = fopen(arg,"r")) == NULL) { printf("***Error*** Can't open '%s' \n",arg); fp = stdin; } else { printf(">>> open %s \n",arg); settimer(); } } /* for statistics checking */ void init_statistics() { STAT_REFUTE=STAT_BACKTRACK_DEEP=STAT_BACKTRACK_SHAL=0; STAT_FOLD=STAT_UNFOLD=STAT_DEF=0; } void print_statistics() { printf("--- statistics ----\n"); printf("[PROLOG] refute: %d + shallow backtrack: %d (deep backtrack: %d)\n", STAT_REFUTE, STAT_BACKTRACK_SHAL, STAT_BACKTRACK_DEEP); printf("[UNFOLD/FOLD] unfold: %d fold: %d definition: %d\n", STAT_UNFOLD, STAT_FOLD, STAT_DEF); init_statistics(); } void prolog_execution() { #if HELIOS != 1 if(tty && KEYIN) putcursor(); /* print cursor */ #endif advance; /* read next one char into cbuf */ switch (cbuf) { case '"': { /* read file */ advance; settimer(); /* set timer */ readfile(); break; } case EOF: { /* file end */ set_eof(); #if HELIOS != 1 printtime(); /* print execution time */ #endif break; } case '%': { /* flag statement */ next(); systemcommand(cbuf); break; } case '#': { /* os command interpreter */ advance; oscommand(); break; } case ':': case '?': { /* question clause */ init_statistics(); check_recursion(); questionclause(); break; } case '@':{ /* modularize clause */ advance; init_statistics(); check_recursion(); trans_routine(); break; } case '$': /* define new predicate */ advance; defnewfunc(); break; case '.': skipline; break; default : init_statistics(); defclause(); /* definition clause */ } } /* ------------------------------------------------------------ Error handler ------------------------------------------------------------ */ void on_interrupt() { error("\nInterrupt\n"); } void error_detail(t,e,s) struct term *t; struct pair *e; char *s; { if ((wfp != stdout) && (wfp != stderr)) fclose(wfp); wfp = stderr; Pterm(t,e); error(s); } void error(s) char *s; { if ((wfp != stdout) && (wfp != stderr)) { if (wfp != NULL) fclose(wfp); /* in %w command */ wfp = stderr; } #if HELIOS == 1 wfp = stderr; #endif if (utop != &ustack[0]) { /* restore stack */ utop = &ustack[0]; undo(utop); } if (!KEYIN) { /* error in reading a file */ while (cbuf != '\n') { next(); putc(cbuf,stderr); } tprint1("\n**** error in reading file (%s) ****\n",s); fclose(fp); fp = stdin; if ((shp -sheap) >= ((SHEAPTOP - sheap) * 0.95)) tprint0("\n***** Caution *****\n System heap is full! \n Restart cu-Prolog with -S option (-S xxx: system heap size)\n") } else { tprint1("\n%s\n", s); skipline; if ((shp -sheap) >= ((SHEAPTOP - sheap) * 0.95)) garbagecollect(); /* 93.9.22 */ #if HELIOS != 1 printtime(); /* print execution time */ #endif } wfp = stdout; newf_list = newflist_save; /* c.t. trace */ freeheap(); longjmp(reset, 0); /* in main() */ } /*------------------------------------------------ heap allocation ------------------------------------------------*/ void system_heap_alloc() { if (NULL == (sheap=(int *)malloc(SHEAP_SIZE+1))) { printf("***** No memories for system heap *****\n"); exit(0); } /* system heap */ shp = &sheap[0]; SHEAPTOP = &sheap[(int)(SHEAP_SIZE/SHEAP_UNIT)]; } void user_heap_alloc() { if (NULL == (heap=(int *)malloc(HEAP_SIZE+1))) { printf("***** No memories for user heap *****\n"); exit(0); } /* user heap */ hp=Heap_Max=&heap[0]; HEAPTOP = &heap[(int)(HEAP_SIZE/HEAP_UNIT)]; } void cstr_heap_alloc() { if (NULL == (cheap=(int *)malloc(CHEAP_SIZE+1))) { printf("***** No memories for constraint heap *****\n"); exit(0); } /* constraints/pst heap */ chp = Cheap_Max = &cheap[0]; CHEAPTOP = &cheap[(int)(CHEAP_SIZE/CHEAP_UNIT)]; } void env_heap_alloc() { if (NULL == (eheap = (struct pair *)malloc(ESP_SIZE+1))) { printf("***** No memories for environment heap *****\n"); exit(0); } /* environment heap */ ep = Esp_Max = &eheap[0]; ESPTOP = &eheap[(int)(ESP_SIZE/ESP_UNIT)]; } void ustack_alloc() { if (NULL == (ustack = (struct ustack *)malloc(USTACK_SIZE+1))) { printf("***** No memories for user stack *****\n"); exit(0); } /* user stack */ usp = Stack_Max = &ustack[0]; STACKTOP = &ustack[(int)(USTACK_SIZE/USTACK_UNIT)]; } void name_heap_alloc() { if (NULL == (nheap = (char *)malloc(NAME_SIZE+1))) { printf("***** No memories for name string heap *****\n"); exit(0); } /* name string heap */ nhp= &nheap[0]; NHEAPTOP = &nheap[(int)(NAME_SIZE/NAME_UNIT)]; } void heap_alloc() /* allocate system/user heaps */ { system_heap_alloc(); user_heap_alloc(); cstr_heap_alloc(); env_heap_alloc(); ustack_alloc(); name_heap_alloc(); } void heap_realloc() /* reallocate system/user heaps */ { cfree((char *)sheap); SHEAP_SIZE=SHEAP_SIZE*1.2; system_heap_alloc(); /* free(heap); HEAP_SIZE *= 1.2; free(cheap); CHEAP_SIZE *= 1.2; free(eheap); ESP_SIZE *= 1.2; free(ustack); USTACK_SIZE *= 1.2; free(nheap); NAME_SIZE *= 1.2; heap_alloc(); */ init_status(); } void initialize_pointer() /* initialize heap pointers */ { shp = &sheap[0]; SHEAPTOP = &sheap[(int)(SHEAP_SIZE/SHEAP_UNIT)]; hp=Heap_Max=&heap[0]; HEAPTOP = &heap[(int)(HEAP_SIZE/HEAP_UNIT)]; chp = Cheap_Max = &cheap[0]; CHEAPTOP = &cheap[(int)(CHEAP_SIZE/CHEAP_UNIT)]; ep = Esp_Max = &eheap[0]; ESPTOP = &eheap[(int)(ESP_SIZE/ESP_UNIT)]; usp = Stack_Max = &ustack[0]; STACKTOP = &ustack[(int)(USTACK_SIZE/USTACK_UNIT)]; nhp= &nheap[0]; NHEAPTOP = &nheap[(int)(NAME_SIZE/NAME_UNIT)]; } void prepare() /* system preparation */ { tty = isatty(0); heap_alloc(); /* heap/stack allocation */ init_status(); /* initialize global vars */ /* default status */ wfp = stdout; /* with echo back */ lfp = NULL; /* no log file */ ECHO_BACK = FALSE; Handle_Undefined = FALSE; /* fail return */ Modular_mode; /* solution flag */ Notrace_mode; /* trace flag */ MODULARMAX = Modmax_def; Refcount = REFMAX; Print_Depth = 32; /* push_status(); */ /* save f_list, etc. */ #if HELIOS != 1 open_title(); /* opening title */ #endif } void init_status() /* initialize global vars */ { int i; initialize_pointer(); /* 93.8.31 */ /* initialize global vars */ refute_node_count = -1; /* refute node counter*/ v_number = 0; /* temporary var number */ p_number = 0; v_list = NULL_TERM; /* temporary var list */ pv_list = NULL_TERM; f_list = (struct func *)NULL; /* new function list entry */ o_list = (struct operator *)NULL; newf_list = (struct itrace *)NULL; /* new function definition */ initialize_psttable(); Def_Modified = 0; /* user pred not modified */ GENSYM = FNUMBER = 0; for(i = 0; i < HASH_SIZE; hash_list[i++] = NULL) ; /* initialize hash table */ init_heap_max(); /* cf. new.c */ init_syspred(); /* initialize system predicates */ } void open_title() /* opening title */ { printf("\n\t******* cu - Prolog III Ver. %s *******\n",VERSION); printf("\t[COPYRIGHT] %s\n",COPYRIGHT); /* printf("\t%s mode",(Is_Msolvable ? "M-solvable" : "All Modular")); */ printf("\tType '%%h' for help.\n\n"); printf("\t[Heap=%dK System_heap=%dK Env_stack=%dK Cstr_heap=%dK\n",(int)(HEAP_SIZE/1000),(int)(SHEAP_SIZE/1000),(int)(ESP_SIZE/1000),(int)(CHEAP_SIZE/1000)); printf("\t Ustack=%dK Name_heap=%dK]\n",(int)(USTACK_SIZE/1000),(int)(NAME_SIZE/1000)); } void print_constant() /* print constant list */ { struct func *f; int i; for (i = 0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f->f_link) if (f->f_arity == 0) tprint2("%s/%x ",f->f_name,f); NL; } void show_hash_list() /* for DEBUG 93.7.16*/ { int i; struct func *f; for (i=0; i:",i); for(f=hash_list[i];f!=(struct func *)NULL;f=f->f_link) printf("%s ",f->f_name); printf(" | "); } putchar('\n'); } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ systemcommand() process cu-Prolog system (%) commands ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void systemcommand(c) /* % command */ int c; { switch(c) { case 'C': /* change cat() functor */ set_category(); break; case 'D': /* maximum of print depth */ readword(nbuf); Print_Depth = atoi(nbuf); break; case 'G': /* garbage collection */ garbagecollect(); break; case 'H': /* for debug */ print_hash_table(); break; case 'L': /* list trace definition */ tprint0("\n +-- List new predicate ----+\n"); Shownewfunc(); break; case 'M': /* maximum of variables in transformation */ readword(nbuf); MODULARMAX = atoi(nbuf); if (MODULARMAX < 0) MODULARMAX = Modmax_def; break; case 'N': /* for debug */ show_heap_max(); break; case 'P': /* Preprocess Constraints */ readword(nbuf); preprocess_constraints(nbuf); break; case 'Q': /* QUIT cu-prolog */ quit_prolog(); return; case 'R': /* system reset */ tprint0("System initialized\n"); prepare(); break; case 'S': /* system statistics */ print_statistics(); break; case 'X': /* print constant (for debug) */ tprint0("+++++ print constants +++++\n"); print_constant(); break; case 'Y': /* edit predicates (for debug) */ tprint0("+++++ edit predicates +++++\n"); edit_predicate(); break; case 'Z': /* show hash table (for debug) */ tprint0("+++++ show hash table +++++\n"); show_hash_list(); break; case 'a': /* all modular mode */ tprint0("\n ___ all modular mode ___\n"); Modular_mode; break; case 'c': /* maximum of refute counter */ readword(nbuf); Refcount = atoi(nbuf); if (Refcount <= 0) Refcount = REFMAX; /* default */ break; case 'd': /* list definition */ readword(nbuf); showdef(nbuf); break; case 'f': /* free space */ tprint0("show the status of memory allocation\n"); freeheap(); break; case 'h': /* help menu */ tprint0("** Usage:\tcuprolog [-Hxxx][-Sxxx][-Exxx][-Cxxx][-Uxxx][-Nxxx][filename]\n"); tprint1("** %% commands (ver.%s) **",VERSION); tprint0(" (prompt _:normal, $:trace, >:step)\n"); helpmenu(); break; case 'l': /* log file */ readword(nbuf); loghandle(nbuf); break; case 'n': /* change genfunc name */ readword(genname); break; case 'o': /* M-Solvable mode */ tprint0("\n ___ M-solvable mode ___\n"); Msolvable_mode; break; case 'p': /* set/reset spy flag */ readword(nbuf); spyswitch(nbuf); break; case 's': /* step trace on/off */ stepswitch(); break; case 't': /* trace on */ traceswitch(); break; case 'u': /* undefined predicate handling */ Handle_Undefined = (Handle_Undefined == TRUE) ? FALSE : TRUE; tprint1("Undefined Predicates causes %s\n", ((Handle_Undefined == TRUE) ? "ERROR" : "FAIL")); break; case 'w': /* write file */ readword(nbuf); filewrite(nbuf); /* save program */ break; default: /* else */ break; } skipline; /* skip one line */ } void garbagecollect() /* garbage collection */ { if (fp != stdin) return; /*fclose(fp);*/ if ((wfp != stdout) && (wfp != stderr)) fclose(wfp); settimer(); /* set timer */ tprint0("====== Garbage Collection ======\n"); strcpy(nbuf, "TEMPF.###"); /* temporary file */ delete_tmp(); /* delete old temp file */ tprint0("--->"); filewrite(nbuf); /* save program to nbuf */ init_status(); /* initialize shp, f_list, etc. */ tprint0("--->"); set_inputfile(nbuf); /* wfp = NULL; no echo back */ } void edit_predicate() /* edit predicate */ { tprint0("++++++++ Garbage Collection +++++++++\n"); strcpy(nbuf, "TEMPF.prd"); /* temporary file */ system("rm -f TEMPF.prd"); /* delete old temp file */ tprint0("++++++++ Step 1: write file \n"); filewrite(nbuf); /* save program */ /* pop_status(); */ /* initialize shp, f_list, etc. */ system("$EDITOR TEMPF.prd"); /* edit */ tprint0("++++++++ Step 2: read file \n"); set_inputfile(nbuf); } void trans_routine() /* modular translation routine (@ C1,C2,...,Cn.) */ { register struct term *t; struct clause *c; if (Is_Steptrace && isspy(MODULAR_P)) CTstep; else if (Is_Normaltrace && isspy(MODULAR_P)) CTnormal; else CTnotrace; up_init(); /* reset termset log (92/10/29) */ v_number = 0; v_list = NULL; p_number = 0; pv_list = NULL; reread = FALSE; clear_psttable(); t = Rterm(1200,TEMPORAL); /* read constraints */ if (tokentype != FULLSTOP) error("Syntax error --- . missing"); skipline; NL; settimer(); /* set timer */ if (is_clause(t)) c = (struct clause *)t; else c = Nclause(t, NULL_CL, TEMPORAL); modular(c,v_list,v_number+p_number); #if HELIOS != 1 if (fp == stdin) printtime(); /* print execution time */ #endif undo(utop); /* pop user stack ( u : static var ) */ } void questionclause() /* ?-g1,g2,...gm;c1,c2...cn. */ { register struct term *q; struct eclause *co; struct pair *e; struct node *Last_Node, *Initial_Goal; struct term *initial_vlist; struct clause *c; int Status, refute(); if (Is_Steptrace && isspy(MODULAR_P)) CTstep; else if (Is_Normaltrace && isspy(MODULAR_P)) CTnormal; else CTnotrace; up_init(); /* reset termset log (92/10/29) */ v_number = 0; v_list = NULL; p_number = 0; pv_list = NULL; clear_psttable(); reread = FALSE; q = Rterm(1200,TEMPORAL); /* read goal */ if (tokentype!=FULLSTOP) error("Syntax error --- . expected"); skipline; /* skip CR */ renum_pvars((struct pstvar *)pv_list,v_number); e = Nenv(v_number+p_number); /* initial environments */ settimer(); if ((Pred(q) == CONSTRAINT_P) || (Pred(q) == CONSTRAINT2_P)) { c = (is_clause(Arg2(q))) ? (struct clause *)Arg2(q) : Nclause(Arg2(q),NULL_CL,TEMPORAL); co = transform(NULL_ECL,c,e); if (co == (struct eclause *)MFAIL) { tprint0("no (unsatisfied constraints)\n"); #if HELIOS != 1 if (fp == stdin) printtime(); #endif refute_node_count = -1; undo(utop); return; } q = Arg1(q); } else { co = NULL_ECL; } if ((Pred(q) != QUERY1_P) && (Pred(q) != QUERY2_P)) error("Syntax error --- Query Predicate was expected"); f_list = NULL; /* temp. pred list */ c = (is_clause(Arg1(q))) ? (struct clause *)Arg1(q) : Nclause(Arg1(q),NULL_CL,TEMPORAL); Initial_Goal = Last_Node = Newnode(c,co,e,NULL_NODE,NULL_NODE); Last_BT = NULL; Last_SKIP = NULL; Status = DOWN; initial_vlist = v_list; /* refutation */ while (1) { if (refute(Initial_Goal,Last_Node,Status) == FALSE){ #if HELIOS==1 printf("result:"); #endif tprint0("no.\n"); break; } else if (initial_vlist == NULL) { #if HELIOS==1 printf("result:"); #endif tprint0("true.\n"); break; } else { #if HELIOS==1 printf("result:"); Pclause(Initial_Goal->n_clause, Initial_Goal->n_env); printf("\n"); break; #endif if ((fp != stdin) || (Panswer(Initial_Goal,initial_vlist) == FALSE)) break; } Status = BACKTRACK; Last_BT = Last_Node = backtrack_node(Last_BT); } #if HELIOS != 1 if (fp == stdin) printtime(); #endif /* freeheap(); */ /* newf_list=index_newflist(newf_list,newflist_save); register itrace list */ /* index_funclist(f_list); tmp. pred -> hash */ refute_node_count = -1; /* refute node counter */ undo(utop); /* pop user stack ( u : static var ) */ } void defclause() /* definition clause read & set */ { register struct term *t; register struct clause *c, *cstr; v_number = 0; v_list = NULL; p_number = 0; pv_list = NULL; up_init(); /* reset termset log (92/10/29) */ reread = FALSE; t = Rterm(1200,STINGY); if (tokentype != FULLSTOP) error("Syntax error --- . was expected"); skipline; if (isvar(t)) error("Syntax error --- Variables cannot be asserted"); rename_var_names((struct var *)v_list); /* STINGY -> ETERNAL */ if ((Pred(t) == CONSTRAINT_P) || (Pred(t) == CONSTRAINT2_P)) { cstr = (is_clause(Arg2(t))) ? (struct clause *)Arg2(t) : Nclause(Arg2(t),NULL_CL,ETERNAL); t = Arg1(t); } else cstr = NULL; if (Pred(t) == DEF_P) { if (isvar(Arg1(t))) { tprint0(">>>>> "); Pterm(t,NULL_ENV); tprint0(" <<<<<"); error("Syntax error --- Variables cannot be asserted"); } if (is_clause(Arg2(t))) c = Nclause(Arg1(t),(struct clause *)Arg2(t),ETERNAL); else c = Nclause(Arg1(t), Nclause(Arg2(t),NULL_CL,ETERNAL), ETERNAL); } else if (is_functor(t)) c = Nclause(t,NULL_CL,ETERNAL); else error("Illegal definition"); if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); } index_set(c, cstr, 'z'); } void rename_var_names(v) struct var *v; { while (v != (struct var *)NULL) { truncate_varname(v->v_name,nbuf); v->v_name = nalloc(nbuf,ETERNAL); v = v->v_link; } } void truncate_varname(n,nbuf) char n[], nbuf[]; { register int i = 0; while ((n[i] != '\0') && (i < 7)) { if (n[i] == '_') break; nbuf[i] = n[i]; i++; } nbuf[i] = '\0'; } void renum_pvars(pvs,vnum) struct pstvar *pvs; int vnum; { while (pvs != (struct pstvar *)NULL) { pvs->v_number += vnum; pvs = (struct pstvar *)pvs->v_link; } } void defnewfunc() /* definition clause read & set */ { register struct term *t; register struct itrace *it; struct clause *c; v_number = 0; v_list = NULL; p_number = 0; pv_list = NULL; up_init(); /* reset termset log (92/10/29) */ reread = FALSE; t = Rterm(1200,STINGY); if (tokentype != FULLSTOP) error("Syntax error --- . was expected"); skipline; if (Pred(t) != EQSIGN_P) error("Illegal itrace definition"); rename_var_names((struct var *)v_list); /* STINGY -> ETERNAL */ c = (is_clause(Arg2(t))) ? (struct clause *)Arg2(t) : Nclause(Arg2(t),NULL_CL,ETERNAL); it = snew(itrace); it->it_clause = Nclause(Arg1(t),c,ETERNAL); it->it_anumber = v_number+p_number; it->it_cnumber = literalnumber(c); it->it_link = newf_list; newf_list = it; Pred(Arg1(t))->f_integ = it; } free space */ tprint0("show the status of memory allocation\n"); freeheap(); break; case 'h': /* help menu */ tprint0("** Usage:\tcuprolog [-Hxxx][-Sxxx][-Exxx][-Cxxx][-Uxxx][-Nxxx][filename]\n"); tprint1("** %% commands (ver.%s) **",VERSION); tprint0(" (prompt _:normal, $:trace, >:step)\n"); helpmenu(); break; case 'l': /* log file */ readword(nbuf); loghandle(nbuf); break; case 'n': /* change genfunc name */ rsrc/mainsub.c 644 10266 36 74562 5712121410 6575 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << mainsub.c >> * system command etc. * 1993.7.30 freeheap() * 1993.8.3 calc_component(), recalc_component() sppedup * 1994.6.28 component functions. speedup * 1994.9.27 show statistics * 1994.10.25 debug: set_head_component --------------------------------------------------------------------*/ #include "include.h" void putcursor () { if (Is_Notrace) { /* trace off */ tputc ('_'); } else if (Is_Normaltrace) { /* trace on */ tputc ('$'); } else tputc ('>'); /* step trace on */ } void traceswitch () { if (Is_Normaltrace) { Notrace_mode; tprint0 ("\n +++ normal trace off +++\n"); } else { Normaltrace_mode; tprint0 ("\n +++ normal trace on +++\n"); } } void stepswitch () { if (Is_Steptrace) { Notrace_mode; tprint0 ("\n +++ step trace off +++\n"); } else { Steptrace_mode; tprint0 ("\n +++ step trace on +++\n"); } } int decode_pname(fname) /* 'member/2' --> 'member', return 2 */ char *fname; { for (; *fname != '\0'; fname++) if (*fname == '/') { *fname = '\0'; return(atoi(fname + 1)); } return(-1); } void spyswitch (fname) char *fname; { struct func *f; int i,arity; if (strcmp (fname, "*") == 0) { tprint0 ("--- set all spy flag ---"); NL; allspy(1); /* set all spy flag */ return; } if (strcmp (fname, ".") == 0) { tprint0 ("--- reset all spy flag ---"); NL; allspy(0); /* reset all spy flag */ return; } if (strcmp (fname, "?") == 0) {/* list spyed predicates */ tprint0 ("+++ list spyed predicates +++\n"); for (i=0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f -> f_link) { if isspy(f) tprint2 ("%s(%u) ", f -> f_name, f -> f_arity); } NL; return; } if (strcmp (fname, ">") == 0) /* spy fold/unfold */ { tprint0(" +++ "); if isspy(MODULAR_P) tprint0("no"); tprint0("spy fold/unfold transformation \n"); spychange(MODULAR_P); spychange(INTEG_P); return; } arity = decode_pname(fname); if (!exist_fname(fname)) { tprint1(" '%s' does not exist.\n", fname); return; } if (arity == -1) /* spy switch fname/?? */ { for(f = hash_list[hash(fname)]; f != NULL; f = f->f_link) if (streq(fname,f->f_name)) { tprint0 ("+++ "); if isspy(f) tprint0 ("no"); tprint2("spy %s/%d\n", f->f_name, f->f_arity); spychange(f); } } else { f = funcsearch(fname, arity); if (f != NULL) { tprint0 (" +++"); if isspy(f) tprint0 ("no"); tprint2("spy %s/%d\n", f->f_name,f->f_arity); spychange(f); /* switch spy flag on/off */ } else tprint2(" '%s/%d' does not exist.\n", fname,arity); } } void allspy (n) /* if n == 1: set all spy flag, else resetall flag */ int n; { struct func *f; int i; if (n == 1) { for (i = 0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f -> f_link) spyfun(f); } else { for (i = 0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f -> f_link) nospyfun(f); } } void show_pred_roles(f) /* show component */ struct func *f; { int i, arity; struct component *cm; register struct component *c; for (i = 0, arity = f->f_arity; i < arity ; i++) { cm = Component(f,i); if (cm == NULL) { tprint0("_"); } else { for (c = cm; c != NULL; c = c->c_next) { if (c->c_label == NULL) { tprint0("+"); } else { tprint1("%s",c->c_label->f_name); } if (c->c_next == NULL) break; else { tprint0("."); } } } if (i == (arity -1)) return; else { tprint0("|"); } } } /* the number of pred names printed in one line */ #define PRED_IN_LINE 5 void show_syspred_name() { int i, j = 0; register struct func *f; tprint0(" +---------------[ +:recursive, ^:functor ]--\n"); for (i = 0; i < HASH_SIZE; i++) /* print system predicates */ for (f = hash_list[i]; f != NULL; f = f -> f_link) if issystem(f) { tprint2 ("%s/%u", f -> f_name, f -> f_arity); if isrecursive(f) tprint0 ("+"); if (f->def.f_sysfunc == NULL) tprint0("^"); tputc('\t'); if (++j >= PRED_IN_LINE) {j = 0; NL;} }; NL; } void show_userpred_name() { int i, j = 0; register struct func *f; tprint0(" +-------------"); tprint0("--[ *:spy, -:reduced, +:recursive, #:new ]--\n"); for (i = 0; i < HASH_SIZE; i++) /* print user predicates */ for (f = hash_list[i]; f != NULL; f = f -> f_link) { /* if (f->f_arity < 0) continue; */ if (f->def.f_sysfunc == NULL) continue; /* cut constant. */ if issystem(f) continue; tprint2 ("%s/%u", f -> f_name, f -> f_arity); if isspy(f) tprint0 ("*"); if isreduced(f) tprint0 ("-"); if isrecursive(f) tprint0 ("+"); if isnewpred(f) tprint0("#"); tputc('\t'); if (++j >= PRED_IN_LINE) {j = 0; NL;} } NL; } void show_syspred_status(f) struct func *f; { tprint0("-----["); show_pred_roles(f); tprint1("]--<%s>---+\n", ((is_funcsys(f)) ? "functional" : "multi-valued")); } void show_pred_def(f) /* show def of each pred */ struct func *f; { void show_pred_roles(); if (f->def.f_set == NULL) return; /* constant */ tprint2 (" +--------( %s/%u )-----", f->f_name, f->f_arity); if issystem(f) { show_syspred_status(f); return; } if is_nofuncsys(f) { tprint0("------+\n"); return; } if isspy(f) tprint0 ("--"); if isreduced(f) tprint0 ("--"); if isrecursive(f) tprint0("--"); if isnewpred(f) tprint0("--"); tprint0("["); show_pred_roles(f); tprint2("]--%d/%d--+\n",f->f_unitcount,f->f_setcount); if (f -> f_integ != NULL) { tprint0 (" "); P_dclause (f -> f_integ -> it_clause,NULL_ENV); NL; NL; } Showfunc(f); } void showdef (fname) /* list definition (%d command) */ char *fname; { register struct func *f; int i,arity; check_recursion(); if (streq(fname, "/")) { tprint0 (" +-- List all predicates ---+ \n"); for (i = 0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f -> f_link) Showfunc (f); return; } if (streq(fname, "*")){ tprint0 (" +-- List predicates ---+ \n") for ( i=0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f -> f_link) { if isnoreduced(f) Showfunc (f); } return; } if (streq(fname, "?")){ show_syspred_name(); show_userpred_name(); return; } if (streq(fname, "-")) { show_userpred_name(); return; } arity = decode_pname(fname); if (exist_fname(fname) == NULL) { tprint1 ("'%s' does not exist.\n", fname); return; } if (arity == -1) /* show fname/?? */ { for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link) if (streq(f->f_name,fname)) show_pred_def(f); } else { f = funcsearch(fname,arity); if (f != NULL) show_pred_def(f); else tprint2("'%s/%d' does not exist.\n",fname,arity); } } void loghandle (fname) /* log file (%l command) */ char *fname; { if (strcmp (fname, "no") == 0) { tprint0 ("=== log stop === \n"); if (lfp != NULL) fclose (lfp); lfp = NULL; strcpy (logfile, "no"); } else if ((fopen (fname, "r")) != NULL) { tprint1 ("'%s' : already exist \n", fname); } else if ((fopen (fname, "w")) == NULL) { tprint1 (" '%s' : can't open \n", fname); } else { if (lfp != NULL) { fclose (lfp); tprint1 (" == %s : close ==\n", logfile); } lfp = fopen (fname, "w"); tprint1 (" log file '%s' \n", fname); strcpy (logfile, fname); } } void helpmenu () { /* on-line help */ tprint0 ("\t%%h\t: help\t\t\t%%Q : quit \n"); tprint0 ("\t# : OS command interpreter \n"); tprint0 ("\t%%d : list definition\n"); tprint0 ("\t\t%%d* %%d/: list all %%d?: list names %%d-: user pred\n"); tprint2 ("\t%c %c: consult file (no echo)\n", '"', '"'); tprint1 ("\t%c ?: consult file (with echo)\n", '"'); tprint1 ("\t%%l : set log file ['%s']\n", logfile); tprint0 ("\t%%w : save program\n"); tprint0 ("\t%%p : spy switch\n"); tprint0 ("\t\t%%p*:spy all\t%%p.:nospy all\t%%p?:list spyed preds.\n"); tprint1 ("\t%%t\t: normal trace switch [%s]\n", ((Is_Normaltrace) ? "on" : "off")); tprint1 ("\t%%s\t: step trace switch [%s]\n", ((Is_Steptrace) ? "on" : "off")); tprint0 ("\t%%a\t: all modular mode "); if (Is_Modular) tprint0(" <=now"); tprint0 ("\n\t%%o\t: M-Solvable mode "); if (Is_Msolvable) tprint0(" <=now\n") else NL; tprint1 ("\t%%c : max number of refutation node [%u]\n", Refcount); tprint0 ("\t%%n \t: new predicate name "); tprint1 ("['%s']\n", genname); tprint0 ("\t%%L\t: list new predicate definitions\n"); tprint0 ("\t%%f\t: show the system heap size\n"); tprint0 ("\t%%C [Feature,type,... ]. : set cat() functor\n"); tprint0 ("\t\t ==> ");show_category();NL; tprint0 ("\t%%G\t: Garbage Collection \n"); tprint1 ("\t%%D : Max Depth of Printing, now is %d\n", Print_Depth); tprint1 ("\t%%u\t: Undefined Predicate Handling Switch [%s]\n", ((Handle_Undefined == TRUE) ? "ERROR" : "FAIL")); tprint1("\t%%M : Max number of Variables in Transformation[%u]\n", MODULARMAX); tprint0 ("\t%%P : Preprocess Constraints\n"); tprint0 ("\t\t%%P*: preprocess all\t%%P?: predicates with nonmodular\n"); tprint0 ("\t%%R\t: system Reset \n"); tprint0 ("\t%%S\t: show statistics of the previous question.\n"); } void freeheap () { /* print shp status */ tprint3 ("\npermanent data area:\n\tSystem_heap : %d%%(%d/%dK) ", (int)(100 * (shp - sheap) *SHEAP_UNIT / SHEAP_SIZE), ((int)(shp-sheap)*SHEAP_UNIT/1000),(int)(SHEAP_SIZE/1000)); tprint3 ("Name_heap : %d%%(%d/%dK)\n", (int)(100 * (nhp - nheap) * NAME_UNIT / NAME_SIZE), (int)((nhp-nheap)*NAME_UNIT/1000),(int)(NAME_SIZE/1000)); show_heap_max(); } void show_heap_max() /* for debug */ { tprint0("temporal data area (max. used)\n\t"); tprint3 ("Cstr. heap : %d%%(%d/%dK) ", (int)((Cheap_Max - cheap) * 100 * CHEAP_UNIT / CHEAP_SIZE), (int)((Cheap_Max - cheap)*CHEAP_UNIT/1000),(int)(CHEAP_SIZE/1000)); tprint3("Heap : %d%%(%d/%dK) ", (int)(((Heap_Max - heap) * 100 * HEAP_UNIT) / HEAP_SIZE), (int)((Heap_Max - heap)*HEAP_UNIT/1000),(int)(HEAP_SIZE/1000)); tprint3 ("\n\tUser stack : %d%%(%d/%dK) ", (int)(((Stack_Max - ustack) * 100 * USTACK_UNIT)/ USTACK_SIZE), (int)((Stack_Max - ustack)*USTACK_UNIT/1000),(int)(USTACK_SIZE/1000)); tprint3 ("Env. stack : %d%%(%d/%dK) \n", (int)(((Esp_Max - eheap) * 100 * ESP_UNIT)/ ESP_SIZE), (int)((Esp_Max - eheap)*ESP_UNIT/1000),(int)(ESP_SIZE/1000)); } void init_heap_max() { Cheap_Max = cheap; Stack_Max = ustack; Heap_Max = heap; } void filewrite (n) /* write program to file */ char *n; { FILE * lfpsave; int i; register struct func *f; if ((wfp = fopen (n, "r")) != NULL) { fclose (wfp); wfp = stdout; tprint1 (" %s : already exist \n", n); return; } if ((wfp = fopen (n, "w")) == NULL) { wfp = stdout; tprint1 (" %s : can't open \n", n); return; } fprintf(wfp,"%%%%%% cu-Prolog predicates %%%%%%%% \n"); lfpsave = lfp; lfp = NULL; writenewfunc(); NL; for (i = 0; i< HASH_SIZE; i++) for (f = hash_list[i]; f != NULL; f = f->f_link) if (isuser(f) && isnoreduced(f)) Showfunc(f); fclose (wfp); wfp = stdout; lfp = lfpsave; tprint1 ("=== write to: %s ===\n", n); return; } void disp_func_def (f_from, f_to)/* show defs of f_from--->f_to */ struct func *f_from, *f_to; { if (f_from == NULL) return; if (f_from == f_to) return; disp_func_def (f_from -> f_link, f_to); if (isuser (f_from) && isnoreduced (f_from)) Showfunc (f_from); } void set_inputfile (n) char *n; /* file name */ { fp = fopen (n, "r"); if (fp == NULL) { /* open error */ fp = stdin; tprint1 ("%s ", n); error ("can't open !"); } else { tprint1 ("=== open '%s'\n", n); } } void readfile () { /* "file name" or "file name?" */ int i; /* if (!KEYIN) error ("file already opened"); */ for (i = 0; ((cbuf != '"') && (cbuf != '?')); advance) nbuf[i++] = cbuf; nbuf[i] = '\0'; /* n[] <- file name */ if (cbuf == '?') ECHO_BACK = TRUE; /* echo back on */ skipline; upush(&fp); utop = usp; set_inputfile (nbuf); /* set file pointer */ if (ECHO_BACK == TRUE) wfp = stdout; /* echo back on */ } void set_eof () { /* file EOF */ clearerr(fp); /* clear eof */ if (tty && KEYIN){ /* from keyboard */ error(" "); /* EOF (^D in UNIX) */ } fclose (fp); if (utop != &ustack[0]) { utop -= 1; undo(utop); } else fp = stdin; if (wfp == NULL) wfp = stdout; /* echo back on */ tprint0 ("\n ****** end of file ******* \n"); } /* ----------- static program analyzer --------------- */ /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * check_recursion() check recursive/finite predicates +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ int REC_to_FINITE = 1; void check_all_unit(),rec_to_finite(),check_unitpred(); int is_body_finite(); void check_recursion() /* check recursive user predicates */ { int i; void reset_component(),calc_component(); if (Def_Modified == 0) return; for (i = 0; i < HASH_SIZE; i++) check_all_unit(hash_list[i]); REC_to_FINITE = 1; while(REC_to_FINITE != 0) { REC_to_FINITE = 0; /* global flag */ rec_to_finite(); /* traverse predicates */ } Def_Modified = 0; /* def modified flag off */ reset_component(); calc_component(); } void check_unitpred(f) struct func *f; { if (issystem(f)) return; if ((f->f_setcount == 0) || (f->f_setcount == f->f_unitcount)) { finitefun(f); return; } recursivefun(f); } void check_all_unit(fl) struct func *fl; { register struct func *f; if (fl == NULL) return; for (f = fl; f != NULL; f = f->f_link) { check_unitpred(f); } } void rec_to_finite() /* recursive pred -> finite pred */ { register int i; register struct func *f; for (i = 0; i < HASH_SIZE; i++) for(f = hash_list[i]; f != NULL; f = f->f_link) { if (issystem(f) || isfinite(f)) continue; else if (is_body_finite(f) != 0) { REC_to_FINITE = 1; finitefun(f); } } } int is_body_finite(f) /* if all the body is finite */ struct func *f; { register struct set *s; register struct clause *c; for (s = f->def.f_set; s != NULL; s = s->s_link) for (c = s->s_clause->c_link; c != NULL; c = c->c_link) if (isvar(c->c_form) || isrecursive(c->c_form->type.t_func)) return(FALSE); return(TRUE); } /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * recalc_component() component of each argument +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ void mark_component_checked_all(), set_all_head_component(), set_head_component(), set_head_component2(), set_all_body_component(),set_body_component(), add_component_pst(), add_component_pst2(), add_label(),calc_all_var(); #define is_globalvar(t) (((struct var *)t)->v_type == VAR_GLOBAL_TYPE) struct component *merge_component(); int COMPONENT_CHANGED; int HAS_BODY; /* changed in set_head_component() */ struct funclist /* temporal funclist structure */ { struct func *func; struct funclist *next; }; #define NULL_fl (struct funclist *)NULL void calc_component() { register int i; register struct func *f; register struct funclist *FL,*fl; int *hsave = hp; FL=fl=NULL_fl; for (i = 0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != (struct func *)NULL; f = f->f_link) if (isuser(f) && f->def.f_set != (struct set *)NULL) { HAS_BODY=0; /* changed in set_head_component() */ set_head_component(f); if (HAS_BODY != 0) /* not unit def predicates */ { MEMORY_ALLOC(fl,funclist,TEMPORAL); fl->func=f; fl->next=FL; FL=fl; } else /* no body clause --> end */ { component_checked(f); calc_all_var(f); } } do { COMPONENT_CHANGED = 0; for (fl=FL; fl != NULL_fl; fl=fl->next) set_body_component(fl->func); for (fl=FL; fl != NULL_fl; fl=fl->next) set_head_component2(fl->func); } while(COMPONENT_CHANGED != 0); for (fl=FL; fl != NULL_fl; fl=fl->next) { component_checked(fl->func); calc_all_var(fl->func); } hp=hsave; } void recalc_component() /* calc component for newly defined preds */ { register int i; register struct func *f; register struct funclist *FL,*fl; int *hsave = hp; FL=fl=NULL_fl; for (i = 0; i < HASH_SIZE; i++) for (f = hash_list[i]; f != (struct func *)NULL; f = f->f_link) if (isuser(f) && is_component_not_checked(f) && f->def.f_set != (struct set *)NULL ) { HAS_BODY=0; /* changed in set_head_component() */ set_head_component(f); if (HAS_BODY != 0) /* if f has a body clause */ { MEMORY_ALLOC(fl,funclist,TEMPORAL); fl->func=f; fl->next=FL; FL=fl; } else /* f has only unit clauses. */ { component_checked(f); calc_all_var(f); } } do { COMPONENT_CHANGED = 0; for (fl=FL; fl != NULL_fl; fl=fl->next) set_body_component(fl->func); for (fl=FL; fl != NULL_fl; fl=fl->next) set_head_component2(fl->func); } while(COMPONENT_CHANGED != 0); for (fl=FL; fl != NULL_fl; fl=fl->next) { component_checked(fl->func); calc_all_var(fl->func); } hp=hsave; } void calc_all_var(f) struct func *f; { register struct set *s; for (s = f->def.f_set; s != NULL; s = s->s_link) recalc_voccurrence(s->s_clause, s->s_vlist); } void reset_component() /* reset all Component() */ { int i; register int j; struct func *f; register struct set *s; register struct term *v; for (i = 0; i < HASH_SIZE; i++) for(f = hash_list[i]; f != NULL; f = f->f_link) if (isuser(f)) { for(j = f->f_arity - 1; j >= 0; j--) Component(f,j) = NULL; for(s = f->def.f_set; s != NULL; s = s->s_link) for (v = s->s_vlist; v != NULL; v = vlink(v)) vcomponent(v) = NULL; } } void set_head_component(f) /* check heads of f */ struct func *f; { register int i; register struct set *s; register struct term *t,*arg; if (f->f_arity == 0) return; for(s = f->def.f_set; s != NULL; s = s->s_link) { t = s->s_clause->c_form; /* head */ if (s->s_clause->c_link != NULL_CL) HAS_BODY=1; for (i = f->f_arity - 1; i >= 0; i--) { arg = Arg(t,i); if (isvar(arg)) { if (is_globalvar(arg)) { Component(f,i) = merge_component(Component(f,i), vcomponent(arg),ETERNAL); } } else if(is_pst(arg)) add_component_pst(f,i,((struct pst *)arg)->p_lists); else add_label(f,i,NOPSTLABEL,ETERNAL); /* normal term ; bug 94.10.25 */ } } } void set_body_component(ff) struct func *ff; { struct set *s; register struct clause *c; register struct term *t,*arg; register struct func *f; int i; if (ff->f_arity == 0) return; for(s=ff->def.f_set; s != NULL; s = s->s_link) for(c=s->s_clause->c_link; c !=NULL; c= c->c_link) { t = c->c_form; if (isvar(t)) continue; /* 94.12.2 call(X):-X. */ f = Pred(t); for (i = f->f_arity - 1; i >= 0; i--) { arg = Arg(t,i); if (is_globalvar(arg)) vcomponent(arg)= merge_component(vcomponent(arg), Component(f,i),TEMPORAL); } } } void set_head_component2(f) /* check heads of f (later than 2nd loop)*/ struct func *f; { register int i; register struct set *s; register struct term *t,*arg; if (f->f_arity == 0) return; for(s = f->def.f_set; s != NULL; s = s->s_link) { if (s->s_clause->c_link == NULL_CL) continue; /* omit unit clause */ t = s->s_clause->c_form; /* head */ for (i = f->f_arity - 1; i >= 0; i--) { arg = Arg(t,i); /* check only var and pst */ if (is_globalvar(arg)) Component(f,i) = merge_component(Component(f,i), vcomponent(arg),ETERNAL); else if(is_pst(arg)) add_component_pst2(f,i,((struct pst *)arg)->p_lists); } } } void add_component_pst(f,a,ec) /* add pst ec to f/a */ struct func *f; int a; struct eclause *ec; { register struct eclause *e; register struct term *value; register struct func *label; for (e = ec; e != NULL_ECL; e = e->c_link) { label = Pred(Arg1(e->c_form)); value = Arg2(e->c_form); if (isvar(value) && vcomponent(value) == NULL) continue; else add_label(f,a,label,ETERNAL); } } void add_component_pst2(f,a,ec) /* add pst ec to f/a (later than 2nd loop) */ struct func *f; int a; struct eclause *ec; { register struct eclause *e; register struct term *value; register struct func *label; for (e = ec; e != NULL_ECL; e = e->c_link) { label = Pred(Arg1(e->c_form)); value = Arg2(e->c_form); if is_globalvar(value) /* check var values only */ if (vcomponent(value) == NULL) continue; else add_label(f,a,label,ETERNAL); } } int cmp_label(l1,l2) /* 0:equal -1:l1l2 */ struct func *l1,*l2; { register int dif; if (l1 == l2) return(0); else if (l1 == NULL) return(-1); else if (l2 == NULL) return(1); else return(l1->f_number - l2->f_number); } /* component : ascending order */ void add_label(f,a,l,flag) /* add label l to f/a */ struct func *f,*l; int a,flag; /* flag = ETERNAL or TEMPORAL */ { register struct component *c,*cprev,*nc; register int cmp; for (cprev=NULL,c=Component(f,a); c != NULL; cprev= c, c = c->c_next) { cmp = cmp_label(l,c->c_label); if (cmp == 0) return; else if (cmp < 0) break; /* l < c_label */ } MEMORY_ALLOC(nc,component,flag); nc->c_next = c; nc->c_label = l; if (cprev == NULL) Component(f,a) = nc; else cprev->c_next = nc; COMPONENT_CHANGED++; } struct component *copy_component(cb,flag) /* make a copy of cb */ struct component *cb; int flag; /* ETERNAL or TEMPORAL */ { register struct component *nc; if (cb == (struct component *)NULL) return(cb); MEMORY_ALLOC(nc,component,flag); nc->c_label = cb->c_label; nc->c_next = copy_component(cb->c_next,flag); return(nc); } struct component *merge_component(ca,cb,flag) /* merge cb in ca */ struct component *ca, /* ca will be changed */ *cb; int flag; /* ETERNAL or TEMPORAL */ { int a; register struct component *nc; if (cb == (struct component *)NULL) return(ca); else if (ca == (struct component *)NULL) { COMPONENT_CHANGED++; return(copy_component(cb,flag)); } else if (ca != (struct component *)NULL) { a = cmp_label(ca->c_label,cb->c_label); if (a == 0) { ca->c_next = merge_component(ca->c_next,cb->c_next,flag); return(ca); } else if (a < 0) /* ca < cb */ { ca->c_next = merge_component(ca->c_next,cb,flag); return(ca); } else /* ca > cb */ { COMPONENT_CHANGED++; /* global var */ MEMORY_ALLOC(nc,component,flag); nc->c_label = cb->c_label; nc->c_next = merge_component(ca,cb->c_next,flag); return(nc); } } } int has_common_label(ec,cm) /* TRUE/FALSE */ struct eclause *ec; struct component *cm; { register int cmp; if (ec == NULL || cm == NULL) return(FALSE); if (cm->c_label == NOPSTLABEL) return(TRUE); /* cm is not vacuous */ cmp = cmp_label(Pred(Arg1(ec->c_form)), cm->c_label); if (cmp == 0) return(TRUE); else if (cmp < 0) return(has_common_label(ec->c_link,cm)); else return(has_common_label(ec,cm->c_next)); } /* -------------- end of component part --------------- */ void oscommand () { /* os command interpreter */ int i; for (i = 0; (cbuf != '\n'); next ()) nbuf[i++] = cbuf; nbuf[i] = '\0'; if (system (nbuf) != 0) tprint0 ("== OS command error == \n"); } void delete_tmp () { /* delete temp file */ FILE *fptmp; if ((fptmp = fopen("TEMPF.###","r")) != NULL) { fclose(fptmp); #if MSDOS == 0 /* for UNIX */ system ("rm -f TEMPF.###"); #else /* for MS-DOS */ system ("del TEMPF.###"); #endif } } void quit_prolog () { /* system quit */ tprint0("\n---- Quit cu-Prolog ? (y/n) ----"); skipline; if (keyread('y')) { if (lfp != NULL) fclose (lfp); /* close log file */ delete_tmp (); /* delete temp file */ exit (1); /* end */ } tprint0("\n.... Return to Prolog ....\n");/* cansel */ return; } void preprocess_constraints(fn) char *fn; { struct func *f; int arity; void preprocess_constr_sub(), preprocess_unit(); if (strcmp(fn,"*") == 0) { tprint0("--- preprocess all predicates ---\n"); preprocess_constr_sub(TRUE); tprint0("Done\n"); return; } if (strcmp(fn,"?") == 0) { tprint0("--- showing predicates with nonmodular constraints ---\n"); preprocess_constr_sub(FALSE); NL; return; } arity = decode_pname(fn); if (! exist_fname(fn)) { tprint1("'%s' does not exist\n",fn); return; } if (arity == -1) { /* any arity */ for (f = hash_list[hash(fn)]; f != NULL; f = f->f_link) if (streq(f->f_name,fn)) preprocess_unit(f,TRUE); } else { f = funcsearch(fn,arity); if (f == NULL) { tprint2("'%s/%d' does not exist.\n",fn,arity); return; } preprocess_unit(f,TRUE); } tprint0("Done\n"); } void preprocess_constr_sub(flag) int flag; /* preproces control flag */ { register int i; void preprocess_all_unit(); for (i = 0; i < HASH_SIZE; i++) preprocess_all_unit(hash_list[i],flag); } void preprocess_all_unit(fl,flag) struct func *fl; int flag; { register struct func *f; void preprocess_unit(); if (fl == NULL) return; for (f = fl; f != NULL; f = f->f_link) preprocess_unit(f,flag); } void preprocess_unit(f,flag) struct func *f; int flag; { register struct set *s; struct clause *c, *sol, *reduce_cstr(); struct pair *env; int check_modularity(); /* cf. is_modular_clause() */ if (issystem(f)) return; for (s = f->def.f_set; s != (struct set *)NULL; s = s->s_link) { c = s->s_constraint; if (c == NULL_CL) continue; if (check_modularity(c) == TRUE) continue; if (flag == FALSE) { Showhorn(s->s_clause,s->s_constraint, NULL_ENV); NL; continue; } tprint2("%s/%d\t", f->f_name,f->f_arity); env = Nenv(s->s_anumber); sol = reduce_cstr(c,s->s_vlist,s->s_anumber,env); if (sol == MFAIL) { /* failing transformation */ wfp = stderr; tprint1("Warning: Failing transformation in %s\n", f->f_name); c->c_form = FAIL; c->c_link = NULL_CL; Showhorn(s->s_clause,s->s_constraint, NULL_ENV);NL; wfp = stdout; continue; } up_init(); s->s_constraint = (struct clause *)termset(sol,env,ETERNAL); s->s_clause = (struct clause *) termset(s->s_clause,env,ETERNAL); up_restore(); if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); } s->s_anumber = (unsigned short int)(v_number+p_number); s->s_vlist = v_list; } } int check_modularity(cst) /* cf. is_modular_clause */ struct clause *cst; { register struct clause *c; register struct term *t; for (c= cst; c != NULL; c = c->c_link) { t = c->c_form; if (Pred(t) == EQ2_P || (! is_modular_literal(t))) return(FALSE); } return(TRUE); } #define NOREDUCED_CLAUSE (struct clause *)11 struct clause *reduce_cstr(cst,vlist,anum,env) struct clause *cst; struct term *vlist; int anum; struct pair *env; { struct clause *nc,*reduce_substitute(); int reduced = 0; nc = reduce_substitute(cst,env); /* reduce x=y */ if (nc == MFAIL) return(MFAIL); else if (nc == NOREDUCED_CLAUSE) /* no reduction */ return(startmodular(cst,vlist,anum)); else if (nc == NULL) return(NULL); else { up_init(); nc = (struct clause *)termset(nc,env,MEDIUM); up_restore(); if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); } return(startmodular(nc,v_list,v_number + p_number)); } } struct clause *reduce_substitute(cst,e)/* preprocess constraint */ struct clause *cst; struct pair *e; { register struct clause *c; struct clause *compress_clause(); int reduced = 0; struct term *t; for (c = cst; c != NULL_CL; c = c->c_link) { t = c->c_form; if (Pred(t) == EQ2_P) /* '=' */ { reduced = 1; c->c_form = NULL; if (tunify(Arg(t,0),e,Arg(t,1),e,0) == FALSE) return(MFAIL); } } if (reduced == 0) return(NOREDUCED_CLAUSE); else return(compress_clause(cst)); } struct clause *compress_clause(cst) /* cut c (c->c_form == NULL) */ struct clause *cst; { if (cst == NULL_CL) return(NULL); if (cst->c_form == NULL) return(compress_clause(cst->c_link)); else { cst->c_link = compress_clause(cst->c_link); return(cst); } } /************* print CPU time ******************************/ #if SUN4 == 1 /* print CPU time */ #include long TIMESAVE; /* system time saver (time_t = long) */ void printtime () { /* print CPU time from the previous settime()*/ long clock(); tprint2 ("CPU time = %.3lf sec (Constraints Handling = %.3lf sec)\n", ((double)(clock() - TIMESAVE))/ 1000000.0, ((double)CONSTRAINT_HANDLING_TIME/1000000.0)); } void settimer () { /* set clock */ long clock(); TIMESAVE = clock(); CONSTRAINT_HANDLING_TIME = 0L; } #else #if CPUTIME == 0 /* do not print CPU-time */ void printtime () { } void settimer () { } #else /* BSD */ #include #include time_t TIMESAVE; /* system time saver (time_t = long) */ struct tms TIMES; /* cf. times() */ /* * Structure returned by old times() interface * struct tms { * time_t tms_utime; user time * time_t tms_stime; system time * time_t tms_cutime; user time, children * time_t tms_cstime; system time, children * }; */ void printtime () { /* print CPU time from the previous settime()*/ time_t ttemp; times(&TIMES); /* get time */ ttemp = TIMES.tms_stime + TIMES.tms_utime; tprint2 ("CPU time = %.3lf sec (Constraints Handling = %.3lf sec)\n", (ttemp - TIMESAVE) / CPUTIME.0, (CONSTRAINT_HANDLING_TIME / CPUTIME.0)); } void settimer() { /* set clock */ times(&TIMES); TIMESAVE = TIMES.tms_stime + TIMES.tms_utime; CONSTRAINT_HANDLING_TIME = 0L; } #endif #endif *nc; if (cb == (struct component *)NULL) return(cb); MEMORY_ALLOC(nc,component,flag); nc->c_label = cb->c_label; nc->c_next src/makefile 644 10266 36 1054 5712121412 6437 # ICOT Free Software (IFS) 1992-95 # Constraint Logic Programming language cu-Prolog # Makefile for cup OBJECTS = main.o jpsgsub.o mainsub.o modular.o new.o print.o read.o\ refute.o unify.o defsysp.o syspred1.o\ syspred2.o trans.o tr_sub.o tr_split.o #CFLAGS = -g CFLAGS = -pg -g # for debug #CFLAGS = -O2 # for optimization #CFLAGS = -O4 #CC = gcc CC = cc FLAGS = -lm cup: $(OBJECTS) $(CC) $(CFLAGS) -o cup3 $(OBJECTS) $(FLAGS) $(OBJECTS): include.h main.o : version.h include.h : funclist.h varset.h globalv.h syspdef.h sysp.h ); preprocess_constr_sub(FALSE); NL; return; } arity = decode_pname(fn); if (! exist_fname(fn)) { tprint1("'%s' does not exist\n",fn); return; } if (arity == -1) { /* any arity */ for (f = hash_list[hash(fn)]; f != NULL; f = f->f_link) if (streq(f->f_name,fn)) preprocess_unit(f,TRUE); } else { f = funcsearch(fn,arity); if (f == NULL) { tprint2("'%s/%d' does not exist.\n",fn,arity); return; } preprocess_unsrc/modular.c 644 10266 36 50324 5712121411 6571 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << modular.c >> * constraint transformation entry, tools * 94.6.28 termset speedup --------------------------------------------------------------------*/ #include "include.h" #if SUN4 == 1 #include #else #if CPUTIME != 0 #include #include #endif #endif #define in_cheap(X) (( &cheap[0] <= ((int *)X)) && (((int *)X) < chp)) #define in_upper_heap(X,Y) ( in_sheap(X) || ( (Y==MEDIUM) && in_cheap(X)) ) long CONSTRAINT_OLD_TIME; /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ modular(c) @ mode entry ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void modular(c,vlist,anum) /* constraint trans. from top level (@) */ struct clause *c; struct term *vlist; int anum; { struct clause *sol; sol = startmodular(c, vlist, anum); /* tranformation */ tprint0("solution = "); if (sol == MFAIL){ /* fail transformation */ tprint0("fail.\n"); } else if (sol == NULL){ /* nil constraint */ tprint0("nil (true).\n"); } else /* c.t. success */ { Pclause(sol, NULL_ENV); NL; show_newdefs(); /* print DEF_list */ } } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ cu(t,e) process unify() built-in predicate ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ /* constraint transformation embedded in Prolog : unify() pred. */ int cu(t,e) /* 0: cu fail 1: success */ struct term *t; struct pair *e; { register struct pair *p, *q; struct pair *ee; struct term *tt; struct clause *c, *clist; #if CPUTIME != 0 struct tms TIMES; #endif if (t == NULL) return(TRUE); if (! isvar(Arg2(t))) return(FALSE); /* second arg = var */ p = &e[vnumber(Arg2(t))]; if (p->p_body != NULL) return(FALSE); /* second arg-->var */ #if SUN4 == 1 CONSTRAINT_OLD_TIME = clock(); #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_OLD_TIME = TIMES.tms_stime + TIMES.tms_utime; #endif #endif p->p_env = Nenv(0); /* cf. 'q' in termset() */ up_init(); tt = Arg1(t); ee = e; down(q,tt,ee); if (tt == NIL){ p->p_body = NIL; p->p_env = NULL; #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return(TRUE); } clist = c = Nclause(termset(head_of_list(tt),ee,TEMPORAL), NULL_CL,TEMPORAL); while (1) { tt = tail_of_list(tt); down(q,tt,ee); if ((tt == NIL) || (! is_list(tt))) break; c->c_link = Nclause(termset(head_of_list(tt),ee,TEMPORAL), NULL_CL,TEMPORAL); c = c->c_link; } if (tt != NIL) { up_restore(); p->p_env = NULL; error("Illegal form of constraint list."); } if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); q=Nenv(p_number); } up_restore(); c = startmodular(clist,v_list,v_number+p_number); /* transformation */ if (c == MFAIL){ /* fail transformation */ p->p_env = NULL; #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return(FALSE); /* fail */ } else if (c == NULL) { p->p_body = NIL; p->p_env = NULL; #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return(TRUE); } else { p->p_body = tolist(c,STINGY); TB tprint0(" ====> "); Pterm(p->p_body, p->p_env); TE #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return(TRUE); /* success */ } } /* change clause(t1,t2,t3) to list([t1,t2,t3]) <- cu() */ struct term *tolist(c,flag) struct clause *c; int flag; { register struct clause *cc, *croot; if (c == NULL) return(NIL); switch (flag) { case STINGY: for (cc = c; cc->c_link != NULL; cc=cc->c_link) cc->c_type = LIST_TYPE; cc->c_link = (struct clause *)NIL; return((struct term *)c); default: croot=cc=Nlist(head_of_list(c),(struct clause *)NIL,flag); while (c->c_link != NULL) { c=c->c_link; cc->c_link=Nlist(head_of_list(c),(struct clause *)NIL,flag); cc = cc->c_link; } return((struct term *)croot); } } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ transform(precond,newc,newenv) constriant solver of CAHC , called by resolve() in refute.c precond: old constraint (from goal) newc, newenv: new constraint (from program) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ /* constraint transformation entry <- resolve() */ struct eclause *transform(precond, newc, newenv) struct eclause *precond; struct clause *newc; struct pair *newenv; { struct eclause *eclause_append(); struct eclause *cond; struct clause *c,*clist; struct pair *env,*q; #if CPUTIME != 0 struct tms TIMES; #endif if (precond == NULL && newc == NULL) return(NULL); #if SUN4 == 1 CONSTRAINT_OLD_TIME = clock(); #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_OLD_TIME = TIMES.tms_stime + TIMES.tms_utime; #endif #endif cond = eclause_append(precond, reduce_clause(newc,newenv)); if (cond == (struct eclause *)MFAIL) /* reduce_clause failure */ { TB tprint0("fail (reducetion)"); TE return((struct eclause *)MFAIL); } env = Nenv(0); up_init(); clist = up_eclause(cond,MEDIUM); /* set clause */ up_restore(); if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); q=Nenv(p_number); /* 1991-03-10 */ } if (clist == NULL) { #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return(NULL); /* no constraint */ } TB tprint0(">>transform: "); Peclause(cond); tprint0(" ==> "); TE c = startmodular(clist,v_list,v_number+p_number); if (c == MFAIL) { /* constraint transformation failure */ TB tprint0("fail"); TE #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return((struct eclause *)MFAIL); } cond = reduce_clause(c,env); if (cond == NULL_ECL) { TB tprint0("null"); TE } else if (cond == (struct eclause *)MFAIL) { TB tprint0("fail (reduction)"); TE } else { TB Peclause(cond); TE } #if SUN4 == 1 CONSTRAINT_HANDLING_TIME += clock()-CONSTRAINT_OLD_TIME; #else #if CPUTIME != 0 times(&TIMES); CONSTRAINT_HANDLING_TIME += TIMES.tms_stime + TIMES.tms_utime - CONSTRAINT_OLD_TIME; #endif #endif return(cond); } struct eclause *eclause_append(head,tail) /* <- transform() */ register struct eclause *head, *tail; { if (head == (struct eclause *)MFAIL || tail == (struct eclause *)MFAIL) return((struct eclause *)MFAIL); while (head != NULL_ECL) { tail = Neclause(head->c_form,head->c_env,tail,TEMPORAL); head = head->c_link; } return(tail); } /* --------- term set ------------- */ /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ struct term *termset(t,e,flag) struct clause *up_eclause(ec,flag) make variant of terms with an environment Before termset, up_init() and after termset, up_restore(). Before termset, set p=Nenv(0), then p will be a unifier. ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct up_log { struct term *u_old,*u_new; struct pair *u_oldenv; struct up_log *u_link; }; struct ustack *ustack_save_up; /* save old usp */ int UHASHSIZE=17; struct up_log *UP_Log[17], *UP_pstLog[17]; int log_size(n) /* for debug */ int n; { register int i; register struct up_log *u; for (u=UP_Log[n],i=0; u!=NULL; u=u->u_link,i++); return(i); } int pstlog_size(n) /* for debug */ int n; { register int i; register struct up_log *u; for (u=UP_pstLog[n],i=0; u!=NULL; u=u->u_link,i++); return(i); } void initialize_log() { register int i; for (i=0; iu_old = oldt; u->u_new = newt; u->u_oldenv = oldenv; tt = tepairtype(oldt,oldenv); u->u_link = UP_Log[tt]; UP_Log[tt] = u; } struct term *search_log(t,e) /* search (t,e) in UP_log */ struct term *t; struct pair *e; { register struct up_log *u; for (u = UP_Log[tepairtype(t,e)]; u != NULL; u = u->u_link) if (u->u_old == t && u->u_oldenv == e) return(u->u_new); return(NULL); } void push_pstlog(oldt,oldenv,newt) struct term *oldt,*newt; struct pair *oldenv; { register struct up_log *u; register int tt; MEMORY_ALLOC(u,up_log,TEMPORAL); u->u_old = oldt; u->u_new = newt; u->u_oldenv = oldenv; tt = tepairtype(oldt,oldenv); u->u_link = UP_pstLog[tt]; UP_pstLog[tt] = u; } struct term *search_pstlog(t,e) /* search (t,e) in UP_log */ struct term *t; struct pair *e; { register struct up_log *u; for (u = UP_pstLog[tepairtype(t,e)]; u != NULL; u = u->u_link) if (u->u_old == t && u->u_oldenv == e) return(u->u_new); return(NULL); } void check_constant_term(t) struct term *t; { register int i; if (t->t_arity < 0) t->t_arity = - t->t_arity; for (i = 0; i < Pred(t)->f_arity; i++) if (! isconst(Arg(t,i))) return; t->t_arity = - t->t_arity; } /* term prepare for cu() : v_list and v_number are changed */ struct term *termset(t,e,flag) register struct term *t; register struct pair *e; int flag; { register struct pair *p,*q; register struct term *nt; if (t == NULL) return(t); down(p,t,e); if (p != NULL) { /* if t is a free var */ if (p == Anonymous_env) return(Anonymous_var); if (p->p_env == NULL) {/* if t is a new var */ /* use p->p_env as work area */ upush(&(p->p_env)); Nvar(vname(t),flag); p->p_env = (struct pair *)v_list; q = Nenv(1); q->p_body = t; q->p_env = e; return(v_list); } else{ ((struct var *)p->p_env)->v_occurrence++; return( (struct term *)p->p_env ); } } if (t->type.ident == PST_TYPE) return(up_pst(((struct pst *)t),e,flag)); if (flag==ETERNAL && (nt = search_log(t,e)) != NULL) return(nt); /* already set */ switch (t->type.ident) { case ATOMIC_TYPE: nt = up_atomic(t,flag); /* constant term */ break; case CLAUSE_TYPE: nt = (struct term *)Nclause(termset(head_of_list(t),e,flag), (struct clause *)termset(tail_of_list(t),e,flag),flag); break; case LIST_TYPE: case CONST_LIST_TYPE: nt = (struct term *)Nlist(termset(head_of_list(t),e,flag), (struct clause *)termset(tail_of_list(t),e,flag),flag); break; default: if (isconst_functor(t)) { nt = up_const_functor(t,flag); break; } nt = Nterm(t->t_arity,flag); nt->type.t_func = t->type.t_func; { register int i; for (i = 0; i < t->t_arity; i++) Arg(nt,i) = termset(Arg(t,i), e, flag); } check_constant_term(nt); /* check if nt is constant term */ } /* print_tepair_length(); */ if (flag == ETERNAL) push_log(t,e,nt); return(nt); } struct term *up_pst(pt,e,flag) struct pst *pt; struct pair *e; int flag; { struct pst_item *target; struct pst *nt; struct pstvar *pv; struct eclause *t0,*targetobj; struct pair *e0; struct term *oldt; if ((target = find_pstitem((struct term *)pt,e)) != NULL_PSTIT) { t0 = target->p_lists; e0 = NULL; if (flag==ETERNAL && (oldt = search_pstlog(t0,e0)) != NULL) return(oldt); targetobj = termset_pstobj(target->p_lists,flag); } else { t0 = pt->p_lists; e0 = e; if ((oldt = search_pstlog(t0,e0)) != NULL) return(oldt); targetobj = termset_pstobj_sub(pt->p_lists,e,flag); } MEMORY_ALLOC(nt,pst,flag); nt->type = PST_TYPE; MEMORY_ALLOC(pv,pstvar,flag); pv->v_type = VAR_PST_TYPE; pv->v_name = vname(Anonymous_var); pv->v_number = p_number++; pv->v_link = pv_list; pv->old_var = pt->p_var; nt->p_var = pv_list = (struct term *)pv; nt->p_lists = targetobj; if (flag == ETERNAL) push_pstlog(t0,e0,(struct term *)nt); return((struct term *)nt); } struct eclause *termset_pstobj(pobj,flag) struct eclause *pobj; int flag; { if (pobj==NULL_ECL) return(pobj); else return(Npstobj(termset(pobj->c_form,pobj->c_env,flag), NULL_ENV, termset_pstobj(pobj->c_link,flag), flag)); } struct eclause *termset_pstobj_sub(pobj,e,flag) struct eclause *pobj; struct pair *e; int flag; { struct eclause *pl, *ptop; if (pobj == NULL_ECL) return(pobj); ptop = pl = Npstobj(termset(pobj->c_form,e,flag), NULL_ENV,NULL_ECL,flag); while (pobj->c_link != NULL_ECL) { pl->c_link= Npstobj(termset(pobj->c_link->c_form,e,flag), NULL_ENV,NULL_ECL,flag); pobj = pobj->c_link; pl = pl->c_link; } return(ptop); } struct term *up_const(t,flag) register struct term *t; int flag; { struct term *up_atomic(), *up_const_functor(); if (in_upper_heap(t,flag)) return(t); switch (t->type.ident) { case ATOMIC_TYPE: return(up_atomic(t,flag)); case CONST_LIST_TYPE: return((struct term *)Nlist(up_const(head_of_list(t),flag), (struct clause *)up_const(tail_of_list(t),flag), flag)); default: /* functor */ return(up_const_functor(t,flag)); } } struct term *up_atomic(t,flag) register struct term *t; int flag; { register struct term *tt; if (flag == TEMPORAL || in_upper_heap(t,flag)) return(t); tt = Nterm(0,flag); tt->type.ident = t->type.ident; tt->t_arity = t->t_arity; if (is_int(t)) num_value(tt) = num_value(t); else if (! is_string(t)) num_value(tt) = num_value(t); else str_value(tt) = nalloc(str_value(t),flag); return(tt); } struct term *up_const_functor(t,flag) register struct term *t; int flag; { register struct term *tt; register int i; if (flag == TEMPORAL || in_upper_heap(t,flag)) return(t); i = -t->t_arity; if (i == 0) /* constant */ { tt = Nterm(0,flag); Pred(tt) = Pred(t); return(tt); } tt = Nterm(i,flag); Pred(tt) = Pred(t); tt->t_arity = -i; while (i > 0) { i--; Arg(tt,i) = up_const(Arg(t,i),flag); } return(tt); } struct clause *up_eclause(ec,flag) struct eclause *ec; int flag; { if (ec == NULL) return(NULL); return(Nclause(termset(ec->c_form, ec->c_env,flag), up_eclause(ec->c_link,flag), flag)); } struct clause *up_itrace_clause(cl,anum) struct clause *cl; int anum; { register struct variant *va; struct variant *variant(); va = variant(cl,ETERNAL); return(va->v_clause); } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ try_fold(c,n) try fold transformation c: clause n: # of vars + # of psts in c if there is H<=>C in new predicate derivation clauses and Cu=cu, return Hu (u is a variable replacement). else return NULL try_fold() is called by new_constraint() in trans.c . . . try_fold+ . . . . match+ . . . . . match_term+ . . . . termnumber ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct term *try_fold(c,n) /* fold transformation */ struct clause *c; /* target clause */ int n; /* # of different vars and psts in c */ { register struct itrace *it; struct ustack *usave; struct term *t,*head; struct pair *e; struct pair *esave = ep; int j, count,termnumber(); if (c == NULL) return(NULL); if (newf_list == NULL) return(NULL); count = literalnumber(c); /* number of terms in c */ usave = usp; esave = ep; e = Nenv(n); for (it = newf_list; it != NULL; it = it->it_link ) { if ((it->it_anumber == n) && (it->it_cnumber == count) ) if (match(c, it->it_clause->c_link, e) == FALSE) { undo(usave); ep = esave; continue; } else{ if (it->it_clause->c_form == FAIL) { undo(usave); ep = esave; return(FAIL); } head = it->it_clause->c_form; t = Nterm(Pred(head)->f_arity, MEDIUM); Pred(t) = Pred(head); for (j = 0; j < Pred(head)->f_arity ; j++) { Arg(t,j) = e[termnumber(Arg(head,j))].p_body; /* patch for PST var 1991-03-02 */ if (Arg(t,j)==NULL) Arg(t,j)=Anonymous_var; } undo(usave); ep = esave; /* patch 1991-03-03 */ return(t); /* found something */ } } return(NULL); } int termnumber(t) struct term *t; /* var or PST */ { if (isvar(t)) return(vnumber(t)); else if (is_pst(t)) return(vnumber( ((struct pst *)t)->p_var)); else printf("illegal term type : termnumber"); } int match(clo,clt,e) /* clause matcher */ struct clause *clo,*clt; struct pair *e; { register struct clause *c1,*c2; for (c1 = clo,c2 = clt; c1 != NULL ; c1 = c1->c_link,c2 = c2->c_link) if (Pred(c1->c_form) != Pred(c2->c_form)) return(FALSE); /* fail */ for (c1 = clo, c2 = clt; c1 != NULL; c1 = c1->c_link, c2 = c2->c_link) if (match_term(c1->c_form , c2->c_form , e) == FALSE) return(FALSE); return(TRUE); /* success */ } int match_term(t1,t2,e) /* term unification (t1,e) = (t2,e) */ struct term *t1,*t2; struct pair *e; /* return envs */ { register struct pair *p; if (isvar(t2)) { if (!isvar(t1)) return(FALSE); p = &e[vnumber(t2)]; if (p->p_body == NULL) { p->p_body = t1; return(TRUE); } else if(p->p_body == t1) return(TRUE); else return(FALSE); } else if (isvar(t1)) return(FALSE); if (Pred(t1) != Pred(t2)) return(FALSE); switch (t1->type.ident) { case ATOMIC_TYPE: if ((t1==t2) ||(atomic_equal(t1,t2))) return(TRUE); else return(FALSE); case LIST_TYPE: case CONST_LIST_TYPE: if (match_term(head_of_list(t1),head_of_list(t2),e) && match_term(tail_of_list(t1),tail_of_list(t2),e)) return(TRUE); else return(FALSE); case CLAUSE_TYPE: while ((t1!=NULL) && (t2!=NULL)) { if (match_term(head_of_list(t1),head_of_list(t2),e) == FALSE) return(FALSE); t1=tail_of_list(t1); t2=tail_of_list(t2); } if (t1==t2) return(TRUE); else return(FALSE); case PST_TYPE: if (t2->type.ident != PST_TYPE) return(FALSE); p = &e[termnumber(t2)]; if (p->p_body == NULL) { if (match_term((struct term *)((struct pst *)t1)->p_lists, (struct term *)((struct pst *)t2)->p_lists,e) == FALSE) return(FALSE); p->p_body = t1; return(TRUE); } else if (p->p_body == t1) return(TRUE); else if (p->p_body != t1) return(FALSE); case ECLAUSE_TYPE: /* pst_objects */ while ((t1!=NULL) && (t2!=NULL)) { if (match_term(((struct eclause *)t1)->c_form, ((struct eclause *)t2)->c_form,e) == FALSE) return(FALSE); t1=(struct term *)((struct eclause *)t1)->c_link; t2=(struct term *)((struct eclause *)t2)->c_link; } if (t1==t2) return(TRUE); else return(FALSE); default: { register int i,j = t1->t_arity; if (j < 0) j = -j; for(i = 0 ; it_arity; i++) Arg(nt,i) = termset(Arg(t,i), e, flag); } check_constant_term(nt); /* check if nt is constant term */ } /* print_tepair_length(); */ if (flag == ETERNAL) push_log(t,e,nt); return(nt); } struct term *up_pst(pt,e,flagsrc/new.c 644 10266 36 51434 5712121411 5722 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< new.c >>>> * memory management * 93.8.2 speedup * 94.6.28 speedup --------------------------------------------------------------------*/ #define DEBUG 0 /* if Debug 1 else 0 */ #define NEW 1 #include "include.h" #include /* struct allocation macro int a:arity */ int TERM_SIZE = (sizeof(struct term) / sizeof(int)); int FUNC_SIZE = (sizeof(struct func) / sizeof(int)); int POINTER_SIZE = (sizeof(struct term *) / sizeof(int)); #if SUN4 == 1 #define Termalloc(a) (struct term *)salloc(TERM_SIZE + a * POINTER_SIZE) #define tempterm(a) (struct term *)alloc(TERM_SIZE + a * POINTER_SIZE) #define mediterm(a) (struct term *)challoc(TERM_SIZE + a * POINTER_SIZE) #define funcalloc(a) (struct func *)salloc(FUNC_SIZE + a * POINTER_SIZE) #else #define Termalloc(a) (struct term *)salloc(TERM_SIZE + (a-1) * POINTER_SIZE) #define tempterm(a) (struct term *)alloc(TERM_SIZE + (a-1) * POINTER_SIZE) #define mediterm(a) (struct term *)challoc(TERM_SIZE + (a-1) * POINTER_SIZE) #define funcalloc(a) (struct func *)salloc(FUNC_SIZE + (a-1) * POINTER_SIZE) #endif void print_hash_table() /* for debug */ { register int i,empty=0,conflict=0; int conflict_max=0,total_length=0; float mean, d; register struct func *f; for (i = 0; i < HASH_SIZE; i++){ printf("[%d]",i); for (f = hash_list[i],conflict=0; f != NULL; f = f->f_link,conflict++) printf("%s/%d ",f->f_name,f->f_arity); putchar('\n'); total_length += conflict; if (conflict == 0) empty++; if (conflict_max < conflict) conflict_max=conflict; } mean = (float)total_length/(float)HASH_SIZE; for (i =d=0; i < HASH_SIZE; i++) { for (f = hash_list[i],conflict=0; f != NULL; f = f->f_link,conflict++) d+= (float)(conflict - mean)*(float)(conflict - mean)/HASH_SIZE; } printf("empty = %d/%d (%.2f), longest = %d, total=%d,\naverage_length=%.2f, d=%.3f\n", empty, HASH_SIZE, ((float)empty/(float)HASH_SIZE), conflict_max, total_length, ((float)total_length/(float)(HASH_SIZE-empty)), sqrt(d)); } int hash(fname) char *fname; { register int h = 0, factor; /* for (factor = strlen(fname) + 1; *fname != '\0'; fname++, factor--) */ /* for (factor = 1; *fname != '\0'; fname++, factor++) h+= ((*fname) * factor); */ for (; *fname != '\0'; fname++) h+= (unsigned char)(*fname); /* for EUC Kanji 94.10.27 */ if (h < 0) return(0); else return(h % HASH_SIZE); } int *salloc(n) /* system heap allocation */ register int n; { register int *p; #if DEBUG == 1 if (shp < SHEAPBOTTOM) error("system heap underflow"); #endif p = shp; shp += n; if (shp < SHEAPTOP) return(p); else error("system heap overflow"); } int *alloc(n) /* user heap allocation */ register int n; { register int *p; /* - hp */ p = hp; hp += n; #if DEBUG == 1 if (hp < HEAPBOTTOM){ sprintf(nbuf,"hp = %d : user heap underflow",hp); error(nbuf); } #endif if (hp < HEAPTOP) return(p); else error("user heap overflow"); } int *challoc(n) /* constraints/pst heap allocation */ register int n; { register int *p; p = chp; chp += n; #if DEBUG == 1 if (chp < CHEAPBOTTOM){ sprintf(nbuf,"chp = %d : constraints heap underflow",chp); error(nbuf); } #endif if (chp < CHEAPTOP) return(p); else error("constraints heap overflow"); } struct pair *ealloc(n) /* envionment stack allocation */ register int n; { register struct pair *p; p = ep; ep += n; #if DEBUG == 1 if (ep < eheap){ sprintf(nbuf,"ep = %d : environment stack underflow",ep); error(nbuf); } #endif if (ep < ESPTOP) return(p); else error("environment stack overflow"); } char *nalloc(n,flag) /* name string heap allocation */ register char *n; int flag; { register char *p; register int q; register struct func *f; if ((&nheap[0] <= n) && (n <= nhp)) return(n); if ((f = exist_fname(n)) != NULL) return(f->f_name); /* - nhp */ switch (flag) { case ETERNAL: case MEDIUM: q = strlen(n)+1; p = nhp; nhp += q; if(nhp > NHEAPTOP) error("name heap overflow"); break; default : /* TEMPORAL or STINGY */ q = strlen(n)+4; p = (char *)alloc(q / sizeof(int)); } strcpy(p,n); return(p); } struct term *Nnum(nbuf,flag) /* make number */ char *nbuf; int flag; { register struct term *n; float x; double atof(); MEMORY_ALLOC(n,term,flag); n->type.ident = ATOMIC_TYPE; sscanf(nbuf,"%f",&x); n->tag.n_value = x; if (x == ((float)((int)x))) n->t_arity = INT_NUM; else n->t_arity = FLOAT_NUM; return(n); } struct term *Nnum_val(x,flag) /* make a term representing x */ register float x; int flag; { register struct term *n; MEMORY_ALLOC(n,term,flag); n->type.ident = ATOMIC_TYPE; if (x == ((float)((int)x))) n->t_arity = INT_NUM; else n->t_arity = FLOAT_NUM; n->tag.n_value = x; return(n); } struct term *Nstr(x, flag) /* make a term representing x */ char *x; int flag; { register struct term *s; MEMORY_ALLOC(s,term,flag); s->type.ident = ATOMIC_TYPE; s->t_arity = STRING; if (flag==STINGY) flag=ETERNAL; s->tag.s_value = nalloc(x,flag); return(s); } struct pst *Npst(flag) int flag; { register struct pst *p; struct pstvar *pv; MEMORY_ALLOC(p,pst,flag); p->type = PST_TYPE; MEMORY_ALLOC(pv,pstvar,flag); pv->v_type = VAR_PST_TYPE; pv->v_name = vname(Anonymous_var); pv->v_number = p_number++; pv->v_link = pv_list; pv->old_var = NULL; p->p_var = pv_list = (struct term *)pv; p->p_lists = NULL_ECL; return(p); } struct eclause *Neclause(val,env,tail,flag) struct term *val; struct pair *env; struct eclause *tail; int flag; { struct eclause *obj; MEMORY_ALLOC(obj,eclause,flag); obj->c_type = ECLAUSE_TYPE; obj->c_env = env; obj->c_form = val; obj->c_link = tail; return(obj); } struct term *Npst_item(p,pobj,next) struct pair *p; struct eclause *pobj; struct pst_item *next; { struct pst_item *t; t = cnew(pst_item); t->p_var = p; t->p_lists = pobj; t->p_link = next; return((struct term *)t); } /* psttable (temporal PST area) functions */ /* initialize_psttable() clear_psttable() find_pstitem() remove_pstitem() remove_pstitem_if_not_equal() record_pstobjects() record_pstlists() */ int psttable_size() { int i; struct pst_item *pi; for (pi = psttable,i=0; pi != NULL; pi=pi->p_link,i++) ; return(i); } void initialize_psttable() { psttable = snew(pst_item); } void clear_psttable() { psttable->p_link = NULL_PSTIT; } struct pst_item *find_pstitem(t,e) struct term *t; struct pair *e; { register struct pair *p; register struct pst_item *table = psttable->p_link; if (e==NULL_ENV) return(NULL_PSTIT); t = ((struct pst *)t)->p_var; down(p,t,e); while (table != NULL_PSTIT) { if (table->p_var <= p) { if (table->p_var == p) return(table); else return(NULL_PSTIT); } table = table->p_link; } return(table); } /* remove (t,e) from psttable if it is not equal pitem */ struct pst_item *remove_pstitem_if_not_equal(t,e,pitem) struct term *t; struct pair *e; struct pst_item *pitem; { struct pst_item *object, *target; struct pair *p; if (e==NULL_ENV) /* 94.5.20 H.Tsuda*/ return(NULL_PSTIT); t = ((struct pst *)t)->p_var; down(p,t,e); target = psttable; while ((object = target->p_link) != NULL_PSTIT) { if (object->p_var <= p) { if (object->p_var == p) { if (object == pitem) return(pitem); /* doesn't remove */ upush(&(target->p_link)); target->p_link = object->p_link; return(object); } else return(NULL_PSTIT); } target = object; } return(object); } struct pst_item *remove_pstitem(t,e) /* remove (t,e) from psttable */ struct term *t; struct pair *e; { return( remove_pstitem_if_not_equal(t,e, NULL_PSTIT) ); } struct pst_item *record_pstobjects(t,e) struct pst *t; struct pair *e; { struct pst_item *entry = psttable; struct term *tt = t->p_var; struct pair *p; down(p,tt,e); while(entry->p_link != NULL_PSTIT) { if (p > entry->p_link->p_var) break; entry = entry->p_link; } upush(&(entry->p_link)); entry->p_link = (struct pst_item *) Npst_item(p,NULL_ECL,entry->p_link); entry = entry->p_link; entry->p_lists = record_pstlists(t->p_lists,e); /* printf("PSTtable size = %d\n",psttable_size()); */ return(entry); } struct eclause *record_pstlists(ptt,e) struct eclause *ptt; struct pair *e; { struct eclause *props, *pre; if (ptt == NULL_ECL) return(ptt); pre = props = Npstobj(ptt->c_form, e, NULL_ECL, MEDIUM); for (ptt = ptt->c_link; ptt != NULL_ECL; ) { props->c_link = Npstobj(ptt->c_form, e, NULL_ECL, MEDIUM); props = props->c_link; ptt = ptt->c_link; } return(pre); } /* ------------------------- */ struct term *Nfile(x) FILE *x; { register struct term *t; t = cnew(term); t->type.ident = ATOMIC_TYPE; t->t_arity = FILE_POINTER; t->tag.f_value = x; return(t); } struct term *Nvar(nbuf,flag) /* make new var */ char *nbuf; int flag; { register struct var *v; /* + nbuf */ /* - v_number, v_list, shp */ MEMORY_ALLOC(v,var,flag); v->v_type = VAR_GLOBAL_TYPE; v->v_number = v_number++; v->v_name = (nbuf==Anonymous_VarName) ? Anonymous_VarName : nalloc(nbuf,flag); v->v_link = (struct var *)v_list; v_list = (struct term *)v; v->v_constraint = NULL_CL; /* for CAHC 89.6.16 */ v->v_component = (struct component *)NULL; v->v_head_occur = 0; /* var occurrence in the head */ v->v_occurrence = 1; /* var occurrence */ return(v_list); } struct term *varsearch(varname) /* search varname in v_list */ char *varname; { register struct term *v; for (v = v_list; v != NULL; v = vlink(v)) if (streq(varname, vname(v))) { ((struct var *)v)->v_occurrence++; return(v); } return(NULL); } void reset_voccurrence(v) /* all v_occurrence = 0 */ register struct term *v; { while (v != NULL_TERM) { ((struct var *)v)->v_occurrence = 0; v = vlink(v); } } /* move v_occurrence->v_head_occur, v_occurrence=0*/ void move_voccurrence(v) register struct term *v; { while (v != NULL_TERM) { ((struct var *)v)->v_head_occur = ((struct var *)v)->v_occurrence; ((struct var *)v)->v_occurrence = 0; v = vlink(v); } } void recalc_voccur_sub(t) /* subroutine for recacl_voccurrence() */ struct term *t; { if (t == NULL_TERM || isconst(t)) return; switch (t->type.ident) { case VAR_VOID_TYPE: /* var */ case VAR_GLOBAL_TYPE: ((struct var *)t)->v_occurrence++; case VAR_PST_TYPE: case ATOMIC_TYPE: case CONST_LIST_TYPE: return; case PST_TYPE: { register struct eclause *ec; for (ec=(struct eclause *)((struct pst *)t)->p_lists; ec != NULL_ECL; ec=ec->c_link) recalc_voccur_sub(Arg2(ec->c_form)); return; } /* case ECLAUSE_TYPE: register struct eclause *ec; for (ec=(struct eclause *)t; ec != NULL_ECL; ec=ec->c_link) recalc_voccur_sub(Arg2(ec->c_form)); return; */ case CLAUSE_TYPE: case LIST_TYPE: recalc_voccur_sub(head_of_list(t)); recalc_voccur_sub(tail_of_list(t)); return; default: /* complex term */ { register int i, j=Pred(t)->f_arity; for (i = 0; i < j; i++) recalc_voccur_sub(Arg(t,i)); } } } void decrement_vacuous(t) /* decrement voccurrence of vacuous position */ struct term *t; { register struct func *f; register int i; register struct term *arg; if (isvar(t)) return; /* 94.12.2 call(X):-X. */ for (f = Pred(t),i = f->f_arity - 1; i >= 0; i--) { arg = Arg(t,i); if (isvar(arg) && Component(f,i) == NULL) vdecrement(arg); } } void recalc_voccurrence(cl,v) /* cl == H :- C. */ struct clause *cl; struct term *v; { register struct clause *c; if (cl == NULL_CL || v == NULL_TERM) return; reset_voccurrence(v); /* all voccurrence=0 */ recalc_voccur_sub(cl->c_form); /* check head */ move_voccurrence(v); /* body var -> head var */ for (c = cl->c_link; c != NULL; c = c->c_link) /* check body */ recalc_voccur_sub(c->c_form); for (c = cl->c_link; c != NULL; c = c->c_link) /* vacuous vars */ decrement_vacuous(c->c_form); } struct func *exist_fname(fname) /* search predicate name */ char *fname; { register struct func *f; for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link) if (streq(fname,f->f_name)) return(f); return(NULL); } struct func *Predicate(fname, arity) /* search fname/arity */ char *fname; /* if not exist, make Nfunc */ int arity; { register struct func *f; f = funcsearch(fname,arity); if (f == NULL) return(Nfunc(USERFUN,fname,arity)); else return(f); } struct func *funcsearch(fname, arity) /* search fname/arity */ char *fname; int arity; { register struct func *f; register int compare; for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link) { if ((compare = strcmp(fname,f->f_name)) > 0) return(NULL); if ((compare == 0) && (f->f_arity == arity)) return(f); } return(NULL); } int pred_compare(f1,f2) /* pred compare -1 <, 0: =, 1 > */ struct func *f1,*f2; { register int cmp; cmp = strcmp(f1->f_name,f2->f_name); if (cmp != 0) return(cmp); return(f2->f_arity - f1->f_arity); } void index_func(fnew) /* store predicate fnew into hash-table */ struct func *fnew; { struct func *flist; register struct func *f, *flast; int i = hash(fnew->f_name); flist = hash_list[i]; if ((flist == NULL) || (pred_compare(fnew,flist) > 0)) { hash_list[i] = fnew; fnew->f_link = flist; return; } for (flast=flist, f=flist->f_link; f != NULL; flast = f, f = f->f_link) { i = pred_compare(fnew,f); if (i > 0) break; if (i==0) { /* sprintf(nbuf,"function `%s' is already used",fnew->f_name); error(nbuf); */ return; } } flast->f_link = fnew; fnew->f_link = f; return; } struct itrace *index_newflist(fl,it) struct itrace *fl,*it; { register struct itrace *t, *top, *s, *temp; if (fl==it) return(fl); top = temp = new(itrace); for (t=fl; t != it; t=t->it_link) { if (in_sheap(t)) { temp->it_link = t; temp = t; } else { temp->it_link = s = snew(itrace); s->it_anumber = t->it_anumber; s->it_cnumber = t->it_cnumber; temp = s; } temp->it_clause = up_itrace_clause(t->it_clause,t->it_anumber); } temp->it_link=it; return(top->it_link); } struct operator *op_search(fname,otype) char *fname; register int otype; { register struct operator *o; register struct func *f; f = (otype != INFIX) ? funcsearch(fname,1) : funcsearch(fname,2); if (f == NULL) return(NULL); for (o=o_list; o != NULL; o=o->o_link) if ((f == o->o_func) && (otype == (o->o_type & INFIX))) return(o); return(NULL); } struct func *Nfunc(ftype, n, a) /* make new function */ int ftype; /* predicate type in include.h */ char *n; /* functor name */ int a; /* arity */ { register struct func *f, *ff; int i; /* - FNUMBER, const_list,f_list, shp */ f = funcalloc(a); f->f_arity = a; f->f_name = nalloc(n,ETERNAL); f->f_setcount = 0; /* number of def clauses */ f->f_unitcount = 0; /* number of unit clauses */ f->def.f_set = NULL; f->f_number = FNUMBER++; f->f_integ = NULL; if (ftype != TEMPFUN) { f->f_mark = (a > 0) ? (ftype | VACUITY_NOCHECK) : ftype; index_func(f); } else { f->f_mark = (a > 0) ? (USERFUN | VACUITY_NOCHECK) : USERFUN; ff = f_list; f_list = f; f->f_link = ff; } for (i = 0; i < a; i++) Component(f,i)=NULL; return(f); } struct term *Nterm(n,flag) int n; /* arity */ int flag; { struct term *t; /* alloc term in sheap */ /* if (n > VMAX) error("Too many arguments"); */ switch (flag) { case TEMPORAL: t = tempterm(n); break; case ETERNAL: case STINGY: t = Termalloc(n); break; default: /* MEDIUM */ t = mediterm(n); } t->t_arity = n; return(t); } struct pair *Nenv(n) /* new environment for n vars */ register int n; { register struct pair *p; register int i; p = ealloc(n); for(i = 0; i < n; i++) { p[i].p_body = NULL; p[i].p_env = NULL; } return(p); } struct clause *Nlist(head,body,flag) struct term *head; struct clause *body; int flag; { register struct clause *c; MEMORY_ALLOC(c,clause,flag); c->c_type = (novar(head) && ((body == (struct clause *)NIL) || (body->c_type == CONST_LIST_TYPE))) ? CONST_LIST_TYPE : LIST_TYPE; c->c_form = head; c->c_link = body; return(c); } struct clause *Nclause(head,body,flag) struct term *head; struct clause *body; int flag; { register struct clause *c; MEMORY_ALLOC(c,clause,flag); c->c_type = CLAUSE_TYPE; c->c_form = head; c->c_link = body; return(c); } struct set *setconcat(slist, s) /* add s to the end of slist */ struct set *slist,*s; { register struct set *ss; if (slist == NULL) return(s); for(ss = slist; ss->s_link != NULL; ss = ss->s_link) ; ss->s_link = s; return(slist); } int literalnumber(c) /* number of literals in c */ register struct clause *c; { register int i; for (i = 0; c != NULL; c = c->c_link, i++); return(i); } int is_ground(t) /* check whether t is ground. */ struct term *t; { if (t == NULL_TERM || isconst(t)) return(TRUE); switch (t->type.ident) { case VAR_VOID_TYPE: /* var */ case VAR_PST_TYPE: case ATOMIC_TYPE: case CONST_LIST_TYPE: return(TRUE); case VAR_GLOBAL_TYPE: case PST_TYPE: return(FALSE); case CLAUSE_TYPE: case LIST_TYPE: if (is_ground(head_of_list(t)) && is_ground(tail_of_list(t))) return(TRUE); else return(FALSE); default: /* complex term */ { register int i, j=Pred(t)->f_arity; for (i = 0; i < j; i++) if (is_ground(Arg(t,i)) == FALSE) return(FALSE); return(TRUE); } } } void index_set(chead,con,flag) struct clause *chead, *con; char flag; { struct set *s; if (issystem(Pred(chead->c_form))) { sprintf(nbuf,"Caution!! : %s is a system predicate.\n", Pred(chead->c_form)->f_name); error(nbuf); } s = snew(set); s->s_clause = chead; recalc_voccurrence(chead, v_list); s->s_vlist = v_list; s->s_anumber = v_number+p_number; s->s_constraint = con; s->s_link = NULL; s->s_ground_head = is_ground(chead->c_form); /* head is ground? */ add_set(s,flag); } void add_set(s,flag) /* add definition s to the end */ struct set *s; char flag; /* 'a' or 'z' */ { register struct func *f = s->s_clause->c_form->type.t_func; struct set *setconcat(); /* check set_bodynumber */ s->s_bodynumber = literalnumber(s->s_clause->c_link); if (flag == 'z') f->def.f_set = setconcat(f->def.f_set, s); else { s->s_link = f->def.f_set; f->def.f_set = s; } f->f_setcount++; if is_unitclause(s) f->f_unitcount++; /* add_f_cbind(s->s_clause->c_form); *//* calc f_cbind[] */ Def_Modified = 1; /* def modified flag (global v.) */ } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ user stack operations: upush(), undo() ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void upush(p) register int *p; { /* - usp */ if (p == NULL) return; usp->u_addr = p; (usp++)->u_val = *p; /* for MS-DOS large model *//* #if MSDOS == 2 usp->u_addr = p + 1; (usp++)->u_val = *(p + 1); #endif */ #if DEBUG == 1 if (p < HEAPBOTTOM || p > HEAPTOP) error("out of range in upush"); if (usp < STACKBOTTOM) error("user stack underflow"); #endif if (usp > STACKTOP) error("user stack overflow"); } void undo(u) register struct ustack *u; { /* - usp */ #if DEBUG == 1 if (u < STACKBOTTOM) error("user stack underpop"); #endif /* if (u > usp) error("user stack overpop"); if (usp > Stack_Max) Stack_Max = usp; if (chp > Cheap_Max) Cheap_Max = chp; if (hp > Heap_Max) Heap_Max = hp; if (ep > Esp_Max) Esp_Max = ep; =====> backtrack_node() */ while(usp > u) { --usp; #if DEBUG == 1 if (usp->u_addr < HEAPBOTTOM || usp->u_addr > HEAPTOP) fprintf(stderr, " over heap (undo)%x/%x\n",usp,STACKBOTTOM); #endif if (usp->u_addr == NULL) return; else *(usp->u_addr) = usp->u_val; } } calc_voccur_sub(c->c_form); for (c = cl->c_link; c != NULL; c = c->c_link) /* vacuous vars */ decrement_vacuous(c->c_form); } struct func *exist_fname(fname) /* search predicate name */ char *fname; { register struct funcsrc/print.c 644 10266 36 40460 5712121411 6262 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< print.c >>>>>> * print out routine --------------------------------------------------------------------*/ #define DEBUG 0 /* when debug, 1 */ #include "include.h" void Pterm_core(),Peclause_core(),Pclause_core(),Pcahc_core(); void init_pp(),scanpst_term(),scanpst_clause(),scanpst_eclause(),print_pp(); int pp_number(); /* global vars */ int PST_PRINT_NUM; /* # of different psts */ /* Classification of Characters */ #define BL 001 /* blank */ #define UC 002 /* Upper Character */ #define LC 003 /* Lower Character */ #define UL 004 /* UnderLine */ #define N 005 /* Numeric */ #define SG 006 /* sign, +- */ #define SP 007 /* special character */ #define Q 010 /* single/double quote */ #define CT 011 /* Cut */ #define CM 012 /* comment character */ #define BR 013 /* Brackets, Commas */ #define CO 014 /* Constraint Marker */ #define kanzi(CH) (CH < 0) /* for EUC */ #define alphabet(CH) ((char_type[CH] <= N) || (char_type[CH] >= UC)) #define is_lower(CH) ((kanzi(CH)) || (char_type[CH] == LC)) /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * print basic structures: * Pterm(t,e) * Peclause(ec) : print eclause * Pclause(c,e): print clause with delimiter ',' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void Pterm(t,e) /* print term */ struct term *t; struct pair *e; { init_pp(); scanpst_term(t,e); Pterm_core(t,e,Print_Depth); if(PST_PRINT_NUM > 1) { tputc(';'); print_pp(Print_Depth); /* $1={...},$2={...},.. */ } } void Peclause(ec) /* print eclause */ struct eclause *ec; { init_pp(); scanpst_eclause(ec); Peclause_core(ec,Print_Depth); if(PST_PRINT_NUM > 1) { tputc(';'); print_pp(Print_Depth); } } void Pclause(c,e) /* print clause */ struct clause *c; struct pair *e; { init_pp(); scanpst_clause(c,e); Pclause_core(c,e); if(PST_PRINT_NUM > 1) { tputc(';'); print_pp(Print_Depth); } } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * showhorn(body,constraint,env): print CAHC ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void Showhorn(c,cst,e) /* Show horn clause */ register struct clause *c,*cst; register struct pair *e; { void P_hclause(); if (cst == NULL_CL) P_hclause(c,e); else { init_pp(); scanpst_clause(c,e); scanpst_clause(cst,e); Pcahc_core(c,cst,e); /* H:-Body;Constraint */ if (PST_PRINT_NUM > 1) { tputc(','); print_pp(Print_Depth); } tputc('.'); } } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * Pgoal(n) : print goal in refutation ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void Pgoal(n) /* print goal in refute() */ struct node *n; { init_pp(); scanpst_clause(n->n_clause, n->n_env); scanpst_eclause(n->n_constraint); Psequence(n->n_clause,n->n_env,Print_Depth); if (n->n_constraint != NULL_ECL) { tputc(';'); Peclause_core(n->n_constraint,Print_Depth); if(PST_PRINT_NUM > 1) { tputc(','); print_pp(Print_Depth); } } else if(PST_PRINT_NUM > 1) { tputc(';'); print_pp(Print_Depth); } } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * Showfunc(func): print definition of a predicate ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void Showfunc(f) /* Show definitions of function *f */ register struct func *f; { register struct set *ts; if (isuser(f)) { for (ts = f->def.f_set; ts != NULL; ts = ts->s_link) { Showhorn(ts->s_clause, ts->s_constraint, NULL_ENV); #if DEBUG == 1 printf("(an=%d bn=%d)",ts->s_anumber,ts->s_bodynumber); #endif NL; } } } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * P_hclause(cl,e): print Horn clause ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void P_hclause_sub(cl,e) /* H:-C1,C2,...Cn */ struct clause *cl; struct pair *e; { register struct clause *c; Pterm_core(cl->c_form,e,Print_Depth); c = cl->c_link; if (c != NULL) { tprint0(" :- "); Pclause_core(c,e); } } void P_hclause(cl,e) struct clause *cl; struct pair *e; { register struct clause *c; init_pp(); scanpst_clause(cl,e); P_hclause_sub(cl,e,Print_Depth); if (PST_PRINT_NUM > 1) { tputc(';'); print_pp(Print_Depth); } tputc('.'); } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * P_dclause(cl,e): print derivation clause of unfold/fold trans. ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void P_dclause(cl,e) struct clause *cl; struct pair *e; { register struct clause *c; init_pp(); scanpst_clause(cl,e); Pterm_core(cl->c_form,e,Print_Depth); c = cl->c_link; if (c != NULL) { tprint0(" <=> "); Pclause_core(c,e); } if (PST_PRINT_NUM > 1) { tputc(','); print_pp(Print_Depth); } tputc('.'); } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * Shownewfunc(): print itrace ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void Shownewfunc() /* Show def of new functions constructed in integrate */ { register struct itrace *it; for (it = newf_list; it != NULL; it = it->it_link){ tprint2("<%d,%d> ",it->it_anumber,it->it_cnumber); P_dclause(it->it_clause,NULL); NL; } } /* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * writenewfunc(): print itrace to file ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void writenewfunc() { register struct itrace *it; register struct func *f; if (newf_list == NULL) return; for (it = newf_list; it != NULL; it = it->it_link){ f = it->it_clause->c_form->type.t_func; if (isnoreduced(f) && (f->def.f_set != NULL)) { tprint0("$ "); P_dclause(it->it_clause,NULL); NL; } } } /* ------------------ local functions ---------------------- */ int quote_needed(f) /* need quote? */ struct func *f; { register char *n = f->f_name; if (f == CUT_P) return(FALSE); if (! is_lower(*n)) return(TRUE); for ( ; *n != '\0'; n++) { if (kanzi(*n)) n++; else if (! alphabet(*n)) return(TRUE); } return(FALSE); } void Pvar(t, n) /* print var with env, as "t_n" */ register struct term *t; int n; { if (((struct var *)t)->v_type==VAR_VOID_TYPE) tputc('_') else if (streq(vname(t),"_")) tprint1("_%u",n) else { tprint2("%s_%u",vname(t),n); #if DEBUG == 1 tprint2("",vheadoccurrence(t),voccurrence(t)); #endif } } void Pclause_core(c,e) /* print clause main */ struct clause *c; struct pair *e; { if (c == NULL) return; for (;;) { Pterm_core(c->c_form,e,Print_Depth); c = c->c_link; if (c == NULL) return; tprint0(", "); } } void Pcahc_core(c,cst,e) /* print CAHC main */ register struct clause *c,*cst; register struct pair *e; { Pterm_core(c->c_form,e,Print_Depth); /* print head */ if (c->c_link != NULL) { /* print body */ tprint0(":-"); Psequence(c->c_link,e,0); /* 0 means infinity */ } if (cst != NULL){ /* print constraint */ tprint0("; "); Psequence(cst,e,0); } /* tputc('.'); */ } void Pterm_core(t,e,d) /* print term main */ register struct term *t; register struct pair *e; int d; { register struct pair *p; if (t == NULL) { if (e == NULL) { tprint0("nil"); return; } else return; /* print nothing */ } if (isvar(t)) { if (e == NULL) { Pvar(t, vnumber(t)); return; } down(p,t,e); if(p != NULL) { /* if t is not var */ Pvar(t, (int)(p - eheap)); /* print its name with env */ return; } } /* print literal */ if (t == NIL) { /* if t is NIL list ([]) */ tprint0("[]"); return; } if (!(--d)) { tprint0("???"); return; } #if DEBUG == 1 if (isatom(t)) printf("~"); else { if(t->type.ident < 100) printf("",t,e,t->type.ident); else printf("",t,e); } #endif switch (t->type.ident) { /* case VAR_VOID_TYPE: case VAR_PST_TYPE: case VAR_GLOBAL_TYPE: */ /* already checked in the above */ case ATOMIC_TYPE: /* atomic */ switch (t->t_arity) { case FLOAT_NUM : tprint1("%f",num_value(t)); /* float */ return; case INT_NUM : tprint1("%d",(int)(num_value(t))); /* int */ return; case STRING : tprint1("\"%s\"", str_value(t)); /* string */ return; default : tprint1("#%x", str_value(t)); /* file */ return; } case PST_TYPE: /* pst */ /* tputc('{');*/ Ppst(t,e,d); /* tputc('}'); */ return; case CLAUSE_TYPE: /* clause */ tputc('('); Psequence((struct clause *)t,e,d); tputc(')'); return; case ECLAUSE_TYPE: /* eclaues */ Peclause_core(t,d); return; case LIST_TYPE: case CONST_LIST_TYPE: /* list */ tputc('['); Psequence((struct clause *)t,e,d); tputc(']'); return; default: /* complex term */ Pfunctor(t,e,d); return; } } void Pfunctor(t,e,d) /* print complex term */ register struct term *t; register struct pair *e; int d; { register struct func *f = t->type.t_func; /* f is functor of t */ register int i, arity = f->f_arity; struct operator *o; if ((arity == 2) || (arity == 1)) { for(o = o_list; o != NULL; o=o->o_link) if (o->o_func == f) { switch (o->o_type & INFIX) { case INFIX: Pterm_core(Arg(t,0),e,d); tprint1("%s",f->f_name); Pterm_core(Arg(t,1),e,d); return; case PREFIX: tprint1("%s ",f->f_name); Pterm_core(Arg(t,0),e,d); return; case POSTFIX: Pterm_core(Arg(t,0),e,d); tprint1(" %s",f->f_name); return; } } } /* print functor name */ if (quote_needed(f)) tprint1("\'%s\'", f->f_name) else tprint1("%s", f->f_name); if(t->t_arity==0) return; /* if t is const */ tputc('('); /* print args */ i=0; while (1) { Pterm_core(Arg(t,i), e,d); /* print one arg */ if(++i >= arity) { tputc(')'); break; } tprint0(", "); } } void Ppst_content(ptt,d) /* {l1/v1,l2/v2,...} temporal PST*/ struct eclause *ptt; { tputc('{'); while (ptt->c_link != NULL_ECL) { Pterm_core(ptt->c_form, ptt->c_env,d); tprint0(", "); ptt = ptt->c_link; } Pterm_core(ptt->c_form, ptt->c_env,d); tputc('}'); } /* patch 92/1/22 by H.Tsuda */ void Ppst_content2(ptt,env,d) /* {l1/v1,l2/v2,...} static PST with env */ struct eclause *ptt; struct pair *env; { tputc('{'); while (ptt->c_link != NULL_ECL) { Pterm_core(ptt->c_form, env,d); tprint0(", "); ptt = ptt->c_link; } Pterm_core(ptt->c_form,env,d); tputc('}'); } void Ppst(t,e,d) /* print pst (in Pterm_core) */ struct term *t; /* actually, (struct pst *) */ struct pair *e; int d; { register struct eclause *ptt = ((struct pst *)t)->p_lists; struct pst_item *target; int n; target = find_pstitem(t,e); if (target != NULL_PSTIT) { /* print temporal PST */ ptt = target->p_lists; if (ptt == NULL_ECL) { tprint0("{}"); return; } #if DEBUG == 1 printf("",ptt); #endif n = pp_number(ptt); if (n > 0) { /* called more than once!! */ tprint1("_p%d",n); return; } Ppst_content(ptt,d); /* print temporal PST */ } else { /* print (static) PST in program */ if (ptt == NULL_ECL) { tprint0("{}"); return; } #if DEBUG == 1 printf("",ptt); #endif n = pp_number(ptt); if (n > 0) { /* called more than once!! */ tprint1("_p%d",n); return; } Ppst_content2(ptt,e,d); /* print static PST with env */ } } void Peclause_core(ec,d) /* print eclause main */ struct eclause *ec; int d; { if (ec == NULL) return; while (1) { Pterm_core(ec->c_form, ec->c_env,d); ec = ec->c_link; if (ec == NULL) return; tputc(','); } } void Psequence(t,e,d) /* print content of list t */ struct clause *t; register struct pair *e; int d; { register struct pair *p; register struct term *tt = (struct term *)t; if ((tt == NULL) || (tt == NIL)) return; while (1) { Pterm_core(t->c_form,e,d); /* print the first argument */ t = t->c_link; tt = (struct term *)t; if (tt == NULL) return; if (isvar(tt)) { if (e == NULL) { tprint0(" | "); Pvar(tt, vnumber(tt)); return; } down(p, tt, e); if (p != NULL) { /* if tt is variable */ tprint0(" | "); Pvar(tt, (int)(p - eheap)); return; } } if (! (is_list(tt) || is_clause(tt))) { if (tt == NIL) return; tprint0(" | "); Pterm_core(tt,e,d); return; } tputc(','); t = (struct clause *)tt; } } /* ------------- functions for PST pretty print --------------- */ struct pstprint { struct eclause *pp_ec; int pp_num; struct pstprint *pp_link; }; struct pstprint *PST_PRINT_LIST; /* pst save entry */ void init_pp() { PST_PRINT_LIST = NULL; PST_PRINT_NUM = 1; } void print_pp(d) /* $1={...},$2={...},... */ int d; /* printing depth */ { register struct pstprint *pp; int printed = 0; for(pp = PST_PRINT_LIST; pp !=NULL; pp=pp->pp_link) { if (pp->pp_num != 0){ if (printed != 0) tputc(',') else printed=1; tprint1("_p%d=",pp->pp_num); Ppst_content(pp->pp_ec,d); } } } int pp_number(ec) /* print PST number */ struct eclause *ec; { register struct pstprint *pp,*ppn; for (pp = PST_PRINT_LIST; pp != NULL; pp = pp->pp_link) if (pp->pp_ec == ec) return(pp->pp_num); return(0); } void scanpst_term(t,e) /* scan PST in a term */ register struct term *t; register struct pair *e; { register struct pair *p; void addpst(),scanpst_functor(); if (t == NULL) return; if (isvar(t)) { if (e == NULL) return; down(p,t,e); if(p != NULL) return; } if (t == NIL) return; /* if t is NIL list ([]) */ switch (t->type.ident) { case ATOMIC_TYPE: /* atomic */ return; case PST_TYPE: /* pst */ addpst(t,e); return; case CLAUSE_TYPE: /* clause */ scanpst_clause((struct clause *)t,e); return; case ECLAUSE_TYPE: /* eclaues */ scanpst_eclause((struct eclause *)t); case LIST_TYPE: case CONST_LIST_TYPE: /* list */ scanpst_clause((struct clause *)t,e); return; default: /* complex term */ scanpst_functor(t,e); return; } } void scanpst_clause(t,e) /* modify Psequence() */ struct clause *t; struct pair *e; { register struct pair *p; register struct term *tt = (struct term *)t; if ((tt == NULL) || (tt == NIL)) return; while (1) { scanpst_term(t->c_form,e); /* scan the first argument */ t = t->c_link; tt = (struct term *)t; if (tt == NULL) return; if (isvar(tt)) { if (e == NULL) return; down(p, tt, e); if (p != NULL) return; } if (! (is_list(tt) || is_clause(tt))) { if (tt == NIL) return; scanpst_term(tt,e); return; } t = (struct clause *)tt; } } void scanpst_eclause(ec) struct eclause *ec; { if (ec == NULL_ECL) return; scanpst_term(ec->c_form,ec->c_env); scanpst_eclause(ec->c_link); } void scanpst_functor(t,e) struct term *t; struct pair *e; { int i,arity; arity = t->t_arity; for (i = 0; i < arity; i++) scanpst_term(Arg(t,i),e); } void addpst(t,e) struct term *t; struct pair *e; { register struct eclause *ptt = ((struct pst *)t)->p_lists; struct pst_item *target; struct pstprint *pp,*ppnew; target = find_pstitem(t,e); if (target != NULL_PSTIT) ptt = target->p_lists; if (ptt == NULL_ECL) return; for (pp = PST_PRINT_LIST; pp != NULL; pp = pp->pp_link) if (pp->pp_ec == ptt) { if (pp->pp_num == 0) pp->pp_num = PST_PRINT_NUM++; return; } MEMORY_ALLOC(ppnew,pstprint,TEMPORAL); ppnew->pp_ec = ptt; ppnew->pp_num = 0; ppnew->pp_link = PST_PRINT_LIST; PST_PRINT_LIST = ppnew; } /* ------------- functions for debug ------------------- */ void P_var(vlist) /* for debug */ struct term *vlist; { register struct term *v; for (v = vlist; v != NULL; v = vlink(v)) { printf("%s-(%d)-",vname(v),v->type.ident); Pclause_core(vconstraint(v),NULL); NL; } } void showvar(v) /* show variable (for debug) */ struct term *v; { putchar('('); while (v != NULL) { printf("%s ",vname(v)); v = vlink(v); } putchar(')'); } e VAR_VOID_TYPE: case VAR_PST_TYPE: case VAR_GLOBAL_TYPE: */ /* already checked in the above */ case ATOMIC_TYPE: /* atomic */ switch (t->t_arity) { case FLOAT_NUM : tprint1("%src/read.c 644 10266 36 35773 5712121411 6054 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< read.c >>>> * input routines * 94.8.10 unsigned char for Kanji input --------------------------------------------------------------------*/ #include "include.h" /* Classification of Characters */ #define BL 001 /* blank */ #define UC 002 /* Upper Character */ #define LC 003 /* Lower Character */ #define UL 004 /* UnderLine */ #define N 005 /* Numeric */ #define SG 006 /* sign, +- */ #define SP 007 /* special character */ #define Q 010 /* single/double quote */ #define CT 011 /* Cut */ #define CM 012 /* comment character */ #define BR 013 /* Brackets, Commas */ #define CO 014 /* Constraint Marker */ #define kanzi(CH) (CH > 128) /* for EUC */ #define alpha (kanzi(cbuf) || ((UC <= char_type[cbuf]) && \ (char_type[cbuf] <= N))) /* special characters are #$%&*+-/:<=>?@\^|~ */ #define specialchar(C) ((! kanzi(C)) && ((char_type[C] == SG) || \ (char_type[C] == SP))) #define delimitchar(C) ((! kanzi(C)) && ((char_type[C] >= BR) || (C == '.'))) #define bracket(C) ((! kanzi(C)) && (char_type[C] == BR)) #define quotesign ((! kanzi(cbuf)) && (char_type[cbuf] == Q)) #define white ((! kanzi(cbuf)) && (char_type[cbuf] == BL)) #define numeric(X) ((X == '-') || ((! kanzi(X)) && (char_type[X]==N))) #define isdigit(X) ((! kanzi(X)) && (char_type[X]==N)) #define isxdigit(X) ((! kanzi(X)) && ((char_type[X]==N) || \ ((char_type[X] == LC) && ('a' <= X) && (X <= 'f')) || \ ((char_type[X] == UC) && ('A' <= X) && (X <= 'F')))) #define is_varname(X) ((X == '_') || ((! kanzi(X)) && (char_type[X]==UC))) #define notconst_list(L) (((struct clause *)L)->c_type != CONST_LIST_TYPE) #define isconst_list(L) (((struct clause *)L)->c_type == CONST_LIST_TYPE) /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ Rterm(num,flag) general read routine entry num: operator strength flag: heap mode (TEMPORAL,ETERNAL,...) +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct term *Rterm(n,flag) int n,flag; { int m = 0; struct term *Rterm_half(),*Rterm_leftover(); struct term *t = Rterm_half(n,flag,&m); t = Rterm_leftover(n,m,flag,t); if ((is_clause(t)) && (((struct clause *)t)->c_link == NULL)) return(((struct clause *)t)->c_form); return(t); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ next() get next char into cbuf (global char register) +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void next() { if (feof(fp)) { clearerr(fp); cbuf = EOF; return; } if (ferror(fp)) { clearerr(fp); error("input error !"); } cbuf = getc(fp); if (lfp) putc(cbuf,lfp); /* log file */ if (ECHO_BACK) putc(cbuf, wfp); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ int check(c) check whether next input is c +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int check(c) /* check if c is cbuf */ char c; { if(cbuf == c) { advance; return(TRUE); } else return(FALSE); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ int keyread(a) check whether user's input is 'a....\n' +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int keyread(a) char a; { int c,c1; c = c1 = getchar(); while (c1 != '\n') c1 = getchar(); if (lfp) fprintf(lfp,"\n"); if (c == a) return(TRUE); else return(FALSE); } void adv() /* skip white and set the next char into cbuf */ { while(white) next(); } int skip(c) /* skip c */ char c; { if(cbuf != c){ wfp = stderr; tprint2("\n '%c' <-> '%c'", cbuf, c); error(" illegal character "); } advance; return(cbuf); } int alldigit(c) register unsigned char *c; { if ( c[0] >= 0x80 ) return(FALSE); if (! numeric(*c)) return(FALSE); for( c++ ; *c!='\0' ; c++ ) if (! isdigit(*c)) return(FALSE); return(TRUE); } void read_hexa(i) register int i; { for(i=0; isxdigit(cbuf); next()) if (i < NAMELEN_MAX) nbuf[i++]=cbuf; nbuf[i]='\0'; } void read_digits(i) register int i; { for( ; isdigit(cbuf); next()) if (i < NAMELEN_MAX) nbuf[i++] = cbuf; if (cbuf=='.') do { nbuf[i++] = cbuf; next(); } while((isdigit(cbuf)) && (i < NAMELEN_MAX)); if ((cbuf == 'e') || (cbuf == 'E')) { nbuf[i++] = 'E'; next(); if ((cbuf == '-') || isdigit(cbuf)) do { nbuf[i++] = cbuf; next(); } while((isdigit(cbuf)) && (i < NAMELEN_MAX)); } nbuf[i]='\0'; } void read_comments() { while (1) { next(); if (cbuf == '*') { next(); if (cbuf == '/') {advance; return;} } } } void read_spechar(i) register int i; { while (specialchar(cbuf) && (i < NAMELEN_MAX)) { nbuf[i++] = cbuf; next(); } nbuf[i]='\0'; } int Rtoken() /* read name into nbuf[] */ { if (reread) { reread = FALSE; return(tokentype); } adv(); if (cbuf==EOF) { set_eof(); error("unexpected End Of File"); } if (bracket(cbuf)) /* ()[]{}|, */ { if (cbuf==',') return(tokentype = COMMA); nbuf[0] = cbuf; nbuf[1] = '\0'; return(tokentype = BRACKET); } if (! kanzi(cbuf)) { /* if (char_type[cbuf] == CO) return(tokentype = CONST_MARK); */ if (char_type[cbuf] == CM) { skipline; return(Rtoken()); } } tokentype = NAME; if (isdigit(cbuf)) { read_digits(0); return(tokentype = NUMBER); } if (alpha) { register int i = 0; if (is_varname(cbuf)) tokentype = VARNAME; while(alpha && (i < NAMELEN_MAX)){ if (kanzi(cbuf)) { nbuf[i++] = cbuf; next(); } nbuf[i++] = cbuf; next(); } nbuf[i]='\0'; return(tokentype); } if (quotesign) { register char temp = cbuf; register int i; if (temp == '\"') tokentype = STRING; next(); for (i = 0; i < NAMELEN_MAX; next()) { if (cbuf != temp) nbuf[i++]=cbuf; else { next(); if (cbuf == temp) nbuf[i++]=cbuf; else break; } } if (i >= NAMELEN_MAX) { nbuf[i]='\0'; wfp = stderr; sprintf(nbuf,">>> %s <<<",nbuf); error("too long string/name"); } nbuf[i]='\0'; return(tokentype); } if (cbuf == '!') { nbuf[0] = cbuf; nbuf[1] = '\0'; next(); return(tokentype); } if (char_type[cbuf] == CO) { nbuf[0] = cbuf; nbuf[1] = '\0'; next(); return(tokentype); } if (specialchar(cbuf)) { register int i = 0; nbuf[i++] = cbuf; next(); switch (nbuf[0]) { case '-': if (isdigit(cbuf)) { tokentype = NUMBER; read_digits(i); } else read_spechar(i); break; case '/': if (cbuf == '*') { read_comments(); return(Rtoken()); } else read_spechar(i); break; case '#': if (isxdigit(cbuf)) { tokentype = FILE_TYPE; read_hexa(i); } else read_spechar(i); break; case '.': if (white) tokentype = FULLSTOP; else read_spechar(i); break; default: read_spechar(i); } } else { sprintf(nbuf,"Illegal Character:>>> %c <<<",cbuf); error(nbuf); } return(tokentype); } struct term *Rlist(flag) /* read list */ int flag; { register struct term *v; register struct clause *c; int ac; advance; /* skip [ */ if (cbuf == ']') { /* [] */ return(NIL); } /* read the first argument */ c = Nlist(Rterm(999,flag),(struct clause *)NIL,flag); ac = c->c_type; switch (Rtoken()) { case COMMA: c->c_link = (struct clause *)Rlist(flag); if (notconst_list(c->c_link)) c->c_type = LIST_TYPE; return((struct term *)c); case BRACKET: if (nbuf[0]=='|') { advance; v = Rterm(999,flag); c->c_link = (struct clause *)v; if (isvar(v) || notconst_list(v)) c->c_type = LIST_TYPE; return((struct term *)c); } else { reread = TRUE; return((struct term *)c); } default: error("Illegal list : ? "); } } struct term *Rpst(flag) /* pst */ int flag; { struct term *p = (struct term *)Npst(flag); struct term *t; struct eclause *pobj = NULL_ECL; while (1) { advance; if (cbuf == '}') return(p); t = Rterm(999, flag); if (Pred(t) != PNAME_P) { error_detail(t,NULL_ENV, "Illegal PST: Delimiter of PST should be '/'"); } if ((! is_functor(Arg1(t)) || (Arg1(t)->t_arity != 0))) { error_detail(t,NULL_ENV, "Illegal PST: PNAME of PST should be ATOM"); } pobj = insert_pstobj(t,pobj,flag); switch (Rtoken()) { case COMMA: break; case BRACKET: reread = TRUE; ((struct pst *)p)->p_lists = pobj; return(p); default: sprintf(nbuf,"Illegal pst : >>> %c <<<",cbuf); error(nbuf); } } } struct eclause *insert_pstobj(val,tail,flag) struct term *val; struct eclause *tail; int flag; { struct eclause *pre, *ptop = tail; register int f,i; if (! is_functor(Arg1(val))) { error_detail(Arg1(val),NULL_ENV, "Illegal Property name for PST"); } if (tail == NULL_ECL) return(Npstobj(val,NULL_ENV,tail,flag)); pre = tail; f = Pred(Arg1(val))->f_number; while (tail != NULL_ECL) { i = Pred(Arg1(tail->c_form))->f_number - f; if (i > 0) { if (pre == tail) return(Npstobj(val,NULL_ENV,tail,flag)); else break; } if (i==0) { wfp = stderr; Pterm(Arg1(tail->c_form),NULL_ENV); NL; Pterm(Arg1(val),NULL_ENV); error("ERROR: There are same PNAMES in PST"); } pre = tail; tail = tail->c_link; } pre->c_link = Npstobj(val,NULL_ENV,tail,flag); return(ptop); } int is_term_end(c) register char c; { switch(c) { case '.': case ')': case '|' : case ',': case ';': case ']': return(TRUE); default: return(FALSE); } } int prefix_is_atom(m) int m; { switch(tokentype) { case FULLSTOP: return(TRUE); case COMMA: case BRACKET: return(is_term_end(nbuf[0])); case NAME: { register struct operator *o; if ((o = op_search(nbuf,INFIX)) != NULL) if ((o->o_prec - ((o->o_type & 0010) != 0)) >= m) return(TRUE); if ((o = op_search(nbuf,POSTFIX)) != NULL) if ((o->o_prec - ((o->o_type & 0010) != 0)) >= m) return(TRUE); } default: return(FALSE); } } struct term *Rterm_half(n,flag,m) int n, flag, *m; { register struct term *t; char tempname[NAMELEN_MAX]; int ac = CONSTANT_TERM; switch (Rtoken()) { case BRACKET: switch (nbuf[0]) { case '[': t = ((struct term *)Rlist(flag)); if ((Rtoken() != BRACKET) || nbuf[0] != ']') { error_detail(t,NULL_ENV,"Syntax error --- ] missing"); } advance; return(t); case '(': advance; t = Rterm(1200,flag); if ((Rtoken() != BRACKET) || nbuf[0] != ')') { error_detail(t,NULL_ENV,"Syntax error --- ) missing"); } advance; if (is_clause(t)) { struct clause *c = (struct clause *)t; return((c->c_link == NULL) ? c->c_form : t); } else return(t); case '{': t = (struct term *)Rpst(flag); if ((Rtoken() != BRACKET) || nbuf[0] != '}') { error_detail(t,NULL_ENV,"Syntax error --- } missing"); } advance; return(t); default : sprintf(nbuf,"Syntax Error: unexpected >>> %c <<<",nbuf[0]); error(nbuf); } case VARNAME: /* variable */ if (streq(nbuf, "_")) return(Anonymous_var); if((t = varsearch(nbuf))==NULL) return(Nvar(nbuf,flag)); else return(t); case NUMBER: /* number */ return(Nnum(nbuf,flag)); case STRING: /* string */ return(Nstr(nbuf,flag)); case FILE_TYPE: { /* file pointer */ int pt; sscanf(nbuf,"%x",&pt); return(Nfile((FILE *)pt)); } case NAME: /* name */ strcpy(tempname,nbuf); /* tempname <- nbuf */ /* constant or functor */ if (check('(')) { register int i,arity = 0; struct clause *temp, *argstack; argstack = temp = Nclause(NULL_TERM,NULL_CL,TEMPORAL); while(1) { reread = FALSE; /* read term */ t = Rterm(999,flag); if (notconst(t)) ac = NOT_CONSTANT_TERM; temp->c_link = Nclause(t,NULL_CL,TEMPORAL); temp = temp->c_link; arity++; if (tokentype != COMMA) break; advance; } skip(')'); t = Nterm(arity,flag); if (ac==CONSTANT_TERM) t->t_arity = -arity; t->type.t_func = Predicate(tempname,arity); temp = argstack; for(i=0; i < arity; i++) { temp = temp->c_link; t->tag.t_arg[i] = temp->c_form; } return(t); } { struct operator *o; if ((o = op_search(tempname, PREFIX)) == NULL) { t = Nterm(0,flag); t->type.t_func = Predicate(tempname,0); return(t); } if (o->o_prec > n) { sprintf(nbuf,"Syntax Error:>>> %s <<<",tempname); error(nbuf); } Rtoken(); reread=TRUE; if (prefix_is_atom(o->o_prec)) { if (*m > n) error("Syntax error"); t = Nterm(0,flag); t->type.t_func = Predicate(tempname,0); return(t); } (t = Nterm(1,flag))->type.t_func = o->o_func; Arg1(t) = Rterm((o->o_prec - o->o_type + PREFIX),flag); *m = o->o_prec; if (isconst(Arg1(t))) t->t_arity = -t->t_arity; return(t); } default: /* else */ sprintf(nbuf,"Syntax error --- unexpected %c",cbuf); error(nbuf); } } struct term *Rterm_leftover(n,m,flag,t) register int n,flag,m; struct term *t; { struct operator *o; int ac = (notconst(t)) ? NOT_CONSTANT_TERM : CONSTANT_TERM; switch(Rtoken()) { case NAME: reread=FALSE; if ((o = op_search(nbuf,INFIX)) != NULL) { if ((o->o_prec <= n) && ((o->o_prec - ((o->o_type & 0010) ? 1 : 0)) >= m)) { struct term *tt = Nterm(2,flag); tt->type.t_func = o->o_func; Arg1(tt) = t; Arg2(tt) = Rterm(o->o_prec - (o->o_type & 0001), flag); if ((ac == CONSTANT_TERM) && (isconst(Arg2(tt)))) tt->t_arity = -tt->t_arity; return(Rterm_leftover(n,o->o_prec,flag,tt)); } } if ((o = op_search(nbuf,POSTFIX)) != NULL) { if ((o->o_prec <= n) && (o->o_prec >= (m + ((o->o_type & 0010) ? 1 : 0)))) { struct term *tt = Nterm(1,flag); tt->type.t_func = o->o_func; Arg1(tt) = t; if (ac == CONSTANT_TERM) tt->t_arity = -tt->t_arity; return(Rterm_leftover(n,o->o_prec,flag,tt)); } } case FULLSTOP: reread = TRUE; return(t); case BRACKET: switch(nbuf[0]) { case '(': case '[': sprintf(nbuf,"Syntax Error:>>> %c <<<",nbuf[0]); error(nbuf); } return(t); case COMMA: if ((n >= 1000) && (m < 1000)) { struct term *tt; advance; tt = Rterm(1000,flag); reread = TRUE; if (! is_clause(tt)) tt=(struct term *)Nclause(tt,NULL_CL,flag); t = (struct term *)Nclause(t,(struct clause *)tt,flag); if (n > 1000) return(Rterm_leftover(n,1000,flag,t)); } default: return(t); } } t(cbusrc/refute.c 644 10266 36 27455 5712121411 6431 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< refute.c >>>> * Prolog refutation --------------------------------------------------------------------*/ #include "include.h" #include #define is_dead(n) (n->n_set == NULL) #define is_tip(n) (n->n_clause == NULL) #define is_root(n) (n->n_link == NULL) struct node *Psolution(), *extend(), *proceed_node(); struct node *Newnode(),*backtrack_node(); struct set *init_set(); void Trace_True(),Trace_False(),Trace_Unification(),Trace_Answer(); void Trace_True2(), Trace_False2(); int Trace_Goal(); void Pbinding(); /* [refute]----------------------------------- . backtrack_node . . Trace_False2 . Trace_False . Trace_Goal . . print_ancestors+ . Trace_True . is_dead. . extend . . [system_function] . . init_set . . resolve+ . . . [tunify] . . . Trace_Unification . is_tip. . proceed_node . . Trace_True2. . . next_goal+ . . have_nextgoal+ */ /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ Prolog refutation entry +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int refute(Root,n,Status) struct node *Root, *n; int Status; /* UP,DOWN,BACKTRACK */ { struct node *m; while(1) { if (n == NULL || n->n_spy) if (Trace_Goal(n)==FALSE) return(FALSE); m = extend(n, Status); if (!is_dead(n)) Last_BT = n; if (m == NULL_NODE) /* fail */ { if (n->n_spy) Trace_False(n); if (n == Root) return(FALSE); Status = BACKTRACK; Last_BT = n = backtrack_node(n->n_last); } else if (is_tip(m)) /* nil clause */ { if (n->n_spy) Trace_True(n); Status = UP; n = proceed_node(m,Last_BT); if (n == NULL_NODE) return(TRUE); } else { Status = DOWN; n = m; } } } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ head unification +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct node *extend(n, status) /* extend goal */ struct node *n; int status; { register struct term *sliteral; /* selected literal */ struct node *m; register struct pair *p,*env; if (n->n_count > Refcount) { tprint1(" <<%d] fail! (over refute counter)\n",n->n_count); return(NULL); /* counter over = fail */ } if (is_tip(n)) return(n); /* no goal */ sliteral = n->n_clause->c_form; env = n->n_env; down(p,sliteral,env); if (p != NULL) return(NULL); /* goal is real var */ m = Newnode(NULL_CL,n->n_constraint, NULL_ENV,n,n); if (is_funcsys(sliteral->type.t_func)) /* functional syspred */ { if (system_function(sliteral, env, n) == SYSFAIL) return(NULL); else { n->n_set = (struct set *)NULL; return(m); } } if (is_nofuncsys(sliteral->type.t_func)) /* sys pred. */ { if (system_pred(sliteral, env, n, m, status) == SYSFAIL) return(NULL); else { return(m); } /* n->n_set may be DUMMY_DEF */ } if (is_dead(n)) return(NULL); if (resolve(n, m, sliteral, env) == FALSE) return(NULL); /* user pred.: resolution */ m->n_usp = usp; m->n_hp = hp; m->n_ep = ep; m->n_set = init_set(m); return(m); } int resolve(n0, n, sliteral, env) /* resolution: called by extend() */ struct node *n0,*n; struct term *sliteral; struct pair *env; { struct ustack *usave; int *hsave,tunify_apply(); struct pair *esave; register struct set *s; register struct eclause *ec; usave = usp;hsave = hp;esave = ep; STAT_REFUTE++; /* statistics */ for (s = n0->n_set; s != NULL; s = s->s_link) { if (s->s_ground_head) /* no variable/PST in the head */ { if (tunify(sliteral, env, s->s_clause->c_form, NULL_ENV,0) == FALSE) { STAT_BACKTRACK_SHAL++; /* statistics */ hp = hsave; ep = esave; continue; } if (s->s_anumber > 0) n->n_env = Nenv((int)s->s_anumber); /* body environment */ } else { if (s->s_anumber > 0) n->n_env = Nenv((int)s->s_anumber); /* head&body env */ if (tunify_apply(sliteral, env, s->s_clause->c_form, n->n_env,0) == FALSE){ /* undo(usave); */ hp = hsave; ep = esave; STAT_BACKTRACK_SHAL++; /* statistics */ continue; } } ec = transform(n0->n_constraint, s->s_constraint, n->n_env); if (ec == (struct eclause *)MFAIL) { /* constraint transformation failure */ undo(usave);hp = hsave; ep = esave; continue; } n->n_constraint = ec; n0->n_scount++; if (n->n_spy) Trace_Unification(n0,s); n0->n_set = s->s_link; n->n_clause = s->s_clause->c_link; return(TRUE); } return(FALSE); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ make and process node +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct node *Newnode(goal, icons, env, nlink, nlast) struct clause *goal; struct eclause *icons; struct pair *env; struct node *nlink, *nlast; { register struct node *n; n = new(node); n->n_last = nlast; /* backtrack node */ n->n_link = nlink; /* mother node */ n->n_clause = goal; /* goal */ n->n_env = env; n->n_hp = hp; n->n_ep = ep; n->n_usp = usp; if (nlink == NULL_NODE) n->n_count = 0; else n->n_count = nlink->n_count + 1; n->n_tmp = 0; n->n_scount = 0; n->n_constraint = icons; if (goal == NULL_CL) { n->n_set = (struct set *)NULL; n->n_spy = 0; } else n->n_set = init_set(n); return(n); } struct set *init_set(n) register struct node *n; { register struct term *t; register struct func *f; register struct pair *e,*p; register struct set *s; if (n->n_clause == NULL_CL) return((struct set *)NULL); t = n->n_clause->c_form; e = n->n_env; down(p,t,e); if (p != NULL) return(NULL); /* goal is var */ f = t->type.t_func; n->n_spy = Is_Trace && isspy(f); if (isuser(f)) { if (((s = f->def.f_set) == (struct set *)NULL) && (Handle_Undefined == TRUE)) { sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name); error(nbuf); } else return(s); } else return((struct set *)NULL); } struct node *backtrack_node(n) /* restore stack, heap */ struct node *n; { if (usp > Stack_Max) Stack_Max = usp; if (chp > Cheap_Max) Cheap_Max = chp; if (hp > Heap_Max) Heap_Max = hp; if (ep > Esp_Max) Esp_Max = ep; STAT_BACKTRACK_DEEP++; /* statistics */ while (n != NULL_NODE) { if (n->n_spy) Trace_False2(n); if(! is_dead(n)) { undo(n->n_usp); hp = n->n_hp; ep = n->n_ep; return(n); } n = n->n_last; } return(NULL_NODE); } struct node *proceed_node(n,btnode) struct node *n,*btnode; { register struct node *m; int have_nextgoal(); struct node *next_goal(); for (m = n; m != NULL; m = m->n_link) { if (m->n_spy) Trace_True2(m); if (have_nextgoal(m->n_clause)) return(next_goal(m,n,btnode)); } return(NULL_NODE); } int have_nextgoal(c) /* called by proceed_node() */ register struct clause *c; { if (c != NULL_CL && c->c_link != NULL_CL) return(TRUE); else return(FALSE); } struct node *next_goal(m,oldnode,btnode) /* called by proceed_node() */ struct node *m, *oldnode,*btnode; { struct node *n; n = Newnode(m->n_clause->c_link, oldnode->n_constraint, m->n_env, m->n_link, btnode); n->n_count = oldnode->n_count +1; return(n); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ print answer & binding +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int Panswer(root, vlist) /* print solution */ struct node *root; struct term *vlist; { if (!Is_Notrace) Trace_Answer(root); Pbinding(vlist, root->n_env); if (root->n_constraint != NULL_ECL) { tprint0("\n where "); Peclause(root->n_constraint); } if (Last_BT == NULL) { tprint0("\n"); return(FALSE); /* no backtrack point */ } if ((fp != stdin) || (!keyread(';'))) return(FALSE); return(TRUE); /* more solution */ } void Pbinding(vlist, env) /* print var binding */ struct term *vlist; struct pair *env; { if (vlist == NULL_TERM) return; Pbinding(vlink(vlist),env); if ((strcmp(vname(vlist),"_") == 0) || (vlist->type.ident == VAR_PST_TYPE)) return; tprint1(" %s = ",vname(vlist)); Pterm(vlist,env); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ trace --- interaction with user +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int Trace_Goal(n) struct node *n; { void print_ancestors(); if (n == NULL) return(FALSE); if (Is_Notrace) return(TRUE); if (Last_SKIP == n) Last_SKIP = NULL_NODE; if (Last_SKIP != NULL_NODE) return(TRUE); tprint1(" [%d>>",n->n_count); Pgoal(n); if ((Is_Steptrace) || (Is_Leap && (n->n_spy))) { Steptrace_mode; while(1) { tprint0(" #"); switch (getchar()) { case 'a' : case 'A' : print_ancestors(n); getchar(); break; case 'b' : case 'B' : { int *hsave; struct pair *esave; struct ustack *usave = utop; hsave = hp; esave = ep; utop = usp; if (setjmp(unbreak_reset)) { utop = usave; hp = hsave; ep = esave; break; } while(1) { prolog_execution(); } } case 'z' : case 'Z' : case 'q' : case 'Q' : NL; tprint0("\n Execution Abort \n"); longjmp(reset,0); case '?' : case 'h' : case 'H' : tprint0("\na : ancestors\tb : break\th : help\tl : leap\ts : skip\n"); tprint0(" : next\tq: abort\tf : fail return\n"); getchar(); break; case 'f' : case 'F' : return(FALSE); case 'l' : case 'L' : tflag = 3; return(TRUE); case 's' : case 'S' : Last_SKIP = n; return(TRUE); default : Last_SKIP = NULL_NODE; return(TRUE); } } } else NL; return(TRUE); } void Trace_False(n) struct node *n; { struct func *f; struct pair *p, *e; struct term *t; if (Is_Leap) Steptrace_mode; if (Last_SKIP == n) Last_SKIP = NULL_NODE; if (Last_SKIP != NULL_NODE) return; t = n->n_clause->c_form; if (isvar(t)) { e = n->n_env; down(p,t,e); } f = t->type.t_func; if (is_funcsys(f)) { tprint2(" <<%d] false (%s)\n",n->n_count,f->f_name); } else if (is_nofuncsys(f)) { tprint2(" <<%d] fail (%s)\n",n->n_count,f->f_name); } else /* user pred */ { tprint2(" <=%d-no= fail %s.\n",n->n_count,f->f_name); } } void Trace_True(n) struct node *n; { struct func *f; struct term *t; struct pair *p, *e; if (Is_Leap) Steptrace_mode; if (Last_SKIP == n) Last_SKIP = NULL_NODE; if (Last_SKIP != NULL_NODE) return; t = n->n_clause->c_form; e = n->n_env; down(p,t,e); f = t->type.t_func; if (isuser(f)) return; tprint1(" <<%d] ",n->n_count); if (is_funcsys(f)) { tprint1("true (%s)\n",f->f_name); } else { tprint1("success (%s)\n",f->f_name); } } void Trace_False2(n) struct node *n; { if (Is_Leap) Steptrace_mode; if (Last_SKIP == n){ tprint1(" <<%d] fail\n",n->n_count); Last_SKIP = NULL_NODE; } } void Trace_True2(n) struct node *n; { if (Last_SKIP == n){ /* tprint1(" <<%d] true",n->n_count); */ Last_SKIP = NULL_NODE; } } void Trace_Unification(n,s) struct node *n; struct set *s; { if (Is_Leap) Steptrace_mode; if (Last_SKIP != NULL_NODE) return; tprint2(" <=%d-%d=",n->n_count, n->n_scount); Showhorn(s->s_clause, s->s_constraint, NULL_ENV); NL; } void Trace_Answer(root) struct node *root; { Last_SKIP = NULL_NODE; tprint0("success.\n"); Pclause(root->n_clause, root->n_env); if (root->n_constraint != NULL_ECL) { tprint0(" ; "); Peclause(root->n_constraint); } NL; } void print_ancestors(n) /* called by Trace_goal() */ struct node *n; { while (n != NULL) { tprint1(" [%d>>",n->n_count); Pgoal(n); NL; n = n->n_link; } } } else return(t); case '{': t = (struct term *)Rpst(flag); if ((Rtoken() != BRACKET) || nbuf[0] != '}') { error_detail(t,NULL_ENV,"Syntax error --- } missing"); } advance; return(t); desrc/sysp.h 644 10266 36 7042 5712121411 6110 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << sysp.h >> * (system predicate external reference) --------------------------------------------------------------------*/ /* functions included in cu-prolog */ extern struct func *ABOLISH_P; extern struct func *ARG_P; extern struct func *APND_P; extern struct func *ASSERT_P; /* assert */ extern struct func *ASSERTA_P; /* asserta */ extern struct func *ASSERTZ_P; /* assertz */ extern struct func *ATTACH_P; extern struct func *CAT_P; extern struct func *CLAUSE_P; extern struct func *CLOSE_P; extern struct func *CMP_P; extern struct func *CNAME_P; extern struct func *CONCAT_P; extern struct func *CONCAT2_P; extern struct func *COUNT_P; /* count */ extern struct func *CUT_P; extern struct func *DEFAULT_P; extern struct func *DIVSTR_P; extern struct func *EOF_P; extern struct func *EQUAL_P; /* equal (=) */ extern struct func *EQ_P; /* eq (==) */ extern struct func *EXECUTE_P; extern struct func *FAIL_P; extern struct func *FUNCTOR_P; extern struct func *GENSYM_P; extern struct func *GEQ_P; extern struct func *GREATER_P; extern struct func *HALT_P; extern struct func *ISOP_P; extern struct func *INTEG_P; /* integrate */ extern struct func *LESS_P; extern struct func *LEQ_P; extern struct func *MULTIPLY_P; extern struct func *MAKELIST_P; /* =.. */ extern struct func *MODULAR_P; /* modlarize */ extern struct func *MULTIPLY_P; extern struct func *NAME_P; /* name */ extern struct func *NEQ_P; /* not-equal */ extern struct func *NL_P; /* nl */ extern struct func *OP_P; extern struct func *OPEN_P; extern struct func *OR_P; extern struct func *PROJECT_P; /* print constraint */ extern struct func *PCONSTRAINT_P; /* print constraint */ extern struct func *PCONSTRAINT2_P; extern struct func *READ_P; /* read */ extern struct func *RETRACT_P; /* retract */ extern struct func *SEE_P; extern struct func *SEEN_P; extern struct func *SUBSTR_P; extern struct func *STAY_P; extern struct func *STRCMP_P; extern struct func *STRLEN_P; extern struct func *SUM_P; extern struct func *T_P; extern struct func *TAB_P; extern struct func *TELL_P; extern struct func *TOLD_P; extern struct func *TREE_P; extern struct func *TRUE_P; extern struct func *UNBREAK_P; extern struct func *VAR_P; extern struct func *WRITE_P; /* write */ /* operators */ extern struct func *DEF_P; extern struct func *QUERY1_P; extern struct func *QUERY2_P; extern struct func *NOT_P; extern struct func *EQSIGN_P; extern struct func *MKLIST_P; extern struct func *CONSTRAINT_P; extern struct func *CONSTRAINT2_P; extern struct func *GREATER2_P; extern struct func *GEQ2_P; extern struct func *LESS2_P; extern struct func *LEQ2_P; extern struct func *EQUAL2_P; extern struct func *EQ2_P; extern struct func *PNAME_P; /* functions included in cu-prolog */ extern struct func *LIST, *CUNIFY; extern struct term *NIL, *FAIL; extern struct func *PNAMES_P; extern struct func *PVALUE_P; extern struct func *TYPE_P; extern struct func *RESET_TIMER_P; extern struct func *TIMER_P; eyread(';'))) return(FALSE); return(TRUE); /* more solution */ } void Pbinding(vlist, env) /* print var binding */ struct term *vlist; struct pair *env; { if (vlist == NULL_TERM) return; Pbinding(vlink(vlist),env); if ((strcmp(vname(vlist),"_") == 0) || (vlist->type.ident == VAR_PST_TYPE)) return; tprint1(" %s = ",vname(vlist)); Pterm(vlist,env); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ trace --- interaction with user ++++++++++++++src/syspdef.h 644 10266 36 5144 5712121411 6570 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <> * initialize system predicate variable --------------------------------------------------------------------*/ /* system predicate in cu-Prolog */ struct func *ABOMB_P; struct func *ABOLISH_P; struct func *APND_P; struct func *ARG_P; struct func *ASSERTA_P; struct func *ASSERTZ_P; struct func *ASSERT_P; struct func *ATTACH_P; struct func *ATOMTOSTR_P; struct func *CAT_P; struct func *CLAUSE_P; struct func *CLOSE_P; struct func *CMP_P; struct func *CNAME_P; struct func *CONCAT2_P; struct func *CONCAT_P; struct func *COUNT_P; struct func *CUT_P; struct func *DEFAULT_P; struct func *DIVSTR_P; struct func *EQUAL_P; struct func *EQ_P; struct func *EXECUTE_P; struct func *FAIL_P; struct func *FUNCTOR_P; struct func *GENSYM_P; struct func *GEQ_P; struct func *GREATER_P; struct func *HALT_P; struct func *ISOP_P; struct func *INTEG_P; struct func *LESS_P; struct func *LEQ_P; struct func *MAKELIST_P; struct func *MEMB_P; struct func *MODULAR_P; struct func *MULTIPLY_P; struct func *NAME_P; struct func *NEQ_P; struct func *NL_P; struct func *OP_P; struct func *OPEN_P; struct func *OR_P; struct func *PROJECT_P; struct func *PCONSTRAINT_P; struct func *PCONSTRAINT2_P; struct func *READ_P; struct func *RETRACT_P; struct func *SEE_P; struct func *SEEN_P; struct func *SUBSTR_P; struct func *STAY_P; struct func *STRCMP_P; struct func *STRLEN_P; struct func *SUM_P; struct func *T_P; struct func *TAB_P; struct func *TELL_P; struct func *TOLD_P; struct func *TREE_P; struct func *TRUE_P; struct func *UNBREAK_P; struct func *VAR_P; struct func *WRITE_P; struct func *PNAME_P; struct func *DEF_P; struct func *QUERY1_P; struct func *QUERY2_P; struct func *NOT_P; struct func *EQSIGN_P; struct func *MKLIST_P; struct func *CONSTRAINT_P; struct func *CONSTRAINT2_P; struct func *GREATER2_P; struct func *GEQ2_P; struct func *LESS2_P; struct func *LEQ2_P; struct func *EQUAL2_P; struct func *EQ2_P; struct func *PNAMES_P; struct func *PVALUE_P; struct func *TYPE_P; struct func *RESET_TIMER_P; struct func *TIMER_P; *GREATER2_P; extern struct func *GEQ2_P; extern struct func *LESS2_P; extern struct func *LEQ2_P; extern struct func *EQUAL2_P; extern struct func *EQ2_P; extern struct func *PNAME_P; /* functions included in cu-prolog */ extern struct func *LIST, *CUNIFY; extern struct term *NIL, *FAIL; extern struct func *PNAMES_P; extern struct func *PVALUE_P; extern struct func *TYPE_P; extern struct func *RESET_TIMEsrc/syspred1.c 644 10266 36 76315 5712121411 6710 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * << syspred1.c >> * (system predicates No.1) * 1992-Nov-4 bug fix (general_assert: add up_init(),restore_init()) * 1994-July-13 apnd(), neq() * 1994-Aug-10 CtoL() (name predicate) for Kanji * 1995-Jan-27 retract() type2->type1 --------------------------------------------------------------------*/ #include "include.h" /* for LtoC(), CtoL() pred */ #define FROM_NAME 1 #define FROM_CONC 0 int memb_pred(t,e,n,status) /* system 'member' pred */ struct term *t; struct pair *e; struct node *n; int status; { register struct term *tt; struct ustack *usave; int *hsave; struct pair *esave; register struct pair *p,*pp,*ee; if (status != BACKTRACK) { pp = Nenv(1); n->n_hp = hp; n->n_ep = ep; n->n_usp = usp; tt = Arg2(t); ee = e; } else { pp = (struct pair *)n->n_set; tt = pp->p_body; ee = pp->p_env; } down(p,tt,ee); usave = usp; hsave = hp; esave = ep; while(tt != NIL) { if (! is_list(tt)) return(SYSFAIL); if (tunify(Arg1(t),e,head_of_list(tt),ee,0) == FALSE) { /* undo(usave); hp = hsave; ep = esave; */ /* recovered in tunify() */ tt = tail_of_list(tt); down(p,tt,ee); continue; } pp->p_body = tail_of_list(tt); pp->p_env = ee; n->n_set = (struct set *)pp; return(SYSTRUE); } return(SYSFAIL); } struct clause *copy_list_half(org,to,flag) struct clause *org,*to; int flag; { if (org == to) return((struct clause *)NIL); else return(Nlist(head_of_list(org), copy_list_half(org->c_link,to,flag), flag)); } struct clause *sys_append(cl,t,flag) /* cl+t */ struct clause *cl; struct term *t; int flag; { if (cl == (struct clause *)NIL) return((struct clause *)t); else return(Nlist(head_of_list(cl), sys_append(cl->c_link,t,flag),flag) ); } struct clause *concat_list(c1,c2) /* cl+t */ struct clause *c1,*c2; { register struct clause *c; if (c1 == (struct clause *)NIL) return(c2); for (c = c1; c->c_link != (struct clause *)NIL; c=c->c_link) ; c->c_link = c2; return(c1); } #define list_or_nil(Term) (is_list(Term)||Term==NIL) int apnd_pred(t,e,n,status) /* system 'append' pred */ struct term *t; struct pair *e; struct node *n; int status; { register struct term *t1,*t2,*t3; register struct pair *ee,*p3,*e1,*p1; struct clause *next,*cl; int vnum; void up_init0(),up_restore0(); /* modular.c */ t1 = Arg1(t); e1=e; down(p1,t1,e1); if (p1 == NULL_ENV){ /* arg1: bound */ if (t1 == NIL) /* Arg1=[] */ { if (tunify(Arg2(t),e,Arg3(t),e,0)==TRUE) return(SYSTRUE); else return(SYSFAIL); } else if (status == BACKTRACK || p1 != NULL_ENV || !is_list(t1)) return(SYSFAIL); else { up_init0(); /* up without log */ t1 = termset(t1,e1,TEMPORAL); /* copy of Arg1 */ t2 = termset(Arg2(t),e,TEMPORAL); /* copy of Arg2 */ up_restore0(); vnum = v_number + p_number; if (vnum > 0) /* if there are vars in Arg1 or Arg2 */ { ee = Nenv(vnum); if (tunify(Arg1(t),e,t1,ee,0) == FALSE || tunify(Arg2(t),e,t2,ee,0) == FALSE) return(SYSFAIL); } else ee = e; cl= concat_list((struct clause *)t1,(struct clause *)t2); if (tunify(Arg3(t),e,cl,ee,0)==TRUE) return(SYSTRUE); else return(SYSFAIL); } } else /* arg1:var, arg3: bound */ { t3 = Arg3(t); ee=e; down(p3,t3,ee); if (! list_or_nil(t3)) return(SYSFAIL); if (status != BACKTRACK) next = (struct clause *)t3; else next = (struct clause *)n->n_set; for (;;) { cl = copy_list_half(t3,next,TEMPORAL); if (tunify(Arg1(t),e,cl,ee,0) == TRUE && tunify(Arg2(t),e,next,ee,0) == TRUE) { n->n_set = (struct set *)(next->c_link); return(SYSTRUE); } else{ if (next == (struct clause *)NIL) return(SYSFAIL); next=next->c_link; } } } } int or_pred(t,e,n,m,status) struct term *t; register struct pair *e; struct node *n, *m; int status; { register struct term *tt; register struct pair *e0; struct pair *p; struct clause *c0; struct clause *convert_list_to_clause(); int arity, next = 0; if (status == BACKTRACK) next = (int)n->n_set; tt = Arg(t,next++); e0 = e; down(p,tt,e0); if ((arity = t->t_arity) < 0) arity = -arity; n->n_set = (next < arity) ? (struct set *)next : NULL; if (p != NULL) { sprintf(nbuf,"or*/%d: %d-th argument is real VAR",arity,next-1); error_detail(t,e,nbuf); } else if ((tt == NIL) || (tt==NULL)) return(SYSTRUE); if (is_list(tt)) { sprintf(nbuf,"or*/%d: %d th argument is not List",arity, (next-1)); c0 = convert_list_to_clause(t,e,tt,e0,&p,nbuf); } else { p = e0; if (! is_clause(tt)) c0 = Nclause(tt,NULL_CL,TEMPORAL); else c0 = (struct clause *)tt; } m->n_clause = c0; m->n_env = p; m->n_usp = usp; m->n_hp = hp; m->n_ep = ep; m->n_set = init_set(m); return(SYSTRUE); } struct clause *convert_list_to_clause(t,e,tt,ee,p,emsg) struct term *t, *tt; struct pair *e, *ee, **p; char *emsg; { struct clause *c, *cc; register struct pair *pp; v_number = 0; v_list = NULL; *p = Nenv(0); c = cc = Nclause(NULL,NULL_CL,TEMPORAL); while(1) { if (isconst(head_of_list(tt))) cc->c_form = head_of_list(tt); else { pp = Nenv(1); cc->c_form = Nvar(Anonymous_VarName,TEMPORAL); pp->p_body = head_of_list(tt); pp->p_env = ee; } tt = tail_of_list(tt); down(pp,tt,ee); if ((tt == NIL) || (tt == NULL)) break; cc->c_link = Nclause(NULL, NULL_CL, TEMPORAL); cc = cc->c_link; } return(c); } int read_pred(t,e) struct term *t; struct pair *e; { register struct term *tt, *target; register struct pair *p, *ee; FILE *filep; int arity; if ((arity = t->t_arity) < 0) arity = -arity; filep = fp; if (arity == 2) { tt = Arg2(t); ee = e; down(p,tt,ee); if (! is_file(tt)) error("read*/2: Illegal file pointer"); fp = filep_value(tt); if (! is_readable(fp)) { fp = filep; error("read*/2: file not open"); } } v_number = 0; v_list = NULL; p_number = 0; reread = 0; advance; if (check(EOF)){ target = END_OF_FILE; fclose(fp); } else { target = Rterm(1200,TEMPORAL); if (tokentype!=FULLSTOP) { error_detail(target,NULL_ENV,"Syntax error --- . expected"); } skipline; } fp = filep; ee = Nenv(v_number+p_number); return(equalpred(Arg1(t),e,target,ee)); } #define SPECIFIED 0 #define INPUT 1 #define OUTPUT 2 int open_pred(t,e) struct term *t; struct pair *e; { return(file_open_pred(t,e,SPECIFIED)); } int see_pred(t,e) struct term *t; struct pair *e; { return(file_open_pred(t,e,INPUT)); } int tell_pred(t,e) struct term *t; struct pair *e; { return(file_open_pred(t,e,OUTPUT)); } int file_open_pred(t,e,openmode) register struct term *t; register struct pair *e; int openmode; { static char *emsg = "open/3: Illegal argument --- should not be variable"; register struct pair *p, *ee; register struct term *tt; char *mode, *fname; FILE *filep, *fopen(); tt = Arg1(t); ee = e; down(p,tt,ee); if (p != NULL) error_detail(t,e,emsg); if (is_string(tt)) fname=str_value(tt); else if (!is_atomic(tt)) fname=tt->type.t_func->f_name; else error_detail(t,e,"open/3: Illegal file name"); switch (openmode) { case INPUT: mode = "r"; break; case OUTPUT: mode = "w"; break; case SPECIFIED: tt = Arg2(t); ee = e; down(p,tt,ee); if (p != NULL) error_detail(t,e, emsg); mode = (is_string(tt)) ? str_value(tt) : tt->type.t_func->f_name; if (((mode[0] != 'r') && (mode[0] != 'w')) || mode[1] != '\0') { sprintf(nbuf,"open/3: Illegal mode >> %s << shoule be 'r' or 'w'",mode); error(nbuf); } } if ((filep = fopen(fname, mode)) == NULL) error("open/3: can't open the file"); switch (openmode) { case INPUT: fp=filep; return(SYSTRUE); case OUTPUT: wfp=filep; return(SYSTRUE); } tt = Nterm(0,TEMPORAL); tt->type.ident = FILE_TYPE; tt->tag.s_value = (char *)filep; return(equalpred(Arg3(t),e,tt,NULL_ENV)); } int seen_pred(t,e) struct term *t; struct pair *e; { FILE *f = wfp; if (fp != stdin) fclose(fp); else { wfp = stderr; tprint0("Warning: no file is opened for input\n"); wfp = f; } fp = stdin; return(SYSTRUE); } int told_pred(t,e) struct term *t; struct pair *e; { if (wfp != stdout) fclose(wfp); else { wfp = stderr; tprint0("Warning: no file is opened for output\n"); wfp = stdout; } wfp = stdout; return(SYSTRUE); } int close_pred(t,e) register struct term *t; register struct pair *e; { FILE *filep; register struct pair *p; t = Arg1(t); down(p,t,e); if (! is_file(t)) error("close/1: Illegal argument"); filep = filep_value(t); if ((filep == stdin) || (filep == stdout)) error("close/1: stdin/stdout cannot be closed!"); fclose(filep); return(SYSTRUE); } struct clause *new_pred_def2(vl,vnum) /* <-- project_pred */ struct term *vl; int vnum; { register struct term *v,*tmp,*t; register struct func *newfunc; struct clause *c; int i,arity=0; tmp = Nterm(vnum,TEMPORAL); for (v = vl; v != NULL; v = vlink(v)) if (((struct var *)v)->v_type == (long int)VAR_GLOBAL_TYPE) Arg(tmp,arity++) = v; if (arity == 0) return(NULL_CL); t = Nterm(arity,ETERNAL); for (i=0; i < arity; i++) Arg(t,i) = Arg(tmp,arity -1 - i); while (1) { /* new predicate name */ sprintf(nbuf, "%s%d", genname, GENSYM++); if (exist_fname(nbuf) == NULL) break; } newfunc = Nfunc(USERFUN, nbuf, arity); newpred(newfunc); index_func(newfunc); t->type.t_func = newfunc; c = Nclause(t,NULL_CL,ETERNAL); /* recalc_voccurrence(c, vl); */ return(c); } int project_pred(t,e,n) /* print constraint */ struct term *t; struct pair *e; register struct node *n; { struct term *tt, *tnew; struct clause *nclause, *body; struct set *s; struct pair *e0; int arity; if ((arity = t->t_arity) < 0) arity = -arity; if (n->n_constraint == NULL_ECL) { if (arity == 2) { return(equalpred(NIL,NULL_ENV,Arg2(t),e)); } tprint0("nil"); return(SYSTRUE); /* need not print */ } e0 = Nenv(0); up_init(); tt = Arg1(t); tnew = termset(tt,e,ETERNAL); nclause = new_pred_def2(v_list,v_number); if (nclause == NULL) { up_restore(); if (arity == 2) { return(equalpred(NIL,NULL_ENV,Arg2(t),e)); } tprint0("no constrained"); return(SYSTRUE); /* need not print */ } body = up_eclause(n->n_constraint, ETERNAL); if (nclause == NULL_CL) { up_restore(); if (arity == 2) { return(equalpred(NIL,NULL_ENV,Arg2(t),e)); } tprint0("no constraint"); return(SYSTRUE); /* need not print */ } up_restore(); nclause->c_link = body; /* Head:-Body. */ s = snew(set); s->s_clause = nclause; s->s_anumber = v_number + p_number; s->s_vlist = v_list; s->s_link = (struct set *)NULL; s->s_constraint = NULL_CL; s->s_bodynumber = 0; /* set in add_set */ if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); } add_set(s,'z'); if (arity == 2) { return(equalpred(nclause->c_form,e0,Arg2(t),e)); } Pterm(nclause->c_form,e0); return(SYSTRUE); } int pcon_pred(t,e,n) /* print constraint */ struct term *t; struct pair *e; register struct node *n; { Peclause(n->n_constraint); return(SYSTRUE); } int attach_pred(t,e,n,m,status) /* attach constraints */ struct term *t; struct pair *e; struct node *n,*m; int status; { struct pair *p, *ee; struct term *tt; register struct clause *c; struct eclause *ec; static char *emesg = "attach_constraint/1: Illegal Argument"; struct clause *convert_list_to_clause(); tt = Arg1(t); ee = e; down(p,tt,ee); if (is_list(tt)) { c = convert_list_to_clause(t,e,tt,ee,&p,emesg); } else if (is_clause(tt)) { c = (struct clause *)tt; p = ee; } else if (tt==NIL) return(SYSTRUE); else if (is_functor(tt)) { c = Nclause(tt, NULL_CL, TEMPORAL); p = ee; } else error_detail(t,e,emesg); ec = transform(n->n_constraint, c, p); if (ec == (struct eclause *)MFAIL) return(SYSFAIL); upush(&(m->n_constraint)); m->n_constraint=ec; return(SYSTRUE); } int cunify_pred(t,e) /* c.u. unify() */ register struct term *t; register struct pair *e; { if (cu(t,e) != FALSE ) return(SYSTRUE); /* success */ else return(SYSFAIL); /* fail */ } int write_pred(t,e) struct term *t; struct pair *e; { register struct pair *p, *ee; register struct term *tt; FILE *filep; int arity; if ((arity = t->t_arity) < 0) arity = -arity; filep = wfp; if (arity == 2) { tt = Arg2(t); ee = e; down(p,tt,ee); if (! is_file(tt)) error("write*/2: Illegal file pointer"); wfp = filep_value(tt); if (! is_writable(wfp)) { wfp = filep; error("write*/2: file not open"); } } tt = Arg1(t); down(p,tt,e); if (is_string(tt)) tprint1("%s",str_value(tt)) else Pterm(tt, e); wfp = filep; return(SYSTRUE); } int nl_pred(t,e) register struct term *t; register struct pair *e; { register struct pair *p; FILE *filep; int arity; filep = wfp; if ((arity = t->t_arity) < 0) arity = -arity; if (arity != 0) { t = Arg1(t); down(p,t,e); if (! is_file(t)) error("nl*/1: Illegal file pointer"); wfp = filep_value(t); if (! is_writable(wfp)) { wfp = filep; error("nl*/2: file not open"); } } NL; wfp = filep; return(SYSTRUE); } int tab_pred(t,e) register struct term *t; register struct pair *e; { register struct pair *p; FILE *filep; int arity; filep = wfp; if ((arity = t->t_arity) < 0) arity = -arity; if (arity != 0) { t = Arg1(t); down(p,t,e); if (! is_file(t)) error("tab*/1: Illegal file pointer"); wfp = filep_value(t); if (! is_writable(wfp)) { wfp = filep; error("tab*/2: file not open"); } } tprint0("\t"); wfp = filep; return(SYSTRUE); } int var_pred(t,e) struct term *t; register struct pair *e; { register struct pair *p; register struct term *tt; tt = Arg1(t); down(p,tt,e); if (p != NULL) return(SYSTRUE); /* (t,e) is var */ else return(SYSFAIL); /* (t,e) is not var */ } /* equal ( = ) predicate : equal(t1,t2) = SYSTRUE : if t1/e = t2/e else SYSFAIL */ int equal_pred(t,e) register struct term *t; struct pair *e; { return(equalpred(Arg1(t),e,Arg2(t),e)); } int eq_pred(t,e) register struct term *t; struct pair *e; { return(eq_pred_sub(Arg1(t),Arg2(t),e,e)); } int nequal_pred(t,e) /* not-equal predicate */ register struct term *t; struct pair *e; { int *hsave,res; struct pair *esave; struct ustack *usave; esave = ep; hsave = hp; usave = usp; if (tunify(Arg1(t),e,Arg2(t),e,0) == TRUE) { undo(usave); hp = hsave; ep = esave; return(SYSFAIL); } else return(SYSTRUE); } int eq_pred_sub(x,y,ex,ey) register struct term *x, *y; register struct pair *ex, *ey; { register struct pair *p; down(p,x,ex); down(p,y,ey); if ((x == y) && (ex == ey)) return(SYSTRUE); if (isvar(x) || (p != NULL)) return(SYSFAIL); if (x->type.ident != y->type.ident) return(SYSFAIL); if (is_atomic(x)) { if (atomic_equal(x,y)) return(SYSTRUE); else return(SYSFAIL); } if (is_pst(x)) return(eq_pred_sub(((struct pst *)x)->p_var,((struct pst *)y)->p_var, ex,ey)); if (is_clause(x) || is_list(x)) { do { if (eq_pred_sub(head_of_list(x),head_of_list(y),ex,ey) == SYSFAIL) return(SYSFAIL); x = tail_of_list(x); y = tail_of_list(y); } while ((x != NULL) && (x != NIL) && (y != NULL) && (y != NIL)); return(SYSTRUE); } if (is_functor(x) && is_functor(y)) { register int i, a = x->t_arity; if (a != y->t_arity) return(SYSFAIL); if (a < 0) a = -a; for(i=0;i < a; i++) { if (eq_pred_sub(Arg(x,i),Arg(y,i),ex,ey) == SYSFAIL) return(SYSFAIL); } } return(SYSTRUE); } int equalpred(t1,e1,t2,e2) register struct term *t1, *t2; register struct pair *e1, *e2; { int *hsave; struct pair *esave; struct ustack *usave; esave = ep; hsave = hp; usave = usp; if (tunify(t1,e1,t2,e2,0) == FALSE) { /* undo(usave); hp = hsave; ep = esave; */ return(SYSFAIL); } return(SYSTRUE); } int assertz_pred(t,e) struct term *t; struct pair *e; { general_assert(t,e,'z'); return(SYSTRUE); } int assert_pred(t,e) struct term *t; struct pair *e; { general_assert(t,e,'a'); return(SYSTRUE); } void general_assert(t,e,flag) struct term *t; struct pair *e; char flag; /* 'a'(first) or 'z'(last) */ { struct term *pred, *defs, *con; register struct pair *p, *ee; struct clause *c_head, *c_con; struct ustack *usave; int arity; pred = Arg1(t); ee = e; down(p,pred,ee); if ((p != NULL) || is_atomic(pred)) { error_detail(t,e,"assert*/1: Illegal argument"); } if (issystem(pred->type.t_func)) { error_detail(t,e,"assert*/1: system function cannot be asserted"); } v_list = NULL; v_number = 0; pv_list = NULL; p_number = 0; usave = usp; if ((arity = t->t_arity) < 0) arity = -arity; /* make first clause (head) */ con = (arity == 3) ? Arg3(t) : NULL; defs = (arity > 1) ? Arg2(t) : NULL; up_init(); /* BUG FIX 1992-Nov-4 */ c_head = Nclause(termset(pred,ee,ETERNAL), list_to_clause(defs,e), ETERNAL); c_con = list_to_clause(con,e); up_restore(); if (p_number != 0) renum_pvars((struct pstvar *)pv_list,v_number); index_set(c_head,c_con,flag); undo(usave); } struct clause *list_to_clause(t,e) register struct term *t; register struct pair *e; { struct clause *croot, *cbefore, *cc; register struct pair *p; int *ssave = shp; if (t != NULL) down(p,t,e); if ((t == NULL) || (t == NIL)) return(NULL); croot = snew(clause); croot->c_type = CLAUSE_TYPE; cbefore = cc = croot; while(1) { if(! is_list(t)) { shp = ssave; error_detail(t,e, "In assert or execute: Illegal argument ... should be LIST"); } cc->c_form = termset(head_of_list(t),e,ETERNAL); t = tail_of_list(t); down(p,t,e); if (t == NIL) break; cbefore = cc; cc = snew(clause); cc->c_type = CLAUSE_TYPE; cbefore->c_link = cc; } cc->c_link = NULL; return(croot); } int retract_pred(t,e) struct term *t; struct pair *e; { register struct set *ss, *foreset; register struct pair *p, *et; register struct ustack *usave; struct term *tt; struct term *c_defs, *c_con; struct term *defs, *con; struct pair *newenv; int arity; if ((arity = t->t_arity) < 0) arity = -arity; tt = Arg1(t); et = e; down(p,tt,et); if (isvar(tt) || is_atomic(tt)) error("retract*/1: Illegal argument"); if (!isuser(tt->type.t_func)) return(SYSFAIL); foreset = NULL; ss = Pred(tt)->def.f_set; usave = usp; con = (arity == 3) ? Arg3(t) : NIL; defs = (arity >= 2) ? Arg2(t) : NIL; while(ss != NULL) { newenv = Nenv((int)ss->s_anumber); if (tunify(tt,et,ss->s_clause->c_form,newenv,0)==FALSE) { /* undo(usave); */ foreset = ss; ss = ss->s_link; continue; } c_defs = tolist(ss->s_clause->c_link,TEMPORAL); if (tunify(defs,e,c_defs,newenv,0) == FALSE) { /* undo(usave); */ foreset = ss; ss = ss->s_link; continue; } c_con = tolist(ss->s_constraint,TEMPORAL); if (tunify(con,e,c_con,newenv,0) == FALSE) { /* undo(usave); */ foreset = ss; ss = ss->s_link; continue; } if (foreset == NULL) /* set the next goal */ Pred(tt)->def.f_set = ss->s_link; else foreset->s_link = ss->s_link; ((struct func *)tt->type.t_func)->f_setcount--; if is_unitclause(ss) ((struct func *)tt->type.t_func)->f_unitcount--; ((struct func *)tt->type.t_func)->f_mark |= VACUITY_NOCHECK; Def_Modified = 1; return(SYSTRUE); } return(SYSFAIL); } void clear_predicate(f) /* clear user predicate */ register struct func *f; { register int i; f->def.f_set = NULL; f->f_setcount = 0; f->f_unitcount = 0; for (i = 0; i < f->f_arity; i++) Component(f,i) = NULL; /* f->f_roles[0] = 0; */ } int abolish_pred(t,e) struct term *t; struct pair *e; { register struct term *f, *a; register struct pair *ef, *ea, *p; struct func *fun; f = Arg1(t); a = Arg2(t); ef = ea = e; down(p,f,ef); down(p,a,ea); if ((f->type.ident < CONST_LIST_TYPE) || (! is_int(a))) { error_detail(t,e,"abolish/2: Illegal argument."); } fun = funcsearch(Predname(f),(int)(num_value(a))); if (fun != NULL) { if (issystem(fun)) { error_detail(t,e,"abolish/2: System predicates cannot be abolished"); } clear_predicate(fun); Def_Modified = 1; /* def modified ! */ } return(SYSTRUE); } int makelist_pred(t,e) /* for predicate ' ml(Pred,List) (=..) ' */ struct term *t; struct pair *e; { struct term *t0, *t1, *tt, *tfun; register struct pair *e0, *e1, *efun, *p; int nvars, depth = 0; t0 = Arg1(t); t1 = Arg2(t); e0 = e1 = e; down(p,t0,e0); down(p,t1,e1); /* 1st arg is var */ if( isvar(t0) ){ if (isvar(t1)) return(SYSFAIL); if (! is_list(t1)) { error_detail(t,e,"ml/2: Illegal argument"); } tfun = head_of_list(t1); /* tfun : functor name */ efun = e1; down(p,tfun,efun); if (isvar(tfun) || (! is_functor(tfun))) { error_detail(t,e,"ml/2:Illegal term for functor."); } t1 = tail_of_list(t1); depth=Llevel(t1,e1,&nvars); if (Pred(tfun) == LIST) { if (depth != 2) { error_detail(t,e,"ml/2: Illegal argument for LIST"); } tt = (struct term *) Nlist(head_of_list(t1), (struct clause *)tail_of_list(t1),TEMPORAL); return(equalpred(t0,e0,tt,efun)); } tt = Nterm(depth,TEMPORAL); Pred(tt) = Predicate(Predname(tfun), depth); if (t1 != NIL ) { efun = Nenv(0); LtoP(t1,e1,tt,depth); } return(equalpred(t0,e0,tt,efun)); } /* 1st arg is term */ if (is_atomic(t0)) tfun=t0; else if (is_list(t0)) { Pred(tfun)=LIST; tt = (struct term *)Nlist(tfun,(struct clause *)t0,TEMPORAL); return(equalpred(t1,e1,tt,e0)); } else if (is_functor(t0)) { tfun = Nterm(0,TEMPORAL); tfun->type.t_func = Predicate(Predname(t0),0); } else error("ml/2:Illegal argument"); tt = (struct term *)Nlist(tfun,PtoL(t0),TEMPORAL); return(equalpred(t1,e1,tt,e0)); } int Llevel(t,e,nv) /* from makelist() : Listlevel -> Depth (int) */ register struct term *t; register struct pair *e; int *nv; { register struct pair *pp; int depth=0; *nv = 0; if (isvar(t)) down(pp,t,e); while( t != NIL ) { if (! is_list(t)) error("ml/2: cdr is real var"); if (! isconst(head_of_list(t))) (*nv)++; t = tail_of_list(t); depth++; if (isvar(t)) down(pp,t,e); }; return(depth); } void LtoP(t,e,tt,depth) /* from makelist() : List -> Predicate */ register struct term *t, *tt; register struct pair *e; int depth; { register struct pair *p; register int i; v_list = NULL; v_number = 0; for(i = 0; i < depth ; i++) { if (isvar(t)) down(p,t,e); if (isconst(head_of_list(t))) Arg(tt,i)=head_of_list(t); else { Nvar(Anonymous_VarName,TEMPORAL); p = Nenv(1); p->p_body = head_of_list(t); p->p_env = e; Arg(tt,i)=(struct term *)v_list; } t = tail_of_list(t); } return; } struct clause *PtoL(t) /* from makelist() : Predicate -> List */ struct term *t; { struct clause *root; register struct term *tt, *temp; int pos = 0, arity; if (is_atomic(t)) return((struct clause *)NIL); if ((arity = t->t_arity)==0) return((struct clause *)NIL); if (arity < 0) arity = -arity; root = Nlist(NIL,(struct clause *)NIL,TEMPORAL); tt = (struct term *)root; while(1) { head_of_list(tt) = Arg(t,pos); pos++; if (pos >= arity) break; tail_of_list(tt) = temp = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL); tt = temp; } return(root); } int name_pred(t,e) /* for predicate ' name(String,List) ' */ struct term *t; struct pair *e; { register struct term *tt,*arg0,*arg1; register struct pair *p,*e0,*e1; arg0 = Arg1(t); arg1 = Arg2(t); e0 = e1 = e; *nbuf = '\0'; down(p,arg0,e0); down(p,arg1,e1); /* 1st arg is var */ if (isvar(arg0)){ if (isvar(arg1)) return(SYSFAIL); LtoC(arg1,e1,0,FROM_NAME); /* List -> (char)nbuf[] */ if (alldigit(nbuf)) tt = Nnum(nbuf,TEMPORAL); else { tt = Nterm(0,TEMPORAL); Pred(tt) = Predicate(nbuf,0); } return(equalpred(arg0,e0,tt,NULL_ENV)); } /* 1st arg is constant */ if (is_num(arg0)) { sprintf(nbuf,"%d",(int)num_value(arg0)); tt = CtoL(nbuf, FROM_NAME); } else if (is_string(arg0)) tt = CtoL( str_value(arg0), FROM_NAME ); else if (isatom(arg0)) tt = CtoL(Predname(arg0), FROM_NAME); else return(SYSFAIL); return(equalpred(arg1,e1,tt,NULL_ENV)); } void LtoC(t,e,pos, flag) /* from name_pred() : List -> Charactar */ struct term *t; struct pair *e; int pos, flag; /* flag = 0(FROM_CONC) /char, 1(FROM_NAME) /int */ { register struct pair *e0, *e1, *p; register struct term *arg0, *arg1; if (is_string(t)) { strcpy(nbuf, str_value(t)); return; } if (! is_list(t)) error("name/2: 2nd arg is illegal term."); arg0 = head_of_list(t); arg1 = tail_of_list(t); e0 = e1 = e; down(p,arg0,e0); down(p,arg1,e1); if (isvar(arg0) || (! isatom(arg0)) || isvar(arg1)) { sprintf(nbuf,"%s/2: 2nd arg is real VAR", ((flag) ? "name" : "concat2")); error_detail(t,e,nbuf); } if (flag) { if (! is_int(arg0)) error("name/2: 2nd arg contains illegal term."); else nbuf[pos++] = (int)num_value(arg0); } else { if (is_string(arg0)) strcat(nbuf, str_value(arg0)); else if ((is_functor(arg0)) && (isatom(arg0))) strcat(nbuf,Predname(arg0)); else if (is_int(arg0)) { int len = strlen(nbuf); nbuf[len++]=(int)num_value(arg0); nbuf[len]='\0'; } else { error_detail(arg0,e0,"concat2/2: illegal arg"); } } if (arg1 != NIL) LtoC(arg1,e1,pos,flag); else if (flag) nbuf[pos] = '\0'; return; } struct term *CtoL(nbuf, flag) /* from name_pred() : Charactar -> List */ unsigned char *nbuf; int flag; /* 0(FROM_CONC) -> char, 1(FROM_NAME) -> int */ { struct term *root, *t; unsigned char s[3]; register int pos = 0; root = t = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL); while (1) { if (flag == FROM_NAME) { head_of_list(t)=Nnum_val((float)nbuf[pos++],TEMPORAL); } else { s[0] = nbuf[pos++]; s[1] = '\0'; #if KANJI ==1 if (s[0] > EUCOS) { s[1] = nbuf[pos++]; s[2] = '\0'; } #endif head_of_list(t) = Nstr(s, TEMPORAL); } if (nbuf[pos] == '\0') return(root); t = (tail_of_list(t) = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL)); } } int arg_pred(t,e) struct term *t; struct pair *e; { register struct term *pos, *tt, *var; register struct pair *p, *ep, *et, *ev; int i, arity; pos = Arg(t,0); tt = Arg(t,1); var = Arg(t,2); ep = et = ev = e; down(p,pos,ep); down(p,tt,et); down(p,var,ev); if (isvar(pos) || isvar(tt)) return(SYSFAIL); if (! is_int(pos)) { error_detail(t,e,"arg/3: illegal argument"); } i = num_value(pos); if (is_list(tt)) switch (i) { case 1: return(equalpred(head_of_list(tt),et,var,ev)); case 2: return(equalpred(tail_of_list(tt),et,var,ev)); default: error_detail(t,e,"arg/3:Illegal argument for position"); } else if (! is_functor(tt)) { error_detail(t,e,"arg/3:Illegal argument for functor"); } if((arity = tt->t_arity) < 0) arity = -arity; if ((i <= 0) || (tt->type.ident == 0) || i > arity) { error_detail(t,e,"arg/3: illegal argument"); } return(equalpred(Arg(tt,i-1),et,var,ev)); } int functor_pred(t,e) struct term *t; struct pair *e; { register struct term *tt, *fun, *ari; register struct pair *p, *et, *ef, *ea; tt = Arg(t,0); fun = Arg(t,1); ari = Arg(t,2); ea = ef = et = e; down(p,tt,et); down(p,fun,ef); down(p,ari, ea); if (isvar(tt)) return(make_func(fun,ari,tt,et)); if ((! is_functor(tt)) && (! is_list(tt))) error_detail(t,e,"functor/3: 1st argument is not appropriate"); return(match_func(tt,et,fun,ef,ari,ea)); } int make_func(f,a,t,e) struct term *f, *a, *t; struct pair *e; { struct term *temp; struct pair *env; int i,arity; if (isvar(f) || isvar(a)) return(SYSFAIL); if (! (isatom(f))) { error_detail(t,e,"functor/3: 2nd argument is not atom"); } if (! (is_int(a))) { error_detail(t,e,"functor/3: 3rd argument is not integer"); } if ((arity = (int)(num_value(a))) < 0) { error_detail(t,e,"functor/3: 3rd argument is illegal number"); } if (arity==0) return(equalpred(t,e,f,e)); v_list = NULL; v_number = 0; env = Nenv(arity); if ((arity == 2) && (Pred(f)==LIST)) temp = (struct term *) Nlist(Nvar(Anonymous_VarName,TEMPORAL), Nvar(Anonymous_VarName,TEMPORAL),TEMPORAL); else { temp = Nterm(arity,TEMPORAL); Pred(temp) = Predicate(Predname(f), arity); for (i=0; i < arity; i++) Arg(temp,i)=Nvar(Anonymous_VarName,TEMPORAL); } return(equalpred(t,e,temp,env)); } int match_func(t,e,f,ef,a,ea) struct term *t, *f, *a; struct pair *e, *ef, *ea; { struct term *temp; int arity, *hsave; struct pair *esave; struct ustack *usave; hsave = hp; esave = ep; usave = usp; arity = t->t_arity; if (arity < 0) arity = -arity; if (is_list(t)) temp =Nnum_val(2.0, TEMPORAL); else temp = Nnum_val((float)arity,TEMPORAL); if (tunify(a,ea,temp,NULL_ENV,0) == FALSE) { /* undo(usave); */ hp = hsave; ep = esave; return(SYSFAIL); } temp = Nterm(0,TEMPORAL); if (is_list(t)) Pred(temp)=LIST; else Pred(temp) = Predicate(Predname(t), 0); if (tunify(f,ef,temp,NULL_ENV,0) == FALSE) { /* undo(usave); */ hp = hsave; ep = esave; return(SYSFAIL); } return(SYSTRUE); } int clause_pred(t,e,n,status) /* clause(P,B,C) P:nonvar*/ struct term *t; struct pair *e; struct node *n; int status; { register struct pair *ee, *p, *newenv; register struct term *tt; struct term *t_body, *t_con; struct ustack *usave; struct set *s; int *hsave; struct pair *esave; ee = e; tt = Arg(t,0); /* head */ down(p,tt,ee); if (isvar(tt)) return(SYSFAIL); if (status != BACKTRACK) n->n_set = tt->type.t_func->def.f_set; if (n->n_set == NULL) return(SYSFAIL); usave = usp; hsave = hp; esave = ep; for (s = n->n_set; s != NULL; s = s->s_link) { newenv = Nenv((int)s->s_anumber); if (tunify(tt,ee,s->s_clause->c_form,newenv,0) == FALSE) { /* undo(usave); */ hp = hsave; ep = esave;continue; } t_body = tolist(s->s_clause->c_link,TEMPORAL); tt = Arg(t,1); ee = e; down(p,tt,ee); if (tunify(tt, ee, t_body, newenv,0)==FALSE) { /* undo(usave); */ hp = hsave; ep = esave;continue; } t_con = tolist(s->s_constraint,TEMPORAL); tt = Arg(t,2); ee = e; down(p,tt,ee); if (tunify(tt, ee, t_con, newenv,0) == FALSE) { /* undo(usave); */ hp = hsave; ep = esave;continue; } n->n_set = s->s_link; /* next goal */ return(SYSTRUE); } return(SYSFAIL); } ; p->p_body = head_of_list(t); p->p_env = e; Arg(tt,i)=(struct term *)v_list; } t = tail_of_list(t); } return; } struct clause *PtoL(t) /* from makelist() : Predicate -> List */ struct term *t; { struct clause *root; register struct term *tt, *temp; intsrc/syspred2.c 644 10266 36 37271 5712121412 6710 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << syspred2.c >> * (system predicates No.2 : string, number) * 1994.9.27 atom_to_str --------------------------------------------------------------------*/ #include "include.h" int kstrlen(),kpoint(); /* for LtoC(), CtoL() pred */ #define FROM_NAME 1 #define FROM_CONC 0 int sum_pred(t,e) struct term *t; struct pair *e; { return(calc_pred(t,e,'+')); } int multiply_pred(t,e) struct term *t; struct pair *e; { return(calc_pred(t,e,'*')); } int calc_pred(t,e,op) struct term *t; struct pair *e; char op; { register struct term *x, *y, *z; register struct pair *e0, *e1, *e2, *p; e0 = e1 = e2 = e; x = Arg(t,0); y = Arg(t,1); z = Arg(t,2); down(p,x,e0); down(p,y,e1); down(p,z,e2); if(isvar(x)) return(calc_2(y,z,x,e0,op)); if(isvar(y)) return(calc_2(x,z,y,e1,op)); else return(calc_1(x,y,z,e2,op)); } int calc_1(x,y,z,e,op) struct term *x,*y,*z; struct pair *e; char op; { struct term *result; register float sum; /* if (isvar(x) || isvar(y)) return(SYSFAIL); */ if (! (is_num(x))) { sprintf(nbuf,"%s/3: Illegal argument as 1st argument", ((op == '+') ? "sum" : "multiply") ); error_detail(x,NULL_ENV,nbuf); } if (! (is_num(y))) { sprintf(nbuf,"%s/3: Illegal argument as 2nd argument", ((op == '+') ? "sum" : "multiply") ); error_detail(y,NULL_ENV,nbuf); } if (op=='+') sum = num_value(x) + num_value(y); else if (op=='*') sum = num_value(x) * num_value(y); else error("system error! at calc_pred"); result = Nnum_val(sum,TEMPORAL); return(equalpred(z,e,result,NULL_ENV)); } int calc_2(x,z,y,e,op) struct term *x,*y,*z; struct pair *e; char op; { struct term *result; register float temp; if (isvar(x) || isvar(z)) return(SYSFAIL); if (! (is_num(x))) { sprintf(nbuf,"%s/3: Illegal argument as 1st argument", ((op == '+') ? "sum" : "multiply") ); error_detail(x,NULL_ENV,nbuf); } if (! (is_num(z))) { sprintf(nbuf,"%s/3: Illegal argument as 2nd argument", ((op == '+') ? "sum" : "multiply") ); error_detail(z,NULL_ENV,nbuf); } temp = num_value(x); if ((op=='*') && (temp==0.0)) error("multiply/3: zero division"); if (op=='+') temp = num_value(z) - temp; else if (op=='*') temp = num_value(z)/temp; result = Nnum_val(temp,TEMPORAL); return(equalpred(y,e,result,NULL_ENV)); } int greater_pred(t,e) struct term *t; struct pair *e; { return(numcomp_pred(t,e,0)); } int less_pred(t,e) struct term *t; struct pair *e; { return(numcomp_pred(t,e,1)); } int geq_pred(t,e) struct term *t; struct pair *e; { return(numcomp_pred(t,e,2)); } int leq_pred(t,e) struct term *t; struct pair *e; { return(numcomp_pred(t,e,3)); } static char* compare_predicates[] = { "greater", "less", "geq", "leq" }; int numcomp_pred(t,e,op) struct term *t; struct pair *e; int op; { register struct term *x, *y; register struct pair *e0, *e1, *p; int g, l; e0 = e1 = e; x = Arg(t,0); y = Arg(t,1); down(p,x,e0); down(p,y,e1); if(isvar(x) || (p != NULL)) return(SYSFAIL); if (! (is_num(x))) { sprintf(nbuf,"%s/2: Illegal argument as 1st Arg", compare_predicates[op]); error_detail(x,e0,nbuf); } if (! (is_num(y))) { sprintf(nbuf,"%s/2: Illegal argument as 2nd Arg", compare_predicates[op]); error_detail(y,e1,nbuf); } g = (num_value(x) > num_value(y)) ? SYSTRUE : SYSFAIL; l = (num_value(x) < num_value(y)) ? SYSTRUE : SYSFAIL; switch (op) { case 0: return(g); case 1: return(l); case 2: return((l==SYSFAIL) ? SYSTRUE : SYSFAIL); case 3: return((g==SYSFAIL) ? SYSTRUE : SYSFAIL); } } /* concat("ab","cde",X) -> X = "abcde" */ int concat_pred(t,e,n,status) struct term *t; struct pair *e; struct node *n; int status; { register struct term *x, *y, *z; register struct pair *px, *py, *p; struct pair *ex, *ey, *ez; int len; char *buf; x = Arg(t,0); y = Arg(t,1); z = Arg(t,2); ex = ey = ez = e; down(px,x,ex); down(py,y,ey); down(p,z,ez); if (isvar(x) && isvar(y)) { if (status ==BACKTRACK) { /* X,Y are Vars, and Z is CONST */ if ((len = (int)n->n_set-1) < 0) return(SYSFAIL); /* copy status chars from z to nbuf */ len = kpoint(str_value(z),len); strncpy(nbuf,str_value(z),len); nbuf[len] = '\0'; /* due to BUG of SUN4 */ upush(&(px->p_body)); upush(&(px->p_env)); px->p_body = Nstr(nbuf,TEMPORAL); px->p_env = NULL_ENV; buf = str_value(z); upush(&(py->p_body)); upush(&(py->p_env)); buf += len; py->p_body = Nstr(buf,TEMPORAL); py->p_env = NULL_ENV; n->n_set = (struct set *)( (int)n->n_set - 1); return(SYSTRUE); } else { if (isvar(z)) return(SYSFAIL); if (! is_string(z)) { error_detail(z,ez,"concat/2: Illegal 3rd argument"); } len = kstrlen(str_value(z)); upush(&(px->p_body)); upush(&(px->p_env)); px->p_body = z; px->p_env = ez; nbuf[0] = '\0'; upush(&(py->p_body)); upush(&(py->p_env)); py->p_body = Nstr(nbuf,TEMPORAL); py->p_env = NULL_ENV; n->n_set = (struct set *)len; /* memorize the position */ return(SYSTRUE); } } if(isvar(x)) return(diff_str(y,z,x,ex,0)); if(isvar(y)) return(diff_str(x,z,y,ey,1)); else return(app_str(x,y,z,ez)); } int app_str(x,y,z,ez) struct term *x, *y, *z; struct pair *ez; { struct term *result; if (! (is_string(x) && is_string(y))) error("concat/3: illegal term"); if ((strlen(str_value(x))+strlen(str_value(y))) > NAMELEN_MAX) error("concat/3: too long string"); strcpy(nbuf,str_value(x)); strcat(nbuf,str_value(y)); result = Nstr(nbuf,TEMPORAL); return(equalpred(z,ez,result,NULL_ENV)); } int diff_str(x,z,y,e,first) struct term *x, *y, *z; struct pair *e; int first; /* assuming 0/last_half, 1/first_half is designated */ { struct term *result; int lx, lz, dif; char *cx, *cz; if (isvar(z)) return(SYSFAIL); if (! (is_string(z)) && (isvar(x) || is_string(x))) error("concat/3: illegal term"); cx = str_value(x); cz = str_value(z); if ((lz = strlen(cz)) < (lx = strlen(cx))) error("concat/3: not appropriate args"); if (first) /* find last half */ { register int pos; for (pos = 0; pos < lx; pos++) if (cx[pos] != cz[pos]) return(SYSFAIL); cz += pos; result = Nstr(cz,TEMPORAL); } else /* find first half */ { register int pos; dif = lz - lx; for (pos = dif; pos < lz; pos++) if (cx[pos-dif] != cz[pos]) return(SYSFAIL); /* strcpy(nbuf, cz, dif); this mus be bag. */ strncpy(nbuf, cz, dif); nbuf[dif] = '\0'; result = Nstr(nbuf,TEMPORAL); } return(equalpred(y,e,result,NULL_ENV)); } /* concat2("abcde",X) -> X = ["a","b","c","d","e"] */ int concat2_pred(t,e) struct term *t; struct pair *e; { struct term *x, *y; struct pair *ex, *ey, *p; struct term *tt; x = Arg(t,0); y = Arg(t,1); ex = ey = e; down(p,x,ex); down(p,y,ey); *nbuf = '\0'; if (isvar(x)) { if (isvar(y)) return(SYSFAIL); LtoC(y,ey,0,FROM_CONC); tt = Nstr(nbuf, TEMPORAL); return(equalpred(x,ex,tt,NULL_ENV)); } if (is_num(x)) { sprintf(nbuf, "%d",(int)num_value(x)); tt = CtoL(nbuf, FROM_CONC); } else if (is_string(x)) tt = CtoL(str_value(x), FROM_CONC); else tt = CtoL(x->type.t_func->f_name, FROM_CONC); return(equalpred(y,ey,tt,NULL_ENV)); } int strlen_pred(t,e) struct term *t; struct pair *e; { struct term *s, *l; struct pair *es, *el, *p; int len; s = Arg(t,0); l = Arg(t,1); es = el = e; down(p,l,el); down(p,s,es); if (p != NULL) return(SYSFAIL); if (! is_string(s)) { error_detail(t,e,"strlen/1: 1st arg is not string"); } if (! (isvar(l) || is_num(l))) { error_detail(t,e,"strlen/2: 2nd arg is neither Var nor Number"); } len = kstrlen(str_value(s)); t = Nnum_val((float)len,TEMPORAL); return(equalpred(l,el,t,NULL_ENV)); } /* substring("abcde",2,X) -> X = "cde" substring("abcde",-3,2,X) -> X = "cd" */ int substr_pred(t,e) struct term *t; struct pair *e; { static char *emsg = "substring/%d: %s arg is not %s"; struct term *s, *tmp; register struct pair *p, *ee; int arity,start,numb,len; char *sr; arity = t->t_arity; if (arity < 0) arity = -arity; s = Arg1(t); ee = e; down(p,s,ee); if (! is_string(s)) { sprintf(nbuf,emsg,arity, "1st", "string"); error_detail(t,e,nbuf); } tmp = Arg2(t); ee = e; down(p,tmp,ee); if (! is_int(tmp)) { sprintf(nbuf,emsg, arity, "2nd","integer"); error_detail(t,e,nbuf); } start = num_value(tmp); len = kstrlen(str_value(s)); if (start < 0) start += len; if (arity == 4) { tmp = Arg3(t); ee = e; down(p,tmp,ee); if (! is_int(tmp)) { sprintf(nbuf,emsg,4,"3rd","integer"); error_detail(t,e,nbuf); } numb = num_value(tmp); if (numb < 0) numb+=len; } else { /* arity == 3 */ numb = len-start; } if ( (start > len) || (numb > len) || (start < 0)) { sprintf(nbuf,"substring/%d: Illegal argument value",arity); error_detail(t,e,nbuf); } sr = str_value(s); sr += kpoint(sr,start); numb = kpoint(sr,numb); strncpy(nbuf,sr,numb); nbuf[numb] = '\0'; tmp = Nstr(nbuf,TEMPORAL); return(equalpred(Arg(t,arity-1),e,tmp,NULL_ENV)); } /* divstr("abcd",2,X,Y) -> X = "ab", Y = "cd" */ /* divstr(+,+,?,?) or divstr(+,-,+,?) */ int divstr_pred(t,e) struct term *t; struct pair *e; { static char *emesg = "divstr*/4: %s is not %s"; register struct pair *p, *ee, *e1; struct term *str, *temp, *first; int n,len, firsthalf(); char *sr, *sf, *divkstr(); str = Arg1(t); ee = e; down(p,str,ee); if (! is_string(str)) { sprintf(nbuf,emesg,"1st","string"); error_detail(t,e,nbuf); } sr = str_value(str); len = kstrlen(sr); temp = Arg2(t); ee = e; down(p,temp,ee); if (p != NULL) { /* 2nd arg is var */ e1 = e; first = Arg3(t); down (p,first,e1); if (! is_string(first)) { sprintf(nbuf,emesg,"2nd","integer and 3rd arg is var"); error_detail(t,e,nbuf); } sf = str_value(first); n = kstrlen(sf); if ((n <= len) && (firsthalf(sf,sr)==TRUE) && (equalpred(temp,ee,Nnum_val((float)n,TEMPORAL),NULL_ENV) == SYSTRUE)){ sr += strlen(sf); return(equalpred(Arg(t,3),e,Nstr(sr,TEMPORAL),NULL_ENV)); } return(SYSFAIL); } else if (! is_int(temp)) { sprintf(nbuf,emesg,"2nd","integer"); error_detail(t,e,nbuf); } n = num_value(temp); /* 2nd arg is num */ if (n < 0) n += len; if ((n > len) || (n < 0)) { sprintf(nbuf,emesg,"2nd","appropriate"); error_detail(t,e,nbuf); } n = kpoint(sr,n); /* n:kanji point -> n:char point */ strncpy(nbuf,sr,n); nbuf[n]='\0'; temp = Nstr(nbuf,TEMPORAL); if (equalpred(Arg(t,2),e,temp,NULL_ENV) == SYSFAIL) return(SYSFAIL); temp = Nstr(sr+n,TEMPORAL); return(equalpred(Arg(t,3),e,temp,NULL_ENV)); } int firsthalf(h,w) char h[], w[]; { register int i; for (i = 0; h[i] == w[i]; i++); if (h[i] == '\0') return(TRUE); else return(FALSE); } /* strcmp("ab","abc", X) -> X = '<' */ /* strcmp(+,+,-) */ int strcmp_pred(t,e) struct term *t; struct pair *e; { static char *emesg = "strcmp*/3: %s is not string"; register struct pair *p, *ee; struct term *a, *b; int result; a = Arg(t,0); b = Arg(t,1); ee = e; down(p,a,ee); if (! is_string(a)) { sprintf(nbuf,emesg,"1st"); error_detail(t,e,nbuf); } ee = e; down(p,b,ee); if (! is_string(b)) { sprintf(nbuf,emesg,"2nd"); error_detail(t,e,nbuf); } result = strcmp(str_value(a),str_value(b)); if (result < 0) return(equalpred(Arg(t,2),e,S_LESS,NULL_ENV)); else if (result == 0) return(equalpred(Arg(t,2),e,S_EQ,NULL_ENV)); else /* result > 0 */ return(equalpred(Arg(t,2),e,S_GREATER,NULL_ENV)); } int compare_pred(t,e) struct term *t; struct pair *e; { register struct pair *p, *ee; struct term *a, *b; float j; int i; ee = e; a = Arg(t,0); down(p,a,ee); ee = e; b = Arg(t,1); down(p,b,ee); if (is_num(a) && is_num(b)) { j = num_value(a) - num_value(b); if (j > 0.0) return(equalpred(Arg(t,2),e,S_GREATER,NULL_ENV)); else if (j == 0.0) return(equalpred(Arg(t,2),e,S_EQ,NULL_ENV)); return(equalpred(Arg(t,2),e,S_LESS,NULL_ENV)); } if (is_string(a) && is_string(b)) { i = strcmp(str_value(a),str_value(b)); if (i > 0) return(equalpred(Arg(t,2),e,S_GREATER,NULL_ENV)); else if (i == 0) return(equalpred(Arg(t,2),e,S_EQ,NULL_ENV)); return(equalpred(Arg(t,2),e,S_LESS,NULL_ENV)); } error_detail(t,e,"compare*/3: Args are mismatched"); } int atom_to_str_pred(t,e) struct term *t; struct pair *e; { struct term *t1,*ns; struct pair *e1,*p1; t1=Arg1(t); e1 = e; down(p1,t1,e1); if (p1 == NULL_ENV) /* arg1: bound */ { if (isconst_functor(t1)) { ns = Nstr(Predname(t1),ETERNAL); if (tunify(Arg2(t),e,ns,NULL_ENV,0)==TRUE) return(SYSTRUE); } return(SYSFAIL); } else error_detail(t,e,"atom_to_pred: 1st arg is free."); } /* count() predicate : count(X) -> X = 0,1,2,... count(3) -> set COUNTNUMBER in 3 */ long COUNTNUMBER = 0; /* used for count(gensym) predicate */ int count_pred(t,e) struct term *t; struct pair *e; { register struct pair *p; struct term *result; t = Arg(t,0); down(p,t,e); if (p != NULL) { result = Nnum_val((float)COUNTNUMBER,TEMPORAL); COUNTNUMBER++; return(equalpred(t,e,result,NULL_ENV)); } if (is_int(t)) { COUNTNUMBER=(long)num_value(t); return(SYSTRUE); } error_detail(t,e,"count/1: illegal argument."); } int gensym_pred(t,e) struct term *t; struct pair *e; { register struct term *tt; register struct pair *p, *ee; struct term *result; char newname[8]; if (t->t_arity == 2) { tt = Arg(t,0); ee = e; down(p,tt,ee); if (is_functor(tt)) strncpy(newname, tt->type.t_func->f_name,8); else if (is_string(tt)) strncpy(newname, str_value(tt), 8); else error_detail(t,e,"gensym/2: 1st Argument should be atom"); tt = Arg(t,1); ee = e; } else { /* gensym/1 */ tt = Arg(t,0); ee = e; strcpy(newname,genname); } down(p,tt,ee); if (p != NULL) { /* new function name is generated in nbuf[] */ while (1) { sprintf(nbuf,"%s%d", newname, GENSYM++); if (exist_fname(nbuf) == NULL) break; } result = Nterm(0,TEMPORAL); result->type.t_func = Predicate(nbuf,0); return(equalpred(tt,ee,result,NULL_ENV)); } else error_detail(t,e,"gensym/1:Argument should be Variable"); } int kstrlen(str) char *str; { register unsigned char *c; register float n; #if KANJI != 1 return(strlen(str)); #else for (c=(unsigned char *)str,n=0; *c != '\0'; c++) { if (*c > EUCOS) n+=0.5; else n++; } return( (int)n ); #endif } int kpoint(s,n) /* return the point after nth Kanji char */ unsigned char *s; int n; { register unsigned char *c; register int i; register float l; #if KANJI != 1 return(n); #else for (c=s,l=i=0; *c != '\0'; c++,i++) { if (l == (float) n) break; if (*c > EUCOS) l+=0.5; else l++; } return(i); #endif } oL(nbuf, FROM_CONC); } else if (is_string(x)) tt = CtoL(str_value(x), FROM_CONC); else tt = CtoL(x->type.t_func->f_name, FROM_CONC); return(equalpred(y,ey,tt,NULL_ENV)); } int strlen_pred(t,e) struct term *t; struct pair *e; { struct term *s, *l; struct pair *es, *el, *p; int len; s = Arg(t,0); l = Arg(src/tr_split.c 644 10266 36 35215 5712121412 6771 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << tr_split.c >> * divide constraint into equivalence classes * 93.8.2 speedup copy_term * 93.8.2 speedup copy_term --------------------------------------------------------------------*/ #include "include.h" #define DEBUG 0 extern struct cset *DEF_list; extern struct cset *CSTR_list; extern struct cset *INITDEF_list; extern int CSTR_number; extern struct clause *CONST_literals, *REST_literals; extern struct itrace *newfsave; extern jmp_buf trans_fail; /* sub functions for transform.c (divide clause into equivalence classes)*/ /* this modulue uses global vars: CONST_literals, REST_literals * . . split+ . . . vconstraint. . . . attach+ . . . . is_modular_literal~ . . . . attach_arg+ . . . . . novar . . . . . replace_terms+ . . . . has_no_var+ . . . . . novar~ . . . divide_consts . . . . has_no_pst+ . . . delete_constraint+ . . . remove_modular_literals+ . . . . is_modular_literal~ */ /* ------------- begin 'split' ------------------ */ struct clause *CONST_PST_literals; /* used in split, divide_consts */ /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ split(clist,vlist,anum) split a clause clist into equivalence class vlist = variable list of clist anum = # of variables + # of PSTs in clist global vars: CONST_literals : no vars and no psts REST_literal : modular literals +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct compartment *split(clist, vlist, anum) struct clause *clist; struct term *vlist; int anum; { register struct term *v; register struct compartment *cmp,*cmplast; struct clause *cnext,*remove_modular_literals(); void divide_consts(); CONST_literals = NULL; /* global vars */ REST_literals = NULL; CONST_PST_literals = NULL; clist = remove_modular_literals(clist); if (clist == NULL) return(NULL); else if (vlist == NULL) /* no variable */ divide_consts(clist); /* CONST or CONST_PST? */ else { /* clear_vconstraint(vlist) */ for (v = vlist; v != NULL; v = vlink(v)) vconstraint(v) = NULL; if (attach(clist, vlist,anum) == FALSE) return((struct compartment *)MFAIL); delete_constraint(vlist); } for (cmplast = NULL; CONST_PST_literals != NULL; CONST_PST_literals = cnext) { cnext = CONST_PST_literals->c_link; CONST_PST_literals->c_link = NULL; MEMORY_ALLOC(cmp,compartment,TEMPORAL); cmp->cmp_clause = CONST_PST_literals; cmp->cmp_link = cmplast; cmplast = cmp; } for (v = vlist; v != NULL; v = vlink(v)) if (vconstraint(v) != NULL){ MEMORY_ALLOC(cmp,compartment,TEMPORAL); cmp->cmp_clause = vconstraint(v); cmp->cmp_link = cmplast; cmplast = cmp; } return(cmplast); } /* remove modular literals in cl into REST_literals */ struct clause *remove_modular_literals(cl) struct clause *cl; { register struct clause *cnext; if (cl == NULL) return(NULL); if (is_modular_literal(cl->c_form)) { cnext = cl->c_link; cl->c_link = REST_literals; REST_literals = cl; return(remove_modular_literals(cnext)); } else { cnext = cl->c_link; cl->c_link = remove_modular_literals(cnext); return(cl); } } void delete_constraint(vl) /* vconstraint(v)=NULL for all vl */ struct term *vl; { register struct term *v1, *v2; register struct clause *c; for (v1 = vl; v1 != NULL; v1 = vlink(v1)) { if (vconstraint(v1) == NULL) continue; c = vconstraint(v1); for (v2 = vlink(v1); v2 != NULL; v2 = vlink(v2)) if (vconstraint(v2) == c) vconstraint(v2) = NULL; } } int has_no_pst(t) /* check pst in arguments */ struct term *t; { register int i; for (i = 0; i < Pred(t)->f_arity; i++) if (is_pst(Arg(t,i))) return(FALSE); return(TRUE); } void divide_consts(cl) /* cl: constraint clauses */ struct clause *cl; { register struct clause *c,*cnext; for (c = cl; c != NULL; c = cnext) { cnext = c->c_link; c->c_link = NULL; if (has_no_pst(c->c_form)) { c->c_link = CONST_literals; CONST_literals = c; } else { c->c_link = CONST_PST_literals; CONST_PST_literals = c; } } } int Attached; /* used in attach, attach_arg */ int attach(c, vl,anum) /* split main */ register struct clause *c; struct term *vl; int anum; { struct clause *cnext; register struct term *t; register int i, j; while (c != NULL) { cnext = c->c_link; c->c_link = NULL; t = c->c_form; j = Pred(t)->f_mark; if (has_no_var(t)) { c->c_link = CONST_literals; CONST_literals = c; } else if ((j & NON_UNFOLDABLE) != 0) { i = satisfiable(c,anum); j &= STAY_IF; if (((i == TRUE) && (j != 0)) || ((i == FALSE) && (j == 0))) { j = Pred(t)->f_arity; for (i = 0; i < j; i++) attach_arg(Arg(t,i),c,vl); } else if ((i == TRUE) && (j == 0)) /* do nothing */ ; else /* in case of FAIL */ return(FALSE); } else if (is_modular_literal(t)) { c->c_link = REST_literals; REST_literals = c; } else { /* attach_term(c,vl); */ Attached = 0; j = Pred(t)->f_arity; for (i = 0; i < j; i++) attach_arg(Arg(t,i),c,vl); if (Attached == 0) divide_consts(c); } c = cnext; } return(TRUE); } void attach_arg(arg,c,vl) /* sub of attach */ struct term *arg,*vl; struct clause *c; { register int i; if (novar(arg)) return; /* printf("attach_arg arg=");Pterm(arg,NULL); printf(" c=");Pclause(c,NULL); NL; */ if (isvar(arg)) { if (arg->type.ident == VAR_GLOBAL_TYPE) { /* 1991-03-02 */ if (vconstraint(arg) == NULL) vconstraint(arg) = c; else replace_terms(vconstraint(arg),c,vl); Attached = 1; /* global var */ return; } else return; } if (is_list(arg) || is_clause(arg)) { attach_arg(head_of_list(arg),c,vl); attach_arg(tail_of_list(arg),c,vl); return; } if (is_pst(arg)) { struct eclause *plists; plists = ((struct pst *)arg)->p_lists; while (plists != NULL_ECL) { attach_arg(Arg2(plists->c_form),c,vl); plists = plists->c_link; } return; } for (i = 0; i < Pred(arg)->f_arity; i++) attach_arg(Arg(arg,i),c,vl); } void replace_terms(c1,c2,vl) struct clause *c1; register struct clause *c2; struct term *vl; { register struct term *v; if (c1 == c2) return; for (v = vl; v != NULL; v = vlink(v)) if (vconstraint(v) == c1) vconstraint(v) = c2; while (c2->c_link != NULL) c2 = c2->c_link; c2->c_link = c1; } /* ------------- end of 'split' ------------------ */ /* --------------- begin 'variant' ---------------- */ struct vpair *VPAIR; /* vpair of var,pst */ int Consider_Vacuous, /* consider vacuous or not */ PST_level; /* depth of pst */ #define TPHASHSIZE 59 struct vpair *Tpair[TPHASHSIZE]; /* hashed vpair for terms */ int termpairtype(t) struct term *t; { return(((int)t) % TPHASHSIZE); } void print_Tpair_length() /* for debug */ { int i; for (i=0; iv_clause,NULL); if (va->v_pair == NULL) return; putchar('\n'); for (vp=va->v_pair; vp != NULL; vp=vp->v_link) { printf("<"); Pterm(vp->v1,NULL);putchar(','); Pterm(vp->v2,NULL);putchar('>'); } } void Pvpair(va) struct vpair *va; { register struct vpair *vp; for (vp=va; vp != NULL; vp=vp->v_link) { printf("<"); Pterm(vp->v1,NULL);putchar(':'); Pterm(vp->v2,NULL);printf("> "); } } int vpair_length(vp) struct vpair *vp; { register int i; for(i = 0; vp != NULL; i++, vp=vp->v_link); return(i); } /* [variant]----------------------------------- . copy_clause . . copy_term . . . Npstobj~ . . . in_sheap~ . . . copy_arg+ . . . . has_common_label . . . . store_vpair . . . exist_termpair. . . . exist_vpair. . . . copy_pst+ . . . . Npst . . . . store_vpair~ . . . . copy_eclause+ . . . store_termpair . . . var_trans+ . . . . store_vpair~ */ /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ variant(cl,flag) : normal copy variant_v(cl,flag) : consider vacuous arguments make a variant of a clause cl ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct variant *variant_main(cl,flag) struct clause *cl; int flag; { struct variant *ccopy; VPAIR = (struct vpair *)NULL; /* global vars */ clear_Tpair(); v_list = pv_list = NULL; v_number = p_number = 0; PST_level = 0; MEMORY_ALLOC(ccopy,variant,TEMPORAL); ccopy->v_clause = copy_clause(cl,flag); ccopy->v_var = v_list; ccopy->v_anum = v_number + p_number; ccopy->v_pair = VPAIR; if (p_number != 0) renum_pvars((struct pstvar *)pv_list,v_number); /* print_Tpair_length(); */ return(ccopy); } struct variant *variant(cl,flag) struct clause *cl; int flag; { Consider_Vacuous = 0; return(variant_main(cl,flag)); } struct variant *variant_v(cl,flag) /* variant considering vacuous args */ struct clause *cl; int flag; { Consider_Vacuous = 1; return(variant_main(cl,flag)); } void store_vpair(told,tnew) /* store told->tnew (var,pst)in VPAIR */ struct term *told,*tnew; { register struct vpair *vp,*p,*op; MEMORY_ALLOC(vp,vpair,TEMPORAL); vp->v1 = told; vp->v2 = tnew; if (VPAIR==NULL || VPAIR->v1 > told) { vp->v_link = VPAIR; VPAIR = vp; return; } for (p=VPAIR; p != NULL; op=p,p=p->v_link) if (told < p->v1) break; vp->v_link = p; /* ...op->vp->p->... */ op->v_link = vp; } struct term *exist_vpair(t) /* check if t is in VPAIR */ struct term *t; { register struct vpair *vp; for (vp = VPAIR; vp != NULL; vp = vp->v_link) if (t <= vp->v1) { if (vp->v1 == t) return(vp->v2); else return(NULL); } return(NULL); } void store_termpair(told,tnew) /* store told->tnew (term) to TermPAIR */ struct term *told,*tnew; { register struct vpair *vp; register int tt; MEMORY_ALLOC(vp,vpair,TEMPORAL); vp->v1 = told; vp->v2 = tnew; tt = termpairtype(told); vp->v_link = Tpair[tt]; Tpair[tt] = vp; } struct term *exist_termpair(t) /* check if t is in TermPAIR */ struct term *t; { register struct vpair *vp; for (vp = Tpair[termpairtype(t)]; vp != NULL; vp = vp->v_link) if (vp->v1 == t) return(vp->v2); return(NULL); } struct clause *copy_clause(cl,flag) /* sub. of variant */ struct clause *cl; int flag; { struct term *copy_term(); if (cl == NULL) return(NULL); return(Nclause(copy_term(cl->c_form,flag), copy_clause(cl->c_link,flag), flag) ); } struct term *copy_term(t,flag) /* variant of t */ struct term *t; int flag; { struct term *nt, *copy_pst(), *copy_arg(); register int i; if (t == NULL_TERM || is_atomic(t)) return(t); else if (isvar(t)) { if ((nt = exist_vpair(t)) != NULL) return(nt); /* check history */ return(var_trans(t,flag)); /* t is var */ } else if (is_pst(t)) { if ((nt = exist_vpair(t)) != NULL) return(nt); /* check history */ PST_level++; nt = copy_pst((struct pst *)t,flag); /* t is PST */ PST_level--; return(nt); } else if ((nt = exist_termpair(t)) != NULL) return(nt); /* check history */ switch(t->type.ident) { /* atom, complex term, eclause */ case CONST_LIST_TYPE: if (in_sheap(t) || flag != ETERNAL) return(t); case LIST_TYPE: nt = (struct term *)Nlist(copy_term(head_of_list(t),flag), (struct clause *)copy_term(tail_of_list(t),flag), flag); break; case CLAUSE_TYPE: nt = (struct term *)Nclause(copy_term(head_of_list(t),flag), (struct clause *)copy_term(tail_of_list(t),flag),flag); break; case ECLAUSE_TYPE: /* pst object */ nt = (struct term *)Npstobj(copy_term(((struct eclause *)t)->c_form,flag), NULL_ENV, (struct eclause *) copy_term((struct term *)((struct eclause *)t)->c_link, flag), flag); break; /* case VAR_VOID_TYPE: return(Anonymous_var); case VAR_PST_TYPE: error("System error occurrs at 'copy_term'"); */ default: if (isconst_functor(t)) nt = up_const_functor(t,flag); else { nt = Nterm(t->t_arity,flag); Pred(nt) = Pred(t); if (Consider_Vacuous == 1) for (i = 0; i < t->t_arity; i++) Arg(nt,i) = copy_arg(t,i,flag); else for (i = 0; i < t->t_arity; i++) Arg(nt,i) = copy_term(Arg(t,i),flag); } } store_termpair(t,nt); return(nt); } struct term *copy_pst(pt,flag) /* copy pst */ struct pst *pt; int flag; { register struct pst *p; register struct term *nt; struct eclause *copy_eclause(); nt = exist_termpair((struct term *)pt); if (nt != NULL) { if (PST_level == 1) store_vpair((struct term *)pt,nt); return(nt); } p = Npst(flag); ((struct pstvar *)(p->p_var))->old_var = pt->p_var; p->p_lists=(struct eclause *)copy_term((struct term *)pt->p_lists,flag); if (PST_level == 1) /* top level PST */ store_vpair((struct term *)pt,(struct term *)p); else store_termpair((struct term *)pt,(struct term *)p); return((struct term *)p); } struct term *var_trans(v, flag) /* var that corresponds to v */ struct term *v; int flag; { register struct term *nv; if is_voidvar(v) return(Anonymous_var); sprintf(nbuf,"V%d",v_number); nv = Nvar(nbuf,flag); voccurrence(nv) = voccurrence(v); vheadoccurrence(nv) = vheadoccurrence(v); store_vpair(v,nv); return(nv); } struct term *copy_arg(t,i,flag) /* copy ith argument of t with vacuity check */ struct term *t; int i,flag; { register struct term *arg,*nt; arg = Arg(t,i); if (is_pst(arg) && (PST_level == 1) && !has_common_label( ((struct pst *)arg)->p_lists,Component(Pred(t),i))) { struct term *nv; if ((nt = exist_vpair(arg)) != NULL) return(nt); /* check history */ if ((nt = exist_termpair(arg)) != NULL) return(nt); /* check history */ sprintf(nbuf,"P%d",v_number); nv = Nvar(nbuf,flag); store_vpair(arg,nv); return(nv); } else return(copy_term(arg,flag)); } /* ---------- end of 'variant' ----------------- */ _link; } return; } for (i = 0; i < Pred(arg)->f_arity; i++) attach_arg(Arg(arg,i),c,vl); } void replace_terms(c1,c2,vl) struct clause *c1; register struct clause *c2; struct term *vl; { register struct term *v; if (c1 == c2) return; for (v = vl; v != NULL; v = vlink(v)) if (vconstraint(v) == c1) vconstraint(v) = c2; while (c2->c_link != Nsrc/tr_sub.c 644 10266 36 52710 5712121412 6426 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< tr_sub.c >>>> * subroutines for constraint transformation (called by transform.c) * 95.1.27 satisfiable (save global vars) --------------------------------------------------------------------*/ #include "include.h" #define DEBUG 0 /* when debug, 1 */ extern struct cset *DEF_list; extern struct cset *CSTR_list; extern struct cset *INITDEF_list; extern int CSTR_number; extern int old_CSTR_number; extern struct clause *CONST_literals, *REST_literals; extern struct itrace *newfsave; extern jmp_buf trans_fail; int cs_status_type(st) int st; { static char cs_status_list[9] = { 'u','r','m','i','d','g','f','x','t'}; if (st > TEMPORAL_DEFINED) return('?'); else return(cs_status_list[st]); } void Pcset_def(cs) /* print cset */ struct cset *cs; { tprint3("[%d(%c,%d)] ",cs->cs_number, cs_status_type((int)cs->cs_status), Pred(cs->cs_clause->c_form)->f_setcount); P_dclause(cs->cs_clause,NULL_ENV); } void Pcset_cstr(cs) /* print cset */ struct cset *cs; { tprint2("<%d(%c)> ",cs->cs_number, cs_status_type((int)cs->cs_status)); P_hclause(cs->cs_clause,NULL_ENV); } void P_csnumber(cs,mode) struct cset *cs; int mode; { register struct cset *c; int i = 0; for (c = cs; c != NULL; c = c->cs_link) if ((mode == 1 && c->cs_status == DERIVATION) || (mode == 2 && c->cs_status == UNTOUCHED) || (mode == 3 && (c->cs_status == MODULAR_DEFINED || c->cs_status == UNIT_DEFINED))) { if (i != 0) { tputc(','); } i = 1; tprint1("%d",c->cs_number); } } /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++ P_status() print DEF_list, CSTR_list . . P_status+ . . . P_csnumber+ . . . Pcset_cstr+ . . . . cs_status_type. . . . . d. . . . Pcset_def+ . . . . cs_status_type~ . . . . d~ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ void P_status() /* print DEF_list,CSTR_list (for debug) */ { register struct cset *cs; tprint0("****"); tprint0("DEFS={");P_csnumber(DEF_list,1);tprint0("} "); tprint0("NON-MODULAR={");P_csnumber(CSTR_list,2);tprint0("} "); tprint0("MODULAR={");P_csnumber(CSTR_list,3);tprint0("}****"); for (cs = DEF_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status != FALSE_REGISTERED && cs->cs_number >= old_CSTR_number) {NL;Pcset_def(cs);} /* if (cs->cs_status == DERIVATION) {NL;Pcset_def(cs);}*/ for (cs = CSTR_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status != REMOVED && cs->cs_number >= old_CSTR_number) {NL;Pcset_cstr(cs);} /* if (cs->cs_status == UNTOUCHED) {NL;Pcset_cstr(cs);}*/ old_CSTR_number=CSTR_number; } struct cset *Ncset(flag) /* allocate cset structure */ int flag; { register struct cset *s; MEMORY_ALLOC(s,cset,flag); s->cs_clause = NULL; s->cs_link = NULL; s->cs_vlist = NULL; s->cs_anumber = s->cs_cnum = 0; s->cs_status = UNTOUCHED; /* defalut status */ s->cs_number = CSTR_number++; s->cs_mother = NULL; return(s); } /* ------- add c to CSTR_list (in apply_add_clause) -------*/ struct cset *CSTR_tail; /* tail of CSTR_list used in add_clause() */ void add_clause(c, vlist, anum) struct clause *c; struct term *vlist; int anum; { register struct cset *cs; struct func *f; void set_temporal_def(); f = Pred(c->c_form); f->f_setcount++; recalc_voccurrence(c,vlist); cs = Ncset(TEMPORAL); if (c->c_link == NULL) { f->f_unitcount++; cs->cs_status = UNIT_DEFINED; if (Is_Msolvable) set_temporal_def(f); } else if (is_modular_clause(c->c_link)) cs->cs_status = MODULAR_DEFINED; else cs->cs_status = UNTOUCHED; cs->cs_clause = c; cs->cs_vlist = vlist; cs->cs_anumber = anum; cs->cs_link = CSTR_list; CSTR_list = cs; } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ add_cs_to_set(cs,flag) register new predicates . . --> tr_sub.c . . . [variant] . . . add_set . . . . setconcat+ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void add_cs_to_set(cs,flag) /* register new predicates */ struct cset *cs; int flag; { register struct set *s; register struct variant *va; struct variant *variant(); s = snew(set); va = variant(cs->cs_clause,ETERNAL); s->s_clause = va->v_clause; s->s_anumber = va->v_anum; s->s_vlist = va->v_var; s->s_constraint = NULL; s->s_bodynumber = 0; /* set in add_set */ add_set(s,flag); } /* ---------- reduction ----------------- */ /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ struct eclause *reduce_clause(cl,e) reduce predicates which have only one definition . reduce_clause . . reduce_clause_m+ . . . [tunify] . . . [system_function] . . . Neclause . . . one_def_literal+ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct eclause *reduce_clause(cl,e) /* entry */ struct clause *cl; struct pair *e; { struct ustack *usave = usp; int *hsave = hp; struct pair *esave = ep; struct eclause *reduce_clause_m(); register struct eclause *res; res = reduce_clause_m(cl,e); if (res == (struct eclause *)MFAIL) { undo(usave); hp = hsave; ep = esave; } return(res); } struct eclause *reduce_clause_m(cl,e) /* reduce_clause sub */ struct clause *cl; struct pair *e; { register struct set *s; struct pair *e1; if (cl == NULL) return(NULL); if (is_functor(cl->c_form) && ((Pred(cl->c_form)->f_mark & NON_UNFOLDABLE) == 0)) { if ((s = one_def_literal(Pred(cl->c_form))) != NULL) /* reduceable */ { if (s == (struct set *)MFAIL) /* error in one_def_literal */ return((struct eclause *)MFAIL); e1 = Nenv(s->s_anumber); if (tunify(cl->c_form,e,s->s_clause->c_form,e1,1)==FALSE) return((struct eclause *)MFAIL); else return( eclause_conc( reduce_clause(cl->c_link,e), eclause_conc( reduce_clause(s->s_constraint,e1), reduce_clause(s->s_clause->c_link,e1)))); } else if (is_funcsys(Pred(cl->c_form))) { struct node *dummy; dummy = Newnode(NULL,NULL,NULL,NULL,NULL); if (system_function(cl->c_form,e,dummy) == SYSFAIL) return((struct eclause *)MFAIL); else return(reduce_clause(cl->c_link,e)); } } return(Neclause(cl->c_form,e,reduce_clause(cl->c_link,e),MEDIUM)); } struct set *one_def_literal(f) /* reduce_clause_m sub */ struct func *f; { if (isuser(f)) { switch (f->f_setcount) { case 1: return(f->def.f_set); case 0: if (Handle_Undefined == TRUE) { sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name); error(nbuf); } else return((struct set *)MFAIL); default: return(NULL); } } else return(NULL); } void reorder_clause(cl, tc) struct clause *cl, *tc; { register struct clause *c; for (c = cl; c != NULL; c = c->c_link) if (c->c_link == tc) break; if (c == NULL) return; c->c_link = tc->c_link; tc->c_link = cl->c_link; cl->c_link = tc; return; } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++ int satisfiable(cl,anum) ---> TRUE/FALSE check satisfiability of constraint . . satisfiable . . . [refute] +++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int satisfiable(cl,anum) /* satisfiability check */ struct clause *cl; int anum; { int tflagsave; /* save tflag */ struct ustack *usave = usp; struct node *Last_Node, *Initial_Goal,*lbsave,*lssave; tflagsave = tflag; /* save prolog trace flag */ Notrace_mode; /* for satisfiable() */ upush(&hp);upush(&ep); upush(&Last_BT);upush(&Last_SKIP); Initial_Goal = Last_Node = Newnode(cl, NULL_ECL, Nenv(anum), (struct node *)NULL,(struct node *)NULL); lbsave=Last_BT; lssave=Last_SKIP; /* 95.1.27 */ Last_BT = Last_SKIP = NULL; if (refute(Initial_Goal, Last_Node, DOWN) == FALSE) { undo(usave); tflag = tflagsave; Last_BT = lbsave; Last_SKIP = lssave; return(FALSE); } undo(usave); Last_BT = lbsave; Last_SKIP = lssave; tflag = tflagsave; return(TRUE); } /* ++++++++++++++++++++++++++++++++++++++++++++++++++ struct clause *target_literal(cl) select unfolding target from cl [target_literal]----------------------------------- . Penergy+ . energy . . isconst . . voccurrence. . . isallunit+ . greater_term . . greater_arg . . . cmp_clause+ . . . cmp_cplxt+ . . . cmp_flt+ . . . cmp_fp+ . . . cmp_int+ . . . cmp_list+ . . . cmp_var . . . cmp_pst+ . . . cmp_str+ . . . arg_type+ ++++++++++++++++++++++++++++++++++++++++++++++++++ */ void Penergy(cl) struct clause *cl; { register struct clause *c; for (c = cl; c != NULL; c = c->c_link) { Pterm(c->c_form,NULL); tprint1("<%d>,",energy(c->c_form)); } } struct clause *target_literal(cl) struct clause *cl; { register struct clause *ct, *c; register int cte,ce; #if DEBUG == 1 printf("ENERGY: "); Penergy(cl); NL; #endif if (cl->c_link == NULL) return(cl); ct = cl; cte = energy(ct->c_form); for (c = cl->c_link; c != NULL; c = c->c_link) { ce = energy(c->c_form); if (ce > cte) { cte = ce; ct = c; } else if (ce == cte && greater_term(ct->c_form,c->c_form)) continue; } return(ct); } int Hueristic_modified = 0; int Factor_con, Factor_funct, Factor_vn, Factor_defs, Factor_units, Factor_rec, Factor_allunit; /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ int energy(term) energy of term +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ int energy(tm) /* enegy function of literal t */ struct term *tm; { int arity = 0, con = 0, vn = 0, funct = 0, rec = 0, allunit = 0, defs = 0, units = 0, energy; struct func *f; register struct term *t; register int i; f = Pred(tm); arity = f->f_arity; for (i = 0; i < arity; i++) { if (Component(f,i) == NULL) continue; t = Arg(tm,i); if (isconst(t)) con++; else if (isvar(t)) vn+=(voccurrence(t) - 1); else funct++; } rec = isrecursive(f); allunit = isallunit(f); defs = f->f_setcount; units = f->f_unitcount; energy = con * 7 - arity + funct * 4 + vn * 2 - defs*2 + units*2 - rec * 4 + allunit * 6; return(energy); } /* general predicates for transform.c */ struct clause *surface_copy_clause(cl,flag) /* make copy of cl */ struct clause *cl; int flag; { if (cl == NULL) return(NULL); return(Nclause(cl->c_form, surface_copy_clause(cl->c_link,flag), flag)); } int is_modular_clause(cl) /* check if clause cl is modular */ struct clause *cl; { register struct clause *c; for (c = cl; c != NULL; c = c->c_link) { if (! is_modular_literal(c->c_form)) return(FALSE); } return(TRUE); } int is_modular_literal(t) /* check if literal t is modular */ struct term *t; { struct func *f; register int i; register struct term *arg; int has_common_label(); /* mainsub.c */ if (! is_functor(t)) { wfp = stderr; Pterm(t,NULL_ENV); error("Only Functors can be used as Constraints"); } f = Pred(t); /* if (is_component_not_checked(f)) recalc_f_roles(f);*/ for (i = 0; i < f->f_arity; i++) { if (Component(f,i) == NULL) continue; else { arg = Arg(t,i); if (isvar(arg) && voccurrence(arg) <= 1) continue; if (is_pst(arg) && ! has_common_label(((struct pst *)arg)->p_lists, Component(f,i))) continue; else return(FALSE); } } return(TRUE); } int has_no_var(t) /* check if t contains no variable */ struct term *t; { register int i; for (i = 0; i < Pred(t)->f_arity; i++) if (! novar(Arg(t,i))) return(FALSE); return(TRUE); } struct eclause *eclause_conc(ec1,ec2) /* concatenate eclauses */ struct eclause *ec1,*ec2; { register struct eclause *ec; if (ec1 == NULL) return(ec2); if (ec2 == NULL) return(ec1); if (ec1 == (struct eclause *)MFAIL||ec2 == (struct eclause *)MFAIL) return((struct eclause *)MFAIL); ec = ec1; while (ec->c_link != NULL) ec = ec->c_link; ec->c_link = ec2; return(ec1); } /* * sort_clause * insert_clause * greater_term * greater_arg * arg_type * cmp_var,cmp_cplxt,cmp_list,cmp_flt,cmp_int,cmp_str,cmp_fp */ struct clause *sort_clause(cl) /* sort clause for fold transformation */ struct clause *cl; { if (cl == NULL) return(NULL); return(insert_clause(cl, sort_clause(cl->c_link))); } struct clause *insert_clause(ct, cl) /* insert ct into cl */ struct clause *ct,*cl; { register struct clause *c,*cbefore; ct->c_link = NULL; if (cl == NULL) return(ct); if (greater_term(ct->c_form,cl->c_form)) { /* ct > top of cl? */ ct->c_link = cl; return(ct); } for (c = cl; c != NULL; cbefore = c, c = c->c_link) if (greater_term(ct->c_form,c->c_form)) /* ct > c? */ break; cbefore->c_link = ct; ct->c_link = c; return(cl); } #define ARG_EQ 0 #define ARG_TRUE 1 #define ARG_FALSE 2 /* term comparator */ int greater_term(t1,t2) /* t1 > t2 ?? */ struct term *t1,*t2; { register int i,cp; if (Pred(t1)->f_number != Pred(t2)->f_number) return(Pred(t1)->f_number > Pred(t2)->f_number); for(i = 0; i < Pred(t1)->f_arity; i++) if ((cp = greater_arg(Arg(t1,i),Arg(t2,i))) != ARG_EQ) return(cp == ARG_TRUE); return(FALSE); } /* argument type: 0 variable (cmp_var) 1 complex term that has a variable (cmp_cplxt) 2 list that has a variable (cmp_list) 3 complex term without variable (cmp_cplxt) 4 list without variable (cmp_list) 5 atom, floating number (cmp_flt) 6 atom, integer number (cmp_int) 7 atom, string (cmp_str) 8 atom, filepointer (cmp_fp) 9 clause (cmp_clause) 10 pst (cmp_pst) */ int arg_type(a) /* return argument type */ struct term *a; { switch (a->type.ident) { case VAR_VOID_TYPE: case VAR_PST_TYPE: case VAR_GLOBAL_TYPE: return(0); case ATOMIC_TYPE: return(5 + a->t_arity); case LIST_TYPE: return(2); case CONST_LIST_TYPE: return(4); case CLAUSE_TYPE: return(9); case PST_TYPE: return(10); default: if (a->t_arity <= 0) return(3); return(1); } } int greater_arg(a1,a2) /* a1 > a2 ? */ struct term *a1,*a2; { int cp; int atype1 = arg_type(a1),atype2 = arg_type(a2); if ((cp = (atype1 - atype2)) != 0) if (cp > 0) return(ARG_TRUE); else return(ARG_FALSE); switch(atype1){ case 0 : return(cmp_var(a1,a2)); case 1 : return(cmp_cplxt(a1,a2)); case 2 : return(cmp_list(a1,a2)); case 3 : return(cmp_cplxt(a1,a2)); case 4 : return(cmp_list(a1,a2)); case 5 : return(cmp_flt(a1,a2)); case 6 : return(cmp_int(a1,a2)); case 7 : return(cmp_str(a1,a2)); case 8 : return(cmp_fp(a1,a2)); case 9 : return(cmp_clause(a1,a2)); case 10: return(cmp_pst(a1,a2)); } return(ARG_FALSE); } int cmp_var(a1,a2) /* compare variable a1 > a2??*/ struct term *a1,*a2; { register int i; i = voccurrence(a1) - voccurrence(a2); if (i == 0) return(ARG_EQ); else if (i > 0) return(ARG_TRUE); else return(ARG_FALSE); } int cmp_cplxt(a1,a2) /* compare complex terms */ struct term *a1,*a2; { register int i,cp; if (Pred(a1)->f_number != Pred(a2)->f_number) return(Pred(a1)->f_number > Pred(a2)->f_number); for(i = 0; i < Pred(a1)->f_arity; i++) if ((cp = greater_arg(Arg(a1,i),Arg(a2,i))) != ARG_EQ) return(cp); return(ARG_EQ); } int cmp_list(a1,a2) /* compare list */ struct term *a1,*a2; { int cp; if (a1 == NIL || a2 == NIL) if (a1 == a2) return(ARG_EQ); else if (a1 == NIL) return(ARG_TRUE); else return(ARG_FALSE); if (isvar(a1)) { /* patch 1991-03-03 */ if (isvar(a2)) return(cmp_var(a1,a2)); else return(ARG_FALSE); } if (cp = greater_arg(head_of_list(a1), head_of_list(a2)) != ARG_EQ) return(cp); else return(cmp_list(tail_of_list(a1),tail_of_list(a2))); } int cmp_clause(a1,a2) /* compare clause */ struct term *a1,*a2; { int cp; if (a1 == NULL || a2 == NULL) if (a1 == a2) return(ARG_EQ); else if (a1 == NULL) return(ARG_TRUE); else return(ARG_FALSE); if (cp = greater_arg(head_of_list(a1), head_of_list(a2)) != ARG_EQ) return(cp); else return(cmp_clause(tail_of_list(a1),tail_of_list(a2))); } int cmp_flt(a1,a2) struct term *a1,*a2; { float cp; cp = num_value(a1) - num_value(a2); if (cp == 0) return(ARG_EQ); else if (cp > 0) return(ARG_TRUE); else return(ARG_FALSE); } int cmp_int(a1,a2) struct term *a1,*a2; { register int cp; cp = (int)num_value(a1) - (int)num_value(a2); if (cp == 0) return(ARG_EQ); else if (cp > 0) return(ARG_TRUE); else return(ARG_FALSE); } int cmp_str(a1,a2) struct term *a1,*a2; { register int cp; cp = strcmp(str_value(a1), str_value(a2)); if (cp == 0) return(ARG_EQ); else if (cp > 0) return(ARG_TRUE); else return(ARG_FALSE); } int cmp_fp(a1,a2) struct term *a1,*a2; { register int cp; cp = filep_value(a1) - filep_value(a2); if (cp == 0) return(ARG_EQ); else if (cp > 0) return(ARG_TRUE); else return(ARG_FALSE); } int cmp_pst(a1,a2) struct term *a1, *a2; { register struct eclause *e1, *e2; int cp; e1 = ((struct pst *)a1)->p_lists; e2 = ((struct pst *)a2)->p_lists; while ((e1 != NULL_ECL) && (e2 != (struct eclause *)NULL)) { if ((cp = greater_arg(e1->c_form,e2->c_form)) != ARG_EQ) return(cp); e1 = e1->c_link; e2 = e2->c_link; } if (e1 == e2) return(ARG_EQ); else if (e2==NULL_ECL) return(ARG_TRUE); else return(ARG_FALSE); } /* c.t. step trace subroutine */ /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ int step_asking() . . step_asking+ . . . [apply] . . . nth_cset+ . . . nth_literal+ . . . quit_transformation+ . . . reorder_clause+ . . . skip_cr+ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int step_asking() /* c.t. step trace --> 0(auto),1(cont) */ { tprint0("\n@step ? "); while(1) { switch(getchar()) { case '?' : case 'h' : tprint0("NOTATION: [(,)]"); tprint0("New Predicate <=> unmodular body\n"); tprint0("\t : U=untouched, M=modular_defined,") tprint0("I=unit_defined, D=Derived,\t\tG=registered,"); tprint0("F=False, R=Reduced, T=Temporary\n"); tprint0("COMMNAD: q:quit\tz:abort"); tprint0("\tn:normal trace\tx:trace off"); tprint0("\nb:break\tCR: continue"); tprint0("\tu : manual unfolding\n"); skip_cr(); break; case 'b': { int *hsave = hp; struct pair *esave = ep; struct ustack *usave = utop; struct cset *deflist_save = DEF_list, *cstrlist_save = CSTR_list, *initdeflist_save = INITDEF_list; struct clause *constliterals_save = CONST_literals, *restliterals_save = REST_literals; int cstrnumber_save = CSTR_number; utop = usp; if (setjmp(unbreak_reset)) { utop = usave; hp = hsave; ep = esave; DEF_list = deflist_save; CSTR_list = cstrlist_save; INITDEF_list = initdeflist_save; CONST_literals = constliterals_save; REST_literals = restliterals_save; CSTR_number = cstrnumber_save; break; } while(1) { prolog_execution(); } } case 'q' : quit_transformation(); /* quit */ longjmp(trans_fail,1); case 'z' : abandon_transformation(); /* abort */ longjmp(trans_fail,1); case 'u' : {int cnum,lnum; /* manual unfolding */ struct cset *tc; struct clause *tl; scanf("%d %d",&cnum,&lnum); skip_cr(); tc = nth_cset(cnum); if (tc == NULL) { tprint1("Error: no clause %d",cnum); break; } tl = nth_literal(tc->cs_clause->c_link,lnum); if (tl == NULL) { tprint0("Error: literal out of range"); break; } tc->cs_status = REMOVED; if (tc->cs_status != DERIVATION) /* in CSTR_list */ Pred(tc->cs_clause->c_form)->f_setcount--; reorder_clause(tc->cs_clause, tl); tprint1("manual_unfold [%d] ",lnum); Pterm(tc->cs_clause->c_link->c_form,NULL); if (apply(tl->c_form,tc->cs_clause->c_form, tl->c_link,tc->cs_anumber) == FALSE) tprint0(" ->FAIL\n") else tprint0(" =>TRUE\n") return(1); } case 'x' : CTnotrace; Notrace_mode; skip_cr();return(0); /* no trace */ case 'n' : CTnormal; skip_cr();return(0);/* normal trace */ case '\n': return(0); /* continue in automode */ default : break; } } } struct cset *nth_cset(n) /* cset whose cs_number = n */ int n; { register struct cset *c; for (c = DEF_list; c != NULL; c = c->cs_link) if (c->cs_status == DERIVATION && c->cs_number == n) return(c); for (c = CSTR_list; c != NULL; c = c->cs_link) if (c->cs_status != REMOVED && c->cs_number == n) return(c); return(NULL); } struct clause *nth_literal(cl,n) struct clause *cl; int n; { register struct clause *c; register int i; for (c = cl, i = 1; c != NULL; c = c->c_link, i++) if (i == n) return(c); return(NULL); } void skip_cr() /* skip user's input "....CR" */ { while( getchar() != '\n') ; } void show_newdefs() /* show newly defined clauses */ { register struct cset *cs; register struct func *f; for (cs = DEF_list; cs != NULL; cs = cs->cs_link) { f = Pred(cs->cs_clause->c_form); if isnoreduced(f) Showfunc(f); } } )->f_number); for(i = 0; i < Pred(t1)->f_arity; i++) src/trans.c 644 10266 36 51010 5712121412 6247 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << trans.c >> * constriant transformation module * 1992-Nov-4 sort bodies literals. (new_constraint, unfold_derivation) --------------------------------------------------------------------*/ #include "include.h" #define DEBUG 0 /* if debug, 1 */ struct cset *DEF_list; /* sets of new predicate derivation clauses */ struct cset *CSTR_list; /* sets of non-modular clauses */ struct cset *INITDEF_list; /* sets of non-modular clauses */ int CSTR_number; int old_CSTR_number; struct clause *CONST_literals, *REST_literals; /* used in split, attach */ struct itrace *newfsave; /* old newf_list */ jmp_buf trans_fail; /* transformation failure */ /* [startmodular]----------------------------------- . abandon_transformation . . --> new.c . . reducedfun+ . add_to_set+ . . index_newflist~ . . --> tr_sub.c . clear_up_DEF . . remove_from_CSTR . end_unfoldfold+ . . + ---> mainsub.c . foldunfold+ . . + ------> tr_sub.c . . set_temporal_def . . + ------> tr_sub.c . . check_INITDEF+ . . is_modular_head+ . . . vheadoccurrence. . . unfold_cstr+ . . . [apply] . . . [target_literal] . . . from_to+ . . . insert_cs+ . . . reorder. . . unfold_derivation+ . . . [apply] . . . [target_literal] . . . literalnumber~ . . . reorder~ . modular_form . . -------> tr_sub.c . . + ---------> split.c . . surface_copy_clause+ . . Pcmp+ . . new_constraint+ . . . + ---> modular.c . . . + ---> tr_split.c . . . new_pred_set+ . . . . newpred+ . . . . set_new_def+ . . . . vpair_length+ . . set_const_pst+ . init_unfoldfold+ */ /* ------------ begin init & end unfoldfold --------------*/ void init_unfoldfold() { newfsave = newf_list; /* save newf_list */ DEF_list = NULL; /* derivation clauses */ CSTR_list = NULL; /* new clauses */ old_CSTR_number = CSTR_number = 0; /* initial clause number */ INITDEF_list = NULL; /* initial derivation clauses */ } void end_unfoldfold() { void recalc_component(); /* mainsub.c */ recalc_component(); CSTR_list = NULL; /* new clauses */ old_CSTR_number = CSTR_number = 0; /* initial clause number */ INITDEF_list = NULL; /* initial derivation clauses */ } /* when transformation fails, */ void abandon_transformation() /* abandon all new predicates */ { register struct cset *cs; register struct func *f; newf_list = newfsave; /* restore newf_list (init_unfoldfold) */ for (cs = INITDEF_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status == FALSE_REGISTERED) { f = Pred(cs->cs_clause->c_form); if (f->f_integ == NULL) continue; index_func(f); reducedfun(f); f->def.f_set = NULL; f->f_unitcount = f->f_setcount = 0; f->f_integ->it_link = newf_list; newf_list = f->f_integ; } newf_list = index_newflist(newf_list,newfsave); } void quit_transformation() /* quit transformation (in step trace) */ { register struct cset *cs; register struct func *f; for (cs = DEF_list; cs != NULL; cs = cs->cs_link) { f = Pred(cs->cs_clause->c_form); f->f_setcount = f->f_unitcount = 0; /* reset in add_cs_to_set*/ if (cs->cs_status == REGISTERED || cs->cs_status == REMOVED) index_func(f); /* register into global hash table */ else if (cs->cs_status == DERIVATION) { index_func(f); /* register into global hash table */ add_cs_to_set(cs,'a'); } } for (cs = CSTR_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status != REMOVED) add_cs_to_set(cs,'a'); } /* ------------ end init & end unfoldfold --------------*/ int check_INITDEF() /* INITDEF_list is satisfiable ??*/ { register struct cset *cs; for(cs = INITDEF_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status == FALSE_REGISTERED) return(FALSE); return(TRUE); } void remove_from_CSTR(f) /* used in clear_up_DEF */ struct func *f; { register struct cset *cs; register struct clause *c; for (cs = CSTR_list; cs != (struct cset *)NULL; cs = cs->cs_link) if (cs->cs_status == MODULAR_DEFINED || cs->cs_status == UNTOUCHED) for(c = cs->cs_clause; c != NULL_CL; c = c->c_link) if (Pred(c->c_form) == f) { cs->cs_status = REMOVED; Pred(cs->cs_clause->c_form)->f_setcount--; break; } } void clear_up_DEF() /* delete useless clauses */ { register struct cset *cs; register struct func *f; int changed = 1; while(changed == 1) { changed = 0; for (cs = DEF_list; cs != NULL; cs = cs->cs_link) { if (cs->cs_status == REMOVED){ f = Pred(cs->cs_clause->c_form); if (f->f_unitcount > 0) cs->cs_status = REGISTERED; else if (f->f_setcount == 0) { changed = 1; cs->cs_status = FALSE_REGISTERED; f->f_integ->it_clause->c_form = FAIL; remove_from_CSTR(f); } } } } } void add_to_set() /* register definition clauses */ { register struct cset *cs; register struct func *f; newf_list = index_newflist(newf_list,newfsave); for (cs = DEF_list; cs != NULL; cs = cs->cs_link) { f = Pred(cs->cs_clause->c_form); if (cs->cs_status == REGISTERED || cs->cs_status == REMOVED) index_func(f); /* register into global hash table */ f->f_setcount = f->f_unitcount = 0; /* reset in add_cs_to_set*/ } for (cs = CSTR_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status == MODULAR_DEFINED || cs->cs_status == UNIT_DEFINED || (Is_Msolvable && (cs->cs_status == TEMPORAL_DEFINED))) add_cs_to_set(cs,'a'); } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ startmodular(clist,vlist,anum) constraint transformation entry ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct clause *startmodular(clist, vlist, anum) /* entry */ struct clause *clist; struct term *vlist; int anum; { int result; register struct clause *c; init_unfoldfold(); /* reset gloval vars */ if (clist != NULL) clist = modular_form(clist,vlist,anum); /* set DEF_list */ if (clist == NULL || clist == MFAIL ||DEF_list == NULL) { end_unfoldfold(); return(clist); /* no need for transformation */ } INITDEF_list = DEF_list; /* initial derivation clauses */ TTB if (setjmp(trans_fail)) /* quit/abort transformation */ { /* <-- step_asking() */ end_unfoldfold(); /* if clist has defs */ for (c = clist; c != NULL; c = c->c_link) { if (Pred(c->c_form)->def.f_set == (struct set *)NULL) return(MFAIL); } return(clist); } TTE result = foldunfold(); if (result == TRUE) /* transformation success */ { clear_up_DEF(); add_to_set(); end_unfoldfold(); return(clist); } else { /* transformation failure */ abandon_transformation(); end_unfoldfold(); return(MFAIL); } } void Pcmp(cmp) /* print compartment */ struct compartment *cmp; { for (; cmp != NULL; cmp = cmp->cmp_link) { Pclause(cmp->cmp_clause,NULL);NL; } if (CONST_literals != NULL) { printf("ground = "); Pclause(CONST_literals,NULL);NL; } if (REST_literals != NULL) { printf("rest = "); Pclause(REST_literals, NULL);NL; } } /* define new predicates */ struct clause *modular_form(clist, vlist, anum) struct clause *clist; struct term *vlist; int anum; { struct compartment *cmp,*cm; struct clause *crest, *cc; register struct clause *c; void set_const_pst(); cmp = split(surface_copy_clause(clist,TEMPORAL), vlist, anum); if (cmp == (struct compartment *)MFAIL) return(MFAIL); /* global vars */ crest = REST_literals; /* printf("split "); Pclause(clist,NULL); printf("into\n"); Pcmp(cmp); NL; */ if (CONST_literals != NULL) if (! satisfiable(CONST_literals,anum)) return(MFAIL); for (cm = cmp; cm != NULL; cm = cm->cmp_link) { cc = c = new_constraint(cm); if (c == MFAIL) return(MFAIL); if (c == NULL) continue; while (c->c_link != NULL) c = c->c_link; /* c <- end of cc */ c->c_link = crest; crest = cc; } return(crest); } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++ new_constraint(cmp) change cmp into surface modular form by making new predicates or folding . . new_constraint+ . . . try_fold+ . . . . match+ . . . . . match_term+ . . . . termnumber . . . variant_v+ . . . . Pvariant+ . . . new_pred_set+ . . . . newpred+ . . . . set_new_def+ . . . . vpair_length+ . . . variables+ ++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ struct clause *new_constraint(cmp) /* make new pred or folding */ struct compartment *cmp; { struct term *t; struct clause *c,*new_pred_set(); struct variant *ccopy,*variant_v(); c = sort_clause(cmp->cmp_clause); /* 92/11/4 BUG fix */ cmp->cmp_clause = c; if (c == NULL) return(NULL); if (is_modular_clause(c)) return(c); /* here works in future */ /* if (!need_trans(cmp)) returnc(restore_head(c->c_form,cmp->cmp_vp,cmp->cmp_vp_size)); */ ccopy = variant_v(c,MEDIUM); if (ccopy->v_anum > MODULARMAX) /* heuristics */ { FILE *f = wfp; wfp = stderr; tprint0("Warning: Transformation failure by exceeding the"); tprint0("limit of the number of variables (cf) %%M command\n"); Pterm(c,NULL_ENV);NL; wfp = f; return(MFAIL); } t = try_fold(c, ccopy->v_anum); if (t != NULL) { TTB tprint0("#folding "); Pclause(c,NULL); tprint0(" ==> "); Pterm(t,NULL); TTE STAT_FOLD++; /* statistics */ if (t == FAIL) return(MFAIL); else return(Nclause(t,NULL,MEDIUM)); } return(new_pred_set(ccopy)); } struct clause *new_pred_set(cc) /* set new pred & return */ struct variant *cc; { struct func *newfunc; struct term *t1,*t2; struct clause *c1,*c2; register struct vpair *a; register int i; int arity,vpair_length(); /* tr_split.c */ STAT_DEF++; /* statistics */ while (1) { sprintf(nbuf, "%s%d", genname, GENSYM++); if (exist_fname(nbuf) == NULL) break; } arity = vpair_length(cc->v_pair); newfunc = Nfunc(TEMPFUN, nbuf, arity); newpred(newfunc); (t1 = Nterm(arity,MEDIUM))->type.t_func = newfunc; /* orig. head */ (t2 = Nterm(arity,MEDIUM))->type.t_func = newfunc; /* copy head */ c1 = Nclause(t1,NULL,MEDIUM); /* new constraint */ c2 = Nclause(t2,cc->v_clause,MEDIUM); /* new head == body */ for (i = arity - 1, a = cc->v_pair; 0 <= i; i--,a=a->v_link) { Arg(t1,i) = a->v1; Arg(t2,i) = a->v2; } set_new_def(c2,cc->v_var,cc->v_anum); /* to DEF_list */ return(c1); } void set_new_def(c,vl,anum) /* add c to DEF_list */ struct clause *c; /* head == body. */ struct term *vl; int anum; { register struct cset *s; s = Ncset(TEMPORAL); s->cs_status = DERIVATION; s->cs_clause = c; s->cs_link = DEF_list; s->cs_anumber = anum; s->cs_vlist = vl; DEF_list = s; /* global var */ } int is_modular_head(t) /* check head t is modular or not */ struct term *t; { struct func *f; register int i; register struct term *arg; if (! is_functor(t)) { wfp = stderr; Pterm(t,NULL_ENV); error("Only Functors can be used as Constraints"); } f = Pred(t); for (i = 0; i < f->f_arity; i++) { arg = Arg(t,i); if (isvar(arg)) { if (vheadoccurrence(arg) > 1) /* double occurrence */ return(FALSE); } else if (is_pst(arg)) continue; /* 91.10.1 ??? */ else return(FALSE); } return(TRUE); } /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ foldunfold() fold/unfold transformation loop +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int foldunfold() /* fold-unfold transformation main */ { register struct cset *cs; struct clause *body; register struct func *f; void unfold_derivation(),unfold_cstr(),set_temporal_def(); for (;;) { clear_up_DEF(); if (check_INITDEF() == FALSE) return(FALSE); TTB P_status(); /* print stack */ if Is_ctstep if (step_asking() != 0) continue; /* user's input */ TTE /* target def-clause */ for (cs = DEF_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status == DERIVATION) break; if (cs != NULL) /* unfold def-clause */ { STAT_UNFOLD++; unfold_derivation(cs); continue; } /* get one clause from CSTR_list*/ for (cs = CSTR_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status == UNTOUCHED) break; if (cs == NULL) return(TRUE); /* no target --> fail */ f = Pred(cs->cs_clause->c_form); if (is_modular_head(cs->cs_clause->c_form)) { STAT_UNFOLD++; unfold_cstr(cs); continue; } body = modular_form(cs->cs_clause->c_link, cs->cs_vlist, cs->cs_anumber); cs->cs_clause->c_link = body; if (body == MFAIL) /* fail transformation */ { cs->cs_status = REMOVED; f->f_setcount--; } else if (body == NULL) /* unit definition */ { cs->cs_status = UNIT_DEFINED; f->f_unitcount++; /* M-solvability */ if (Is_Msolvable) set_temporal_def(f); TTB tprint1("#reduce body <%d>",cs->cs_number); TTE } else { cs->cs_status = MODULAR_DEFINED; TTB tprint1("#modularize <%d>",cs->cs_number); TTE } } } void set_temporal_def(f) struct func *f; { register struct cset *cs; for (cs = CSTR_list; cs != (struct cset *)NULL; cs = cs->cs_link) { switch (cs->cs_status) { case UNTOUCHED: if (f == Pred(cs->cs_clause->c_form)) cs->cs_status = TEMPORAL_DEFINED; break; case MODULAR_DEFINED: if (f == Pred(cs->cs_clause->c_link->c_form)) { cs->cs_status = TEMPORAL_DEFINED; set_temporal_def(Pred(cs->cs_clause->c_form)); } } } } struct clause *reorder(cl,tc) /* used in unfold_derivation, _cstr */ struct clause *cl,*tc; /* cl:literals, tc:target literal */ { register struct clause *c; if (cl == NULL_CL) return(NULL_CL); for (c = cl; c != NULL_CL; c = c->c_link) if (c->c_link == tc) break; if (c == NULL_CL) return(cl); else { c->c_link = tc->c_link; tc->c_link = cl; return(tc); } } void unfold_derivation(cs) /* unfold derivation clause (in unfoldfold) */ struct cset *cs; { struct clause *tc,*ccopy; struct func *f; struct itrace *it; int res; ccopy = surface_copy_clause(cs->cs_clause,ETERNAL); tc = target_literal(cs->cs_clause->c_link); cs->cs_clause->c_link = reorder(cs->cs_clause->c_link,tc); if (tc == NULL) /* no need for transformation */ { cs->cs_status = REGISTERED; return; } TTB /* print target literal */ tprint1("#unfold-[%d] ",cs->cs_number); Pterm(tc->c_form,NULL); TTE res = apply(tc->c_form,cs->cs_clause->c_form, tc->c_link,cs->cs_anumber); f = Pred(cs->cs_clause->c_form); f->f_integ = it = snew(itrace); it->it_clause = ccopy; /* BUG 92/11/4 */ it->it_anumber = cs->cs_anumber; it->it_cnumber = literalnumber(cs->cs_clause->c_link); it->it_link = newf_list; newf_list = it; if (res == FALSE) { it->it_clause->c_form = FAIL; cs->cs_status = FALSE_REGISTERED; remove_from_CSTR(f); TTB tprint0(" ->FAIL"); TTE } else { if (f->f_unitcount > 0) cs->cs_status = REGISTERED; else cs->cs_status = REMOVED; TTB tprint0(" =>TRUE"); TTE } } void insert_cs(cs,newcs) /* used in unfold_cstr */ struct cset *cs, *newcs; /* append newcs after cs */ { register struct cset *c; if (newcs == NULL) return; for (c = newcs; c->cs_link != NULL; c = c->cs_link); /* c <= end of newcs */ c->cs_link = cs->cs_link; cs->cs_link = newcs; } struct cset *from_to(s1,s2) /* used in unfold_cstr */ struct cset *s1,*s2; /* s1->..->c->s2 ===> s1->..->c->NULL*/ { struct cset *c; if (s1 == s2) return(NULL); for (c = s1; c->cs_link != s2; c= c->cs_link); c->cs_link = NULL; return(s1); } void unfold_cstr(cs) /* unfold CSTR clause (in unfoldfold) */ struct cset *cs; { struct clause *tc; struct func *f; int res; struct cset *cstr_save; /* old CSTR_list */ f = Pred(cs->cs_clause->c_form); tc = target_literal(cs->cs_clause->c_link); cs->cs_clause->c_link = reorder(cs->cs_clause->c_link,tc); if (tc == NULL) /* no need for transformation */ { cs->cs_status = MODULAR_DEFINED; return; } TTB /* print target literal */ tprint1("#unfold=[%d] ",cs->cs_number); Pterm(tc->c_form,NULL); TTE f->f_setcount--; cs->cs_status = REMOVED; cstr_save = CSTR_list; res = apply(tc->c_form,cs->cs_clause->c_form, tc->c_link,cs->cs_anumber); if (res == FALSE) { TTB tprint0(" ->FAIL"); TTE } else { struct cset *newcs; newcs = from_to(CSTR_list,cstr_save); /* new defs */ CSTR_list = cstr_save; insert_cs(cs,newcs); /* put newcs after cs */ TTB tprint0(" =>TRUE"); TTE } } /* [apply]-------------------- head unification & goal replacement . [system_function] . ---> defsysp.c . ---> tr_sub.c . apply_add_clause . . ---> modular.c . . ---> tr_sub.c . . + ---> tr_sub.c . extend_apply+ . . [tunify] . . eclause_conc. */ int apply(target,head,rest,anum) /* head:-target,rest. */ struct term *target,*head; struct clause *rest; int anum; { struct pair *e0; struct func *f = Pred(target); struct node *dummy; struct eclause *ec; struct pair *esave = ep; struct ustack *usave = usp; if (anum > 0) e0=Nenv(anum); else e0=NULL_ENV; if (issystem(f)) { dummy = Newnode(NULL,NULL,NULL,NULL,NULL); if (isfunc(f)) { if (system_function(target,e0,dummy) == SYSFAIL) { ep = esave; return(FALSE); } /* has solution */ ec = reduce_clause(rest,e0); if (ec == (struct eclause *)MFAIL) { ep = esave; return(FALSE); } apply_add_clause(head,e0,ec); ep = esave; return(TRUE); } else { /* isnonfunc */ if (system_pred(target,e0,dummy,dummy,DOWN) == SYSFAIL) return(FALSE); /* has possibly many solutions */ do { ec = reduce_clause(rest,e0); apply_add_clause(head,e0,ec); undo(usave); if (anum > 0) e0 = Nenv(anum); else e0=NULL_ENV; } while (system_pred(target,e0,dummy,dummy,BACKTRACK) == SYSTRUE); ep = esave; undo(usave); return(TRUE); } } /* user predicate */ return(extend_apply(target,head,rest,e0,f,f->def.f_set)); } int extend_apply(target,head,rest,e0,f,s) /* in apply */ struct term *target,*head; struct clause *rest; struct pair *e0; struct func *f; register struct set *s; { struct eclause *ec; struct ustack *usave = usp; int *hsave,cn; struct pair *e1; if (s == (struct set *)NULL) { if (Handle_Undefined == TRUE) { sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name); error(nbuf); } else return(FALSE); } for (cn = 0 ; s != NULL; s = s->s_link) { hsave = hp; if (s->s_ground_head) /* no var/PST in the head */ { if (tunify(target,e0, s->s_clause->c_form,NULL,2)==FALSE) /* safe unify */ { hp = hsave; continue; } if (s->s_anumber > 0) e1 = Nenv(s->s_anumber); else e1 = NULL_ENV; } else { if (s->s_anumber > 0) e1 = Nenv(s->s_anumber); else e1 = NULL_ENV; if (tunify(target,e0, s->s_clause->c_form,e1,2)==FALSE) /* safe unify */ { hp = hsave; continue; } } ec = eclause_conc(reduce_clause(s->s_clause->c_link, e1), eclause_conc(reduce_clause(s->s_constraint,e1), reduce_clause(rest,e0))); if (apply_add_clause(head,e0,ec)!=FALSE) cn++; /* # of new clauses */ undo(usave); /* restore environments */ } if (cn == 0) return(FALSE); else return(TRUE); } int apply_add_clause(head,e0,ec) /* in apply, extend_apply */ struct term *head; struct pair *e0; struct eclause *ec; { struct clause *newbody; struct term *newhead; struct pair *e1; int i; if (ec == (struct eclause *)MFAIL) return(FALSE); up_init(); newhead = termset(head, e0,MEDIUM); newbody = up_eclause(ec,MEDIUM); if (p_number != 0) { renum_pvars((struct pstvar *)pv_list,v_number); if (p_number > 0) e1=Nenv(p_number); else e1=NULL_ENV; i = p_number; while (i > 0) { i--; e1[i].p_body = ((struct pstvar *)pv_list)->old_var; e1[i].p_env = e0; pv_list = ((struct pstvar *)pv_list)->v_link; } } up_restore(); if (newbody != NULL && v_number == 0 && p_number == 0) { /* containts no variables */ if (satisfiable(newbody,0)) newbody = NULL; else return(FALSE); } add_clause(Nclause(newhead,newbody,MEDIUM), v_list, v_number+p_number); return(TRUE); } om CSTR_list*/ for (cs = CSTR_list; cs != NULL; cs = cs->cs_link) if (cs->cs_status == UNTOUCHED) break; if (cs == NULL) return(TRUE); /* no target --> fail */ f = Pred(cs->cs_clause->c_form); if (is_modular_head(cs->cs_clause->c_form)) { STAT_UNFOLD++; unfold_cstr(cs); continue; } body = modular_form(cs->cs_clause->c_link, cs->cs_vlist, cs->cs_anumber); cs->cs_clause->c_link = body; if (body == MFAIL) /* fail transformation */ { cs->cs_status = REMOsrc/unify.c 644 10266 36 37674 5712121412 6276 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * << UNIFY.C >> * safe/unsafe/PST unification * 94.5.20 remove_pst_ob * 94.6.27 pst_unify, remove_pst_object_if_not_equal() --------------------------------------------------------------------*/ #include "include.h" #define Npstobj(Head,Env,Tail,Flag) Neclause(Head,Env,Tail,Flag) #define UNSAFE 0 #define SAFE 1 #define NOEXTRACT 2 #define EXTRACT 3 #define PSTDEBUG 0 int Ocheck_max; /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ int tunify(t,e,u,f,flag) term unification between (t,e) and (u,f) flag = 0: unsafe 1: safe, no extract 2: safe, extract return_value --> TRUE/FALSE +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int tunify(t,e,u,f,flag) /* term unification entry */ register struct term *t, *u; register struct pair *e, *f; int flag; /* 1:safe no-extract, 2:safe extract, 0:unsafe */ { struct ustack *usave = usp; int *hsave = hp, res; struct pair *esave = ep; Ocheck_max = 0; if (flag == 1) res = safe_unify(t,e,u,f,NOEXTRACT); else if (flag == 2) res = safe_unify(t,e,u,f,EXTRACT); else res = unify(t,e,u,f); if (res == FALSE) { undo(usave); hp = hsave; ep = esave; return(FALSE); } else return(TRUE); } struct pair *LastEnv; /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ int tunify_apply(t,e,u,newf,flag) newf= newly-defined environment does not push the address in newf +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ int tunify_apply(t,e,u,f,flag) /* term unification entry */ register struct term *t, *u; register struct pair *e, *f; int flag; /* 1:safe no-extract, 2:safe extract, 0:unsafe (only) */ { struct ustack *usave = usp; int *hsave = hp, res; struct pair *esave = ep; LastEnv=f; res = tunify(t,e,u,f,flag); LastEnv=NULL_ENV; return(res); } int ocheck(p, t, e) /* occur check of normal unification */ /* check if var p is contained in (t,e) if contained, return FALSE, else return TRUE */ register struct pair *p; /* var */ register struct term *t; register struct pair *e; { register struct pair *q; register int i, j; if (Ocheck_max++ > 50) return(FALSE); /* in case of infinite loop */ /* printf("ocheck "); Pterm(p->p_body, p->p_env); printf(" in "); Pterm(t,e); NL; */ if (t == NULL_TERM) return(TRUE); down(q, t, e); if (q != NULL_ENV) { /* if t is var */ if (p == q) /* occured !! ==> fail */ return(FALSE); else return(TRUE); } switch (t->type.ident) { case ATOMIC_TYPE: case CONST_LIST_TYPE: return(TRUE); case LIST_TYPE: case CLAUSE_TYPE: if (ocheck(p,head_of_list(t),e) == TRUE && ocheck(p,tail_of_list(t),e) == TRUE) return(TRUE); else return(FALSE); case PST_TYPE: { /* pst */ struct eclause *ptt; struct pst_item *item; if ((item = find_pstitem(t,e)) == NULL_PSTIT) { ptt = ((struct pst *)t)->p_lists; while (ptt != NULL_ECL) { t = Arg2(ptt->c_form); if (ocheck(p,t,e) == FALSE) return(FALSE); ptt = ptt->c_link; } } else { ptt = item->p_lists; while (ptt != NULL_ECL) { t = Arg2(ptt->c_form); e = ptt->c_env; if (ocheck(p, t, e) == FALSE) return(FALSE); ptt=ptt->c_link; } } return(TRUE); } default: /* functor */ for(i = 0, j = t->t_arity; i < j; i++) if (ocheck(p, Arg(t,i), e) == FALSE) return(FALSE); } return(TRUE); } int unify(t, e, u, f) register struct term *t, *u; register struct pair *e, *f; { register struct pair *p, *q; #if PSTDEBUG == 1 printf("unify:"); Pterm(t,e); printf(" and "); Pterm(u,f); NL; #endif down(p, t, e); down(q, u, f); if (p != NULL_ENV) /* if t = var */ if (p==Anonymous_env) return(TRUE); /* if t = Anonymous Var */ else if(q != NULL) /* t:var, u:var */ if(p == q) /* t,u : the same var */ return(TRUE); else if (q==Anonymous_env) /* u : Anonymous Var */ return(TRUE); else { if (e != LastEnv) { upush(&(p->p_body)); /* t->u */ upush(&(p->p_env)); } p->p_body = u; p->p_env = f; return(TRUE); } else { /* t:var, u:non-var */ if (e != LastEnv) { upush(&(p->p_body)); /* t->u */ upush(&(p->p_env)); } p->p_body = u; p->p_env = f; return(TRUE); } else if(q != NULL) if (q==Anonymous_env) return(TRUE); else { /* t:nonvar , u:var */ if (f != LastEnv) { upush(&(q->p_body)); /* u->t */ upush(&(q->p_env)); } q->p_body = t; q->p_env = e; return(TRUE); } /* t,u : nonvar */ switch (u->type.ident) { case ATOMIC_TYPE : /* t,u: atomic (string,num,quote) */ { if ((t==u) || (atomic_equal(u,t))) return(TRUE); else return(FALSE); } case LIST_TYPE: case CONST_LIST_TYPE: if (is_list(t)) { if(unify(head_of_list(t),e,head_of_list(u),f) && unify(tail_of_list(t),e,tail_of_list(u),f)) return(TRUE); } return(FALSE); case CLAUSE_TYPE: if (is_clause(t)) { while ((t != NULL) && (u != NULL)) { if (unify(((struct clause *)t)->c_form,e, ((struct clause *)u)->c_form,f) == FALSE) return(FALSE); t=(struct term *)((struct clause *)t)->c_link; u=(struct term *)((struct clause *)u)->c_link; } if (t == u) return(TRUE); } return(FALSE); case PST_TYPE: if (is_pst(t)) { return(pst_unify(t,e,u,f,UNSAFE)); } return(FALSE); default : /* functor */ if(Pred(t) == Pred(u)) {/* t,u: complex term */ register int i, j; for(i = 0, j = Pred(t)->f_arity; i < j; i++) if (unify(Arg(t,i), e, Arg(u,i), f) == FALSE) return(FALSE); /* unify each arg */ return(TRUE); } return(FALSE); } } int unify_pst_extract(); int safe_unify(t, e, u, f, extflag) /* unify with occur check */ register struct term *t, *u; register struct pair *e, *f; int extflag; /* NOEXTRACT or EXTRACT */ { register struct pair *p, *q; int i, j; #if PSTDEBUG == 1 printf("safe_unify "); Pterm(t,e); printf(" and "); Pterm(u,f); NL; #endif down(p, t, e); down(q, u, f); if(p != NULL) /* if t = var */ if (p==Anonymous_env) return(TRUE); /* if t = Anonymous Var */ else if(q != NULL) /* t:var, u:var */ if(p == q) /* t,u : the same var */ return(TRUE); else if (q==Anonymous_env) /* u : Anonymous Var */ return(TRUE); else { if (e != LastEnv) { upush(&(p->p_body)); /* t->u */ upush(&(p->p_env)); } p->p_body = u; p->p_env = f; return(TRUE); } else { /* t:var, u:non-var */ if (ocheck(p,u,f) == FALSE) return(FALSE); if (e != LastEnv) { upush(&(p->p_body)); /* t->u */ upush(&(p->p_env)); } p->p_body = u; p->p_env = f; return(TRUE); } else if(q != NULL) if (q==Anonymous_env) return(TRUE); else { /* t:nonvar , u:var */ if (ocheck(q,t,e) == FALSE) return(FALSE); if (f != LastEnv) { upush(&(q->p_body)); /* u->t */ upush(&(q->p_env)); } q->p_body = t; q->p_env = e; return(TRUE); } /* t,u : nonvar */ switch (u->type.ident) { case ATOMIC_TYPE : /* t,u: atomic (string,num,quote) */ { if ((t==u) || (atomic_equal(u,t))) return(TRUE); else return(FALSE); } case LIST_TYPE: case CONST_LIST_TYPE: if (is_list(t) && safe_unify(head_of_list(t),e,head_of_list(u),f,extflag) == TRUE && safe_unify(tail_of_list(t),e,tail_of_list(u),f,extflag) == TRUE) return(TRUE); else return(FALSE); case CLAUSE_TYPE: if (is_clause(t)) { while ((t != NULL) && (u != NULL)) { if (safe_unify(((struct clause *)t)->c_form,e, ((struct clause *)u)->c_form,f,extflag) == FALSE) return(FALSE); t=(struct term *)((struct clause *)t)->c_link; u=(struct term *)((struct clause *)u)->c_link; } if (t == u) return(TRUE); } return(FALSE); case PST_TYPE: if (is_pst(t)) { /* if (extflag == NOEXTRACT) pst_unify(t,e,u,f,SAFE); else unify_pst_extract(t,e,u,f); */ return(pst_unify(t,e,u,f,SAFE)); } else return(FALSE); default : /* functor */ if(Pred(t) == Pred(u)) {/* t,u: complex term */ for(i = 0, j = Pred(t)->f_arity; i < j; i++) if (safe_unify(Arg(t,i), e, Arg(u,i), f,extflag) == FALSE) return(FALSE); /* unify each arg */ return(TRUE); } return(FALSE); } } int pst_unify(t,e,u,f,safeflag) register struct term *t,*u; register struct pair *e,*f; int safeflag; /* SAFE(1) or UNSAFE(0) */ { struct pst_item *target, *object; #if PSTDEBUG != 0 printf("pst_unify %d ",safeflag); Pterm(t,e); printf(" & "); Pterm(u,f); printf(" ---> "); #endif target = find_pstitem(t,e); if (target != NULL_PSTIT) { object = remove_pstitem_if_not_equal(u,f,target); if (object == target) /* p.var==t.var */ { #if PSTDEBUG != 0 printf(""); #endif return(TRUE); } else if (object != NULL_PSTIT) /* t,u exist in psttable */ { #if PSTDEBUG != 0 printf(""); #endif if (unify_merge_psts(target,object->p_lists,safeflag) == FALSE) return(FALSE); } else { /* t exist, u doesn't exist */ #if PSTDEBUG != 0 printf(""); #endif if (unify_pstlist_objects(target,((struct pst *)u)->p_lists, f, safeflag) == FALSE) return(FALSE); } if (unify(((struct pst *)u)->p_var,f, ((struct pst *)t)->p_var,e) == FALSE) return(FALSE); /* u.var -> t.var */ } else { object = find_pstitem(u,f); if (object != NULL_PSTIT) /* t doesn't exist, u:exists */ { #if PSTDEBUG != 0 printf(""); #endif if (unify_pstlist_objects(object,((struct pst *)t)->p_lists, e, safeflag) == FALSE) return(FALSE); if (unify(((struct pst *)t)->p_var,e, ((struct pst *)u)->p_var,f) == FALSE) return(FALSE); /* t.var -> u.var */ } else { /* t,u don't exist */ #if PSTDEBUG != 0 printf(""); #endif target = record_pstobjects((struct pst *)t,e); if (unify_pstlist_objects(target,((struct pst *)u)->p_lists, f, safeflag)==FALSE) return(FALSE); if (unify(((struct pst *)u)->p_var,f, ((struct pst *)t)->p_var,e) == FALSE) return(FALSE); /* u.var -> t.var */ } } #if PSTDEBUG != 0 Pterm(t,e); NL; #endif return(TRUE); } /* one-way unification */ int unify_pst_extract(t,e,u,f) /* safe, extract pst unification */ struct pst *t,*u; /* t may be changed */ struct pair *e,*f; { struct pst_item *object,*target; struct eclause *nttbegin,*ntt,*ot,*tt; int i; target = find_pstitem(t,e); object = find_pstitem(u,f); if (target == NULL_PSTIT) target = record_pstobjects((struct pst *)t,e); if (object == NULL_PSTIT) object = record_pstobjects((struct pst *)u,f); nttbegin=NULL_ECL; for(ot=object->p_lists,tt=target->p_lists; ((ot!=NULL) && (tt!=NULL));) { i = Pred(Arg1(tt->c_form))->f_number - Pred(Arg1(ot->c_form))->f_number; if (i == 0) { if (safe_unify(tt->c_form,e,ot->c_form,f,1) == FALSE) return(FALSE); tt = tt->c_link; ot = ot->c_link; } else if (i < 0) tt = tt->c_link; else { /* ntt is in (u,f), but not in (t,e) */ if (nttbegin==NULL) nttbegin=ntt=ot; else { upush(&(ntt->c_link)); ntt->c_link = ot; ntt = ot; } ot = ot->c_link; } } if (nttbegin != NULL) { upush(&(ntt->c_link)); ntt->c_link = ot; } else nttbegin = ot; upush(&(target->p_lists)); target->p_lists = nttbegin; /* new target = (u,f)-(t,e) */ return(TRUE); } int unify_pstlist_objects(entry, ol, e, safeflag) struct pst_item *entry; struct eclause *ol; struct pair *e; int safeflag; /* SAFE or UNSAFE */ { register int i; struct eclause *pl; if (ol==NULL_ECL) return(TRUE); pl=entry->p_lists; /* pl must NOT be NULL */ #if PSTDEBUG != 0 printf("unify_pstlist_obj "); Peclause(pl); printf(" -- "); Peclause(ol); NL; #endif if (pl == NULL_ECL) { upush(&(entry->p_lists)); entry->p_lists=record_pstlists(ol,e); return(TRUE); } i = Pred(Arg1(pl->c_form))->f_number - Pred(Arg1(ol->c_form))->f_number; if (i == 0) { if (safeflag == UNSAFE) { if (unify(pl->c_form,pl->c_env,ol->c_form,e) == FALSE) return(FALSE); } else { if (safe_unify(pl->c_form,pl->c_env,ol->c_form,e,NOEXTRACT) == FALSE) return(FALSE); } ol=ol->c_link; } /* pl={f1/v1,f2/v2,..} object={g1/t1,g2/t2,...}, f1 > g1 */ /* --> pl={g1/t1,f1/v1,...} object={g2/t2,...} */ else if (i > 0) { upush(&(entry->p_lists)); entry->p_lists = Npstobj(ol->c_form,e,pl,MEDIUM); ol = ol->c_link; pl=entry->p_lists; } /* else goes on */ for (; ol != NULL_ECL && pl->c_link != NULL_ECL; ) { i = Pred(Arg1(pl->c_link->c_form))->f_number - Pred(Arg1(ol->c_form))->f_number; if (i == 0) { if (safeflag== UNSAFE) { if (unify(pl->c_link->c_form,pl->c_link->c_env, ol->c_form,e) == FALSE) return(FALSE); } else { if (safe_unify(pl->c_link->c_form,pl->c_link->c_env, ol->c_form,e,NOEXTRACT) == FALSE) return(FALSE); } ol = ol->c_link; pl = pl->c_link; } else if (i > 0) { upush(&(pl->c_link)); pl->c_link = Npstobj(ol->c_form,e,pl->c_link,MEDIUM); ol = ol->c_link; pl = pl->c_link; } else { pl = pl->c_link; } } if (pl->c_link == NULL_ECL) { upush(&(pl->c_link)); pl->c_link = record_pstlists(ol,e); } return(TRUE); } int unify_merge_psts(target,object,safeflag) struct pst_item *target; struct eclause *object; int safeflag; /* SAFE or UNSAFE */ { register int i; struct eclause *pnext,*onext, *pl; if (object==NULL_ECL) return(TRUE); pl=target->p_lists; if (pl == NULL_ECL) { upush(&(target->p_lists)); target->p_lists = object; return(TRUE); } i = Pred(Arg1(pl->c_form))->f_number - Pred(Arg1(object->c_form))->f_number; if (i == 0) { if (safeflag == UNSAFE) { if (unify(pl->c_form,pl->c_env, object->c_form,object->c_env) == FALSE) return(FALSE); } else { if (safe_unify(pl->c_form,pl->c_env, object->c_form,object->c_env,EXTRACT) == FALSE) return(FALSE); } object=object->c_link; } /* pl={f1/v1,f2/v2,..} object={g1/t1,g2/t2,...}, f1 > g1 */ /* --> pl={g1/t1,f1/v1,...} object={g2/t2,...} */ else if (i > 0) { /* 93.8.17 by H.Sirai */ upush(&(target->p_lists)); /* pl.. > ol.. -> ol,pl.. & ol... */ target->p_lists = Npstobj(object->c_form,object->c_env,pl,MEDIUM); object = object->c_link; pl = target->p_lists; } /* else goes on */ for (; object != NULL_ECL && pl->c_link != NULL_ECL; ) { i = Pred(Arg1(pl->c_link->c_form))->f_number - Pred(Arg1(object->c_form))->f_number; if (i == 0) { if (safeflag == UNSAFE) { if (unify(pl->c_link->c_form,pl->c_link->c_env, object->c_form,object->c_env) == FALSE) return(FALSE); } else { if(safe_unify(pl->c_link->c_form,pl->c_link->c_env, object->c_form,object->c_env,NOEXTRACT) == FALSE) return(FALSE); } pl=pl->c_link; object=object->c_link; } else if (i > 0) { /* pl->pnext-> ==> pl->object->pnext */ pnext=pl->c_link; onext=object->c_link; upush(&(pl->c_link)); pl->c_link = object; upush(&(object->c_link)); object->c_link = pnext; pl=pl->c_link; object=onext; } else { pl=pl->c_link; } } if (pl->c_link == NULL_ECL) { upush(&(pl->c_link)); pl->c_link = object; } return(TRUE); } _of_list(t),e,tail_of_list(u),f,extflag) == TRUE) return(TRUE); src/varset.h 644 10266 36 12140 5712121412 6432 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< varset.h >>>> * initialize global vars * 93.7.30 heap, stack * 94.8.10 unsigned char for Kanji --------------------------------------------------------------------*/ long CONSTRAINT_HANDLING_TIME = 0L; FILE *fp,*wfp,*lfp; /* read file pointer, write fp, log fp */ int tty; int cbuf; /* character buffer */ struct ustack *utop; int ECHO_BACK = 0; int Handle_Undefined = FALSE; /* fail return */ int Print_Depth = 32; int tflag; /* trace flag 0-> off, 1-> on 2->step trace on */ int sflag; /* solution mode flag 1->all solutions, 0->one solution */ int CTmode; /* trace mode 0,1,2 */ int refute_node_count = -1; /* refute node counter in c.t. */ /* Classification of Characters */ #define BL 001 /* blank */ #define UC 002 /* Upper Character */ #define LC 003 /* Lower Character */ #define UL 004 /* Undef Line */ #define N 005 /* Numeric */ #define SG 006 /* sign, +- */ #define SP 007 /* special character */ #define Q 010 /* quote */ #define CT 011 /* Cut */ #define CM 012 /* comment character */ #define BR 013 /* Brackets, Commas */ #define CO 014 /* Constraint Marker */ int char_type[128] = { /* 00, 01, 02, 03, 04, 05, 06, 07, 10, 11, 12, 13, 14, 15, 16, 17 */ BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, /* 20, 21, 22, 23, 24, 25, 26, 27, 30, 31, 32, 33, 34, 35, 36, 37 */ BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, /* sp, !, " # $ % & ' ( ) * + , - . / */ BL, CT, Q, SP, SP, CM, SP, Q, BR, BR, SP, SG, BR, SG, SP, SP, /* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */ N, N, N, N, N, N, N, N, N, N, SP, CO, SP, SP, SP, SP, /* @ A B C D E F G H I J K L M N O */ SP, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, /* P Q R S T U V W X Y Z [ \ ] ^ _ */ UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, BR, SP, BR, SP, UL, /* ` a b c d e f g h i j k l m n o */ SP, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, /* p q r s t u v w x y z { | } ~ del */ LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, BR, BR, BR, SP, BL }; unsigned char nbuf[NAMELEN_MAX]; /* name buffer */ int v_number = 0; /* temporary var number */ int p_number = 0; struct term *v_list = NULL; /* temporary var list */ struct term *pv_list = NULL; struct func *f_list = NULL; /* new function list entry */ /* struct node *n_last = NULL; */ /* node list */ struct operator *o_list = NULL; struct itrace *newf_list = NULL; /* new function definition */ struct pst_item *psttable; int FNUMBER = 0; /* function number seed */ int Def_Modified = 0; /* def modified flag */ /* system predicates in cu-prolog */ struct func *LIST,*CUNIFY; struct term *NIL,*FAIL, *END_OF_FILE; struct clause *MFAIL; struct term *XF_P, *YF_P, *FX_P, *FY_P, *XFX_P, *XFY_P, *YFX_P; struct term *S_GLOBAL_VAR, *S_VAR, *S_INTEGER, *S_FLOAT; struct term *S_STRING, *S_FILE_POINTER, *S_PST, *S_CLAUSE; struct term *S_LIST, *S_FUNCTOR, *S_ATOM, *S_PSTOBJ; struct term *S_EQ, *S_GREATER, *S_LESS; struct term *Anonymous_var; struct pair *Anonymous_env; int Refcount; /* maximum of refute counter */ int MODULARMAX; /* maximum number of Variables in Transformation */ struct node *Last_BT, *Last_SKIP; char genname[8] = "c", /* generate function name c0,c1,... */ logfile[32] = "no", /* no log */ Anonymous_VarName[4]="_"; int tokentype, reread; int GENSYM = 0; /* default heap sizes */ int HEAP_SIZE=500000; /* user heap size (KBytes)*/ int SHEAP_SIZE=1000000; /* system heap size */ int ESP_SIZE=80000; /* environment heap size */ int CHEAP_SIZE=1000000; /* constraints/pst heap size */ int USTACK_SIZE=50000; /* user stack size */ int NAME_SIZE=50000; /* name string sie */ int *sheap; /* system heap */ int *shp; int *SHEAPTOP; int *heap; /* user heap */ int *Heap_Max; int *hp; int *HEAPTOP; int *cheap; /* constraints/pst heap */ int *CHEAPTOP; int *Cheap_Max; int *chp; struct pair *eheap; /* environment heap */ struct pair *ep; struct pair *Esp_Max; struct pair *ESPTOP; struct ustack *ustack; /* user stack */ struct ustack *usp; struct ustack *STACKTOP; struct ustack *Stack_Max; char *nheap; /* name string heap */ char *nhp; char *NHEAPTOP; #include jmp_buf reset; /* error recovery */ jmp_buf unbreak_reset; /* trace --- unbreak */ /* for statistics */ int STAT_BACKTRACK_DEEP, STAT_BACKTRACK_SHAL, STAT_REFUTE; int STAT_UNFOLD, STAT_FOLD, STAT_DEF; * <<<< varset.h >>>> * initialize global vars * 93.7.30 heap, stack * 94.8.10 unsigned char for Kanji --------------------------------------------------------------------*/ long CONSTRAINT_HANDLING_TIME = 0L; FILE *fp,*wfp,*lfp; /* read file pointer, write fp, log fp */ int tty; int cbuf; /* character buffer */ struct ustack *utop; int ECHO_BACK = 0; int Handle_Undefined = FALSsrc/version.h 644 10266 36 46 5712121412 6535 #define VERSION "3.94 (Jan.27, 1995)" constraints/pst heap */ int *CHEAPTOP; int *Cheap_Max; int *chp; struct pair *eheap; /* environment heap */ struct pair *ep; struct pair *Esp_Max; struct pair *ESPTOP; struct ustack *ustack; /* user stack */ struct ustack *usp; struct ustack *STACKTOP; struct ustack *Stack_Max; char *nheap; /* name string heap */ char *nhp; char *NHEAPTOP; #include jmp_buf reset; /* error recovery */ jmp_buf unbreak_reset; /* trace --- unbreak */ /* for statistics */ isrc/varset.h 644 10266 36 12140 5712121412 6432 /* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< varset.h >>>> * initialize global vars * 93.7.30 heap, stack * 94.8.10 unsigned char for Kanji --------------------------------------------------------------------*/ long CONSTRAINT_HANDLING_TIME = 0L; FILE *fp,*wfp,*lfp; /* read file pointer, write fp, log fp */ int tty; int cbuf; /* character buffer */ struct ustack *utop; int ECHO_BACK = 0; int Handle_Undefined = FALSE; /* fail return */ int Print_Depth = 32; int tflag; /* trace flag 0-> off, 1-> on 2->step trace on */ int sflag; /* solution mode flag 1->all solutions, 0->one solution */ int CTmode; /* trace mode 0,1,2 */ int refute_node_count = -1; /* refute node counter in c.t. */ /* Classification of Characters */ #define BL 001 /* blank */ #define UC 002 /* Upper Character */ #define LC 003 /* Lower Character */ #define UL 004 /* Undef Line */ #define N 005 /* Numeric */ #define SG 006 /* sign, +- */ #define SP 007 /* special character */ #define Q 010 /* quote */ #define CT 011 /* Cut */ #define CM 012 /* comment character */ #define BR 013 /* Brackets, Commas */ #define CO 014 /* Constraint Marker */ int char_type[128] = { /* 00, 01, 02, 03, 04, 05, 06, 07, 10, 11, 12, 13, 14, 15, 16, 17 */ BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, /* 20, 21, 22, 23, 24, 25, 26, 27, 30, 31, 32, 33, 34, 35, 36, 37 */ BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, BL, /* sp, !, " # $ % & ' ( ) * + , - . / */ BL, CT, Q, SP, SP, CM, SP, Q, BR, BR, SP, SG, BR, SG, SP, SP, /* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */ N, N, N, N, N, N, N, N, N, N, SP, CO, SP, SP, SP, SP, /* @ A B C D E F G H I J K L M N O */ SP, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, /* P Q R S T U V W X Y Z [ \ ] ^ _ */ UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, BR, SP, BR, SP, UL, /* ` a b c d e f g h i j k l m n o */ SP, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, /* p q r s t u v w x y z { | } ~ del */ LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, BR, BR, BR, SP, BL }; unsigned char nbuf[NAMELEN_MAX]; /* name buffer */ int v_number = 0; /* temporary var number */ int p_number = 0; struct term *v_list = NULL; /* temporary var list */ struct term *pv_list = NULL; struct func *f_list = NULL; /* new function list entry */ /* struct node *n_last = NULL; */ /* node list */ struct operator *o_list = NULL; struct itrace *newf_list = NULL; /* new function definition */ struct pst_item *psttable; int FNUMBER = 0; /* function number seed */ int Def_Modified = 0; /* def modified flag */ /* system predicates in cu-prolog */ struct func *LIST,*CUNIFY; struct term *NIL,*FAIL, *END_OF_FILE; struct clause *MFAIL; struct term *XF_P, *YF_P, *FX_P, *FY_P, *XFX_P, *XFY_P, *YFX_P; struct term *S_GLOBAL_VAR, *S_VAR, *S_INTEGER, *S_FLOAT; struct term *S_STRING, *S_FILE_POINTER, *S_PST, *S_CLAUSE; struct term *S_LIST, *S_FUNCTOR, *S_ATOM, *S_PSTOBJ; struct term *S_EQ, *S_GREATER, *S_LESS; struct term *Anonymous_var; struct pair *Anonymous_env; int Refcount; /* maximum of refute counter */ int MODULARMAX; /* maximum number of Variables in Transformation */ struct node *Last_BT, *Last_SKIP; char genname[8] = "c", /* generate function name c0,c1,... */ logfile[32] = "no", /* no log */ Anonymous_VarName[4]="_"; int tokentype, reread; int GENSYM = 0; /* default heap sizes */ int HEAP_SIZE=500000; /* user heap size (KBytes)*/ int SHEAP_SIZE=1000000; /* system heap size */ int ESP_SIZE=80000; /* environment heap size */ int CHEAP_SIZE=1000000; /* constraints/pst heap size */ int USTACK_SIZE=50000; /* user stack size */ int NAME_SIZE=50000; /* name string sie */ int *sheap; /* system heap */ int *shp; int *SHEAPTOP; int *heap; /* user heap */ int *Heap_Max; i