├── doc ├── helpgen.pro ├── preds.pro ├── makeall.bat ├── tarau.bib ├── user.pdf ├── advanced.pdf ├── crossref.pdf ├── interface.pdf ├── internet.html ├── internet.pdf ├── toPDF.bat ├── README.txt ├── crossref.tex ├── .log ├── local.bib └── makefile ├── progs ├── bm.bat ├── test.pl ├── mfibo.pl ├── temp.pro ├── mbrev.pl ├── macro.pl ├── plain_tetris.pl ├── clean.bat ├── mboyer.pl ├── dbrev.pl ├── p3.pl ├── dhan.pl ├── dfibo.pl ├── engines.pro ├── tloop.pro ├── dtak.pl ├── pure_io.pl ├── spy.pl ├── dboyer.pl ├── netrun.pl ├── lgraph.pl ├── hello.pro ├── untrail.pl ├── han.pl ├── move1.pl ├── gc_bug.pl ├── p1.pl ├── show_tetris.pl ├── algraph.pl ├── lat_plan.pl ├── drive_tetris.pl ├── nping.pl ├── ic.pl ├── xreftest.pl ├── lsort.pl ├── profile.pl ├── bug.pl ├── ilgraph.pl ├── lat_wam.pl ├── q8.pl ├── dbsort.pl ├── rpc_chat.pro ├── bm.pl ├── coco_data.pl ├── or_engtest.pl ├── ffibo.pl ├── synco_data.pl ├── eperms.pl ├── if0_fibo.pl ├── obtest.pl ├── tsp.pl ├── bm2.bat ├── fmoney.pl ├── tak.pl ├── queens.pl ├── subset.pl ├── thread_test.pro ├── bm1.bat ├── fibo.pl ├── ltak.pl ├── lmoney.pl ├── lmap.pl ├── gc.pl ├── money.pl ├── move.pl ├── bm_tetris.pl ├── disj.pl ├── tetris_trace.pl ├── setarg_dcg.pl ├── eassert.pl ├── netscale.pl ├── lfibo.pl ├── ja_primes.pl ├── bmark.pl ├── igmoney.pl ├── lknight.pl ├── ham.pl ├── primes.pl ├── bestof.pl ├── lq8.pl ├── qsort.pl ├── bincont.pl ├── ag_ic.pl ├── term2io.pl ├── l.pl ├── infinite.pl ├── fknight.pl ├── qrev.pl ├── linperms.pl ├── nrev30.pl ├── ttest.pl ├── knight.pl ├── bugs.pl ├── catch.pl ├── over_ex.pl ├── rnet.pl ├── cont.pl ├── cperms.pl ├── tty_tetris.pl ├── callbm.pl ├── bbemul.pl ├── qbrev.pl ├── vfbrev.pl ├── file2pred.pl ├── fbrev.pl ├── cbrev.pl ├── winthreads.pl ├── lrev.pl ├── recordbm.pl ├── differen.pl ├── p2.pl ├── hag_bm2.pl ├── hag_bm1.pl ├── engtest.pl ├── bfmeta.pl ├── brev.pl ├── horn_gram.pl ├── hag_bm.pl ├── fperms.pl ├── cube.pl ├── dcomp.pl ├── nrev.pl ├── allperms.pl ├── dlg.pl ├── lattice.pl ├── calibrate.pro ├── lsum.pl ├── natlog.pl └── netkill.pl ├── src ├── OLD │ ├── makebpr.bat │ ├── makedll.bat │ ├── makedllr.bat │ ├── makelib.bat │ ├── makedllx.bat │ ├── xtest.bat │ ├── makebp.bat │ ├── cboot.bat │ ├── tboot.bat │ ├── test.pro │ ├── linux32mt │ ├── linux64mt │ ├── genrun.bat │ ├── makebpx.bat │ ├── make64.bat │ ├── makeru.bat │ ├── remake.bat │ ├── makeall.bat │ ├── mac │ ├── makenew.bat │ ├── mac64 │ ├── makenew │ ├── mac32mt │ ├── makemac │ ├── makenew1 │ ├── makeprof │ └── makenew2 ├── remake.pro ├── wam.ok ├── full.pro ├── wam.pro ├── make_ru.sh ├── binpro.pro ├── stub.c ├── reboot.sh ├── run.pro ├── go.sh ├── mac64mt.sh ├── termStore.c ├── tstore.pl ├── c.c ├── oper.pl ├── main.c ├── top.pl ├── init.pl └── termStore.h ├── lib ├── bin └── README.md ├── library ├── xref.pdf ├── prodoc.pl ├── prodoc.bat ├── if_syntax.pl ├── test_kernel_prolog.pl ├── file2or.pl ├── foldall.pro ├── coord1.pl ├── canonical.pl ├── to_simple.pl ├── bpxref.pl ├── coord.pl ├── xref2txt.pl ├── monad.pl ├── record.pl ├── small_kernel_prolog.pl └── catch_cont.pl ├── binbuild.bat ├── makefile ├── makeall.bat └── .gitignore /doc/helpgen.pro: -------------------------------------------------------------------------------- 1 | main:-help,halt. 2 | -------------------------------------------------------------------------------- /progs/bm.bat: -------------------------------------------------------------------------------- 1 | CALL bm1.bat 2 | CALL bm2.bat 3 | -------------------------------------------------------------------------------- /progs/test.pl: -------------------------------------------------------------------------------- 1 | a(1). 2 | a(2). 3 | a(3). 4 | 5 | -------------------------------------------------------------------------------- /progs/mfibo.pl: -------------------------------------------------------------------------------- 1 | :-memo fibo/2. 2 | 3 | :-[fibo]. 4 | -------------------------------------------------------------------------------- /progs/temp.pro: -------------------------------------------------------------------------------- 1 | 2 | main :- 3 | notepad. 4 | -------------------------------------------------------------------------------- /src/OLD/makebpr.bat: -------------------------------------------------------------------------------- 1 | CALL makebpx.bat bpr.exe -GA 2 | -------------------------------------------------------------------------------- /src/OLD/makedll.bat: -------------------------------------------------------------------------------- 1 | CALL makedllx bp_lib.dll 2 | -------------------------------------------------------------------------------- /src/OLD/makedllr.bat: -------------------------------------------------------------------------------- 1 | CALL makedllx bpr_lib.dll 2 | -------------------------------------------------------------------------------- /lib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/lib -------------------------------------------------------------------------------- /progs/mbrev.pl: -------------------------------------------------------------------------------- 1 | :-memo nrev/2. 2 | 3 | :-[brev]. 4 | 5 | -------------------------------------------------------------------------------- /progs/macro.pl: -------------------------------------------------------------------------------- 1 | pi2(Y):- ##((X is 2*asin(1),Y is X*X)). 2 | 3 | -------------------------------------------------------------------------------- /progs/plain_tetris.pl: -------------------------------------------------------------------------------- 1 | :-[tetris]. 2 | :-[tetris_trace]. 3 | -------------------------------------------------------------------------------- /doc/preds.pro: -------------------------------------------------------------------------------- 1 | :-[library(bpxref)]. 2 | main:-cd('../src'),go. 3 | -------------------------------------------------------------------------------- /src/remake.pro: -------------------------------------------------------------------------------- 1 | :-[oper]. 2 | :-[headers]. 3 | main:-go,reboot. 4 | -------------------------------------------------------------------------------- /progs/clean.bat: -------------------------------------------------------------------------------- 1 | rm -f before.* 2 | rm -f after.* 3 | rm -f info.* 4 | -------------------------------------------------------------------------------- /src/wam.ok: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/src/wam.ok -------------------------------------------------------------------------------- /doc/makeall.bat: -------------------------------------------------------------------------------- 1 | @echo make sure vsvars32 is called first 2 | CALL nmake.exe -------------------------------------------------------------------------------- /doc/tarau.bib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/tarau.bib -------------------------------------------------------------------------------- /doc/user.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/user.pdf -------------------------------------------------------------------------------- /progs/mboyer.pl: -------------------------------------------------------------------------------- 1 | :-nogc. 2 | 3 | :-memo rewrite/2. 4 | 5 | :-[boyer]. 6 | -------------------------------------------------------------------------------- /bin/README.md: -------------------------------------------------------------------------------- 1 | ## the binary bp lands here - a self contained executable BinProlog -------------------------------------------------------------------------------- /doc/advanced.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/advanced.pdf -------------------------------------------------------------------------------- /doc/crossref.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/crossref.pdf -------------------------------------------------------------------------------- /doc/interface.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/interface.pdf -------------------------------------------------------------------------------- /doc/internet.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/internet.html -------------------------------------------------------------------------------- /doc/internet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/doc/internet.pdf -------------------------------------------------------------------------------- /library/xref.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ptarau/binprolog/HEAD/library/xref.pdf -------------------------------------------------------------------------------- /progs/dbrev.pl: -------------------------------------------------------------------------------- 1 | :-random_seed(3). 2 | 3 | :-delphi nrev/2-5. 4 | 5 | :-[brev]. 6 | 7 | -------------------------------------------------------------------------------- /progs/p3.pl: -------------------------------------------------------------------------------- 1 | my_member(X,[X|_]). 2 | my_member(X,[_|Xs]):- 3 | my_member(X,Xs). 4 | -------------------------------------------------------------------------------- /src/full.pro: -------------------------------------------------------------------------------- 1 | :-[run]. 2 | :-[bin]. 3 | :-[co]. 4 | :-[c_comp]. 5 | :-[c_instr]. 6 | 7 | 8 | -------------------------------------------------------------------------------- /src/wam.pro: -------------------------------------------------------------------------------- 1 | :-[run]. 2 | :-[bin]. 3 | :-[co]. 4 | :-[c_comp]. 5 | :-[c_instr]. 6 | 7 | 8 | -------------------------------------------------------------------------------- /progs/dhan.pl: -------------------------------------------------------------------------------- 1 | :-random_seed(3). 2 | :-delphi han/4-10/[1,2,3,4]. 3 | %:-delphi han/4-10. 4 | :-[han]. 5 | -------------------------------------------------------------------------------- /src/make_ru.sh: -------------------------------------------------------------------------------- 1 | cp defs.ok defs.h 2 | cp prof.ok prof.h 3 | cp wam.ok wam.bp 4 | gcc -std=c11 -o ru *.c -lm -------------------------------------------------------------------------------- /src/OLD/makelib.bat: -------------------------------------------------------------------------------- 1 | del /Q *.dll 2 | del /Q *.exp 3 | del /Q *.lib 4 | link.exe -lib *.obj -out:..\lib\%1 5 | -------------------------------------------------------------------------------- /src/binpro.pro: -------------------------------------------------------------------------------- 1 | % this empty program just gives a name to the 2 | % C-ified standalone BinProlog executable 3 | -------------------------------------------------------------------------------- /binbuild.bat: -------------------------------------------------------------------------------- 1 | cd c_inter 2 | CALL winmake.bat 3 | cd ..\pl2c 4 | CALL winmake.bat 5 | @echo binbuild.bat DONE 6 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | all: 2 | cd src ; make nobp 3 | cd src ; make realclean 4 | @echo executable: bin/bp 5 | ./bin/bp 6 | -------------------------------------------------------------------------------- /progs/dfibo.pl: -------------------------------------------------------------------------------- 1 | :-random_seed(3). 2 | 3 | :-delphi fibo/2-5. % Prob/100 chance to do memoing 4 | 5 | :-[fibo]. 6 | -------------------------------------------------------------------------------- /src/stub.c: -------------------------------------------------------------------------------- 1 | #include "global.h" 2 | 3 | struct bp_instr *wam_bp=NULL,*user_bp=NULL; 4 | long wam_bp_size=0; 5 | 6 | -------------------------------------------------------------------------------- /progs/engines.pro: -------------------------------------------------------------------------------- 1 | :-[library(engines)]. 2 | 3 | go:-all_tests. 4 | 5 | 6 | bug:-engine_params(64,32,32)=>gc_test. 7 | 8 | -------------------------------------------------------------------------------- /src/OLD/makedllx.bat: -------------------------------------------------------------------------------- 1 | del /Q *.dll 2 | del /Q *.exp 3 | del /Q *.lib 4 | CALL makebpx.bat %1 -D"VCCDLL=1" -LD -Gd -D_USRDLL 5 | -------------------------------------------------------------------------------- /src/OLD/xtest.bat: -------------------------------------------------------------------------------- 1 | bp -r1000000 -c20000 -b40000 -h10000 -t5000 -s5000 -d20 assertbm call(db_hook_on) call(go1a) mmap_show(unx) call(halt) -------------------------------------------------------------------------------- /src/OLD/makebp.bat: -------------------------------------------------------------------------------- 1 | CALL makebpx.bat bp.exe -GA 2 | copy /Y *.h ..\sdist 3 | copy /Y *.c ..\sdist 4 | del /Q ..\sdist\stub.c 5 | 6 | 7 | -------------------------------------------------------------------------------- /makeall.bat: -------------------------------------------------------------------------------- 1 | cd src 2 | CALL makeall.bat 3 | cd .. 4 | call binbuild.bat 5 | cd ..\csocks 6 | CALL winmake.bat 7 | cd .. 8 | @echo DONE! 9 | -------------------------------------------------------------------------------- /progs/tloop.pro: -------------------------------------------------------------------------------- 1 | loop(Max):-N is 1<0,N1 is N-1,loop(N1,c(X,N)). 5 | 6 | -------------------------------------------------------------------------------- /progs/dtak.pl: -------------------------------------------------------------------------------- 1 | :-delphi tak/3-10/[1,2,3]. 2 | :-[tak]. 3 | 4 | /* 5 | before 1150 6 | first run 180 7 | second run 10 8 | third run 5 9 | */ 10 | -------------------------------------------------------------------------------- /src/reboot.sh: -------------------------------------------------------------------------------- 1 | # integrates changes in lib.pl and builtins 2 | make 3 | ../bin/bp "reboot,halt" 4 | cp wam.bp wam.ok 5 | make 6 | make realclean 7 | 8 | 9 | -------------------------------------------------------------------------------- /progs/pure_io.pl: -------------------------------------------------------------------------------- 1 | :-[library(string_io)]. 2 | 3 | go:-T0=f(X,X,g(a,[X,Y,Y],13)),t2s(T0,S),write(S),nl, 4 | s2t(S,T),write(T0+T),nl, 5 | name(N,S),write(N),nl. 6 | -------------------------------------------------------------------------------- /src/OLD/cboot.bat: -------------------------------------------------------------------------------- 1 | CALL makeru.bat 2 | @echo ru.exe generated 3 | ru.exe call((cboot,halt)) 4 | @echo wam.bp generated 5 | CALL makebp.bat 6 | @echo bp.exe generated 7 | -------------------------------------------------------------------------------- /src/OLD/tboot.bat: -------------------------------------------------------------------------------- 1 | CALL makeru.bat 2 | @echo ru.exe generated 3 | ru.exe call((tboot,halt)) 4 | @echo wam.bp generated 5 | CALL makebp.bat 6 | @echo bp.exe generated 7 | -------------------------------------------------------------------------------- /progs/spy.pl: -------------------------------------------------------------------------------- 1 | :-spy a/1. 2 | :-spy c/1. 3 | 4 | b(X):-a(X),c(X). 5 | 6 | a(1). 7 | a(2). 8 | 9 | c(2). 10 | c(3). 11 | 12 | go:-b(X),write(X),nl. 13 | 14 | :-go. 15 | -------------------------------------------------------------------------------- /progs/dboyer.pl: -------------------------------------------------------------------------------- 1 | :-random_seed(3). 2 | :-delphi rewrite/2-20. 3 | 4 | :-[boyer]. 5 | 6 | /* 7 | 8 | first run 410 9 | second 110 10 | third 60 11 | fourth etc. 20 12 | 13 | */ 14 | -------------------------------------------------------------------------------- /doc/toPDF.bat: -------------------------------------------------------------------------------- 1 | set PROJ=%1 2 | CALL clean.bat %PROJ% 3 | del /Q %PROJ%.pdf 4 | latex %PROJ%.tex 5 | bibtex %PROJ% 6 | latex %PROJ%.tex 7 | pdflatex %PROJ%.tex 8 | CALL clean.bat %PROJ% 9 | REM %PROJ%.pdf 10 | 11 | -------------------------------------------------------------------------------- /src/OLD/test.pro: -------------------------------------------------------------------------------- 1 | a(1). 2 | a(2). 3 | b(X):-a(X). 4 | 5 | test(N):-for(I,1,N),remote_run(eq(_,I)),fail. 6 | test(_). 7 | 8 | go(N):-ctime(T1),test(N),ctime(T2),'is'(T,'-'(T2,T1)),println(T). 9 | 10 | go:-go(20). 11 | 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | bin/bp 2 | src/binpro 3 | src/binpro.c 4 | src/binpro.h 5 | src/builtins.pl 6 | src/defs.h 7 | src/otherwam.bp 8 | src/prof.h 9 | src/ru 10 | src/wam.bp 11 | src/wam.c 12 | src/wam.h 13 | src/wam.ok 14 | src/wam.ok 15 | -------------------------------------------------------------------------------- /src/OLD/linux32mt: -------------------------------------------------------------------------------- 1 | rm -f wam.c binpro.c *.o bp binpro 2 | gcc -o ru -lpthread -lm *.c 3 | ./ru remake 4 | ./ru "and(cboot,halt)" 5 | mv -f stub.c stub.txt 6 | gcc -g -O3 -DTHREADS=1 -o bp -fomit-frame-pointer -lpthread -lm *.c 7 | mv -f stub.txt stub.c 8 | -------------------------------------------------------------------------------- /progs/netrun.pl: -------------------------------------------------------------------------------- 1 | go:-go(10). 2 | 3 | go(N):-go(N,_). 4 | 5 | go(0,_):-!. 6 | go(N,Old):- 7 | N>0, 8 | N1 is N-1, 9 | println(before(N)), 10 | remote_run(eq(New,c(Old,Old))), 11 | println(after_(N)), 12 | go(N1,New). 13 | 14 | -------------------------------------------------------------------------------- /src/OLD/linux64mt: -------------------------------------------------------------------------------- 1 | rm -f wam.c binpro.c *.o bp binpro 2 | gcc -o ru -lpthread -lm *.c 3 | ./ru remake 4 | ./ru "and(cboot,halt)" 5 | mv -f stub.c stub.txt 6 | gcc -O3 -DW64 -m64 -g -DTHREADS=1 -o bp -fomit-frame-pointer -lpthread -lm *.c 7 | mv -f stub.txt stub.c 8 | -------------------------------------------------------------------------------- /src/run.pro: -------------------------------------------------------------------------------- 1 | :-[oper]. 2 | :-[builtins]. 3 | :-[init]. 4 | 5 | :-[lib]. 6 | 7 | :-[xdb]. 8 | :-[hmap]. 9 | 10 | :-[tstore]. 11 | 12 | :-[maps]. 13 | :-[dcg]. 14 | :-[read]. 15 | :-[write]. 16 | :-[top]. 17 | :-[extra]. 18 | 19 | :-[net]. 20 | :-[cserver]. 21 | -------------------------------------------------------------------------------- /progs/lgraph.pl: -------------------------------------------------------------------------------- 1 | path(X,X,[X]). 2 | path(X,Z,[X|Xs]):-linked(X,Y),path(Y,Z,Xs). 3 | 4 | linked(X,Y):-c(X,Ys),member(Y,Ys). 5 | 6 | go(Xs):- 7 | c(1,[2,3]) -: c(2,[1,4]) -: c(3,[1,5]) -: c(4,[1,5]) -: 8 | path(1,5,Xs). 9 | 10 | go:-go(Xs),write(Xs),nl,fail. 11 | -------------------------------------------------------------------------------- /src/OLD/genrun.bat: -------------------------------------------------------------------------------- 1 | copy run.pro wam.pro 2 | bp.exe call((cmake,halt)) 3 | @echo wam.c generated 4 | CALL makebpr.bat 5 | @echo bpr.exe generated 6 | CALL makedllr.bat 7 | copy full.pro wam.pro 8 | del /Q wam.c 9 | del /Q wam.h 10 | del /Q binpro.c 11 | del /Q binpro.h 12 | -------------------------------------------------------------------------------- /progs/hello.pro: -------------------------------------------------------------------------------- 1 | /* 2 | do not consult directly: demo 3 | for creation of standalone executables 4 | 5 | requires full source BinProlog license 6 | */ 7 | :-op(200,fx,hello). 8 | 9 | :-begin_module(prolog). 10 | :-[wam]. 11 | :-end_module(prolog). 12 | 13 | main:-write(hello world),nl. 14 | -------------------------------------------------------------------------------- /doc/README.txt: -------------------------------------------------------------------------------- 1 | preds.tex - automatically generated predicate cross refs and help 2 | 3 | makefile - from *.tex+*.bib -> *.dvi -> *.ps and *.txt 4 | - use it if you edit and improve art.tex 5 | 6 | FILES: 7 | 8 | *.ps 9 | *.html 10 | 11 | User, Advanced, Interface and Internet Toolkit documentation. 12 | -------------------------------------------------------------------------------- /src/OLD/makebpx.bat: -------------------------------------------------------------------------------- 1 | del /Q *.obj 2 | cl.exe -Fe%1 %2 %3 %4 %5 %7 %8 %9 -DTHREADS=1 -DVCC=1 -MT -GF -TC -W2 -O2x -Oy -DWIN32 -DNDEBUG -D_CONSOLE -D_WINDOWS -DMBCS -nologo ru.c sym.c load.c engine.c builtins.c dict.c io.c socket.c float.c debug.c gc.c term.c termStore.c main.c wam.c binpro.c c.c -link /DEFAULTLIB:wsock32 /DEFAULTLIB:advapi32 3 | -------------------------------------------------------------------------------- /progs/untrail.pl: -------------------------------------------------------------------------------- 1 | go:- 2 | T=f(X,X),get_neck_cut(CUT), 3 | for(_,1,3),nl, 4 | write(cut=CUT),nl, 5 | T=f(Y,a), 6 | get_deep_cut(DEEP), 7 | write(deep_cut=DEEP),nl, 8 | CUT==DEEP, 9 | write(=),nl, 10 | write(before=Y+T),nl, 11 | untrail_to(DEEP),!, 12 | write(after=Y+T),nl, 13 | fail. 14 | 15 | -------------------------------------------------------------------------------- /progs/han.pl: -------------------------------------------------------------------------------- 1 | /* Prolog version of hanoi benchmark */ 2 | 3 | go:-go(16). 4 | 5 | time(T):-statistics(runtime,[T,_]). 6 | 7 | go(N) :- time(T1),han(N,1,2,3),time(T2),T is T2-T1,write(T),nl. 8 | 9 | han(N,_,_,_) :- N=<0,!. 10 | han(N,A,B,C) :- N>0, 11 | N1 is N - 1, 12 | %write(A+B=C),nl, 13 | han(N1,A,C,B), 14 | han(N1,C,B,A). 15 | 16 | -------------------------------------------------------------------------------- /progs/move1.pl: -------------------------------------------------------------------------------- 1 | fg(Goal):-end_cont-::capture_cont_for(Goal). 2 | 3 | move:- 4 | % assumes fg(...) has been executed before 5 | call_with_cont(run_and_return). 6 | 7 | run_and_return(Gs):- 8 | println(Gs), 9 | the(Gs,Gs,R), 10 | eq(the(Gs),R). 11 | 12 | go:-fg(test). 13 | 14 | test:-eq(X,1),there,move,and(member(Y,[X,2,X]),println(remote_values(X,Y))). 15 | -------------------------------------------------------------------------------- /src/OLD/make64.bat: -------------------------------------------------------------------------------- 1 | del /Q *.obj 2 | del /Q wam.c 3 | del /Q wam.h 4 | del /Q binpro.c 5 | del /Q binpro.h 6 | cl.exe -Feru.exe -DTHREADS=1 -DVCC=1 -MT -GF -TC -W2 -O2x -DWIN32 -DNDEBUG -D_CONSOLE -D_WINDOWS -DMBCS -nologo ru.c sym.c load.c engine.c builtins.c dict.c io.c socket.c float.c debug.c gc.c term.c termStore.c main.c stub.c c.c -link /DEFAULTLIB:wsock32 /DEFAULTLIB:advapi32 7 | -------------------------------------------------------------------------------- /src/OLD/makeru.bat: -------------------------------------------------------------------------------- 1 | del /Q *.obj 2 | del /Q wam.c 3 | del /Q wam.h 4 | del /Q binpro.c 5 | del /Q binpro.h 6 | cl.exe -Feru.exe -DTHREADS=1 -DVCC=1 -MT -GF -TC -W2 -O2x -DWIN32 -DNDEBUG -D_CONSOLE -D_WINDOWS -DMBCS -nologo ru.c sym.c load.c engine.c builtins.c dict.c io.c socket.c float.c debug.c gc.c term.c termStore.c main.c stub.c c.c -link /DEFAULTLIB:wsock32 /DEFAULTLIB:advapi32 7 | -------------------------------------------------------------------------------- /src/OLD/remake.bat: -------------------------------------------------------------------------------- 1 | del /Q wam.c 2 | del /Q wam.h 3 | del /Q binpro.c 4 | del /Q binpro.h 5 | del /Q *.obj 6 | del /Q *.exe 7 | del /Q *.dll 8 | del /Q *.exp 9 | del /Q *.lib 10 | copy full.pro wam.pro 11 | bp [remake] 12 | CALL cboot.bat 13 | REM copy bp.exe \bin 14 | REM CALL MAKEBPX pbp.exe "-DPROF=3" "-DTRACE=1" "-DTRACE_EXEC=1" 15 | del /Q ru.exe 16 | del /Q *.obj 17 | -------------------------------------------------------------------------------- /library/prodoc.pl: -------------------------------------------------------------------------------- 1 | % xref based program documentation tool 2 | 3 | :-[library(xref2latex)]. 4 | 5 | % tests itself 6 | selftest:-xref(prodoc). 7 | 8 | % filters out unwanted predicates 9 | 10 | non_trivial(FN):-FN \== true/0,FN\==(!)/0. % FN\==fail/0, 11 | 12 | filter(F/N):-functor(P,F,N), \+ is_builtin(P). 13 | 14 | % adds some predicates that the system cannot see 15 | generator(_F/_N):-fail. 16 | 17 | -------------------------------------------------------------------------------- /progs/gc_bug.pl: -------------------------------------------------------------------------------- 1 | % bp -q0 -t2000 2 | go:-go(100000). 3 | 4 | go(N):-go(N,L),println(L). 5 | 6 | go(N,L):- 7 | gen_cs(N,Xs), 8 | #>Xs, 9 | get_cs(Cs), 10 | #<[], 11 | length(Cs,L). 12 | 13 | get_cs([C|Cs]):- #C,!,get_cs(Cs). 14 | get_cs([]). 15 | 16 | gen_cs(0,[]):-!. 17 | gen_cs(I,[C|Cs]):- 18 | I>0, 19 | I1 is I-1, 20 | C is 0'a + I mod 26, 21 | gen_cs(I1,Cs). 22 | -------------------------------------------------------------------------------- /progs/p1.pl: -------------------------------------------------------------------------------- 1 | /* facts */ 2 | likes(joe,beer). 3 | likes(mary,wine). 4 | likes(bill,water). 5 | likes(bill,wine). 6 | 7 | /* rules */ 8 | drinks(X,Drink):-likes(X,Drink). 9 | drinks(_,Drink):-likes(mary,Drink). 10 | 11 | /* projection */ 12 | person(X):-likes(X,_). 13 | 14 | /* join */ 15 | dry(X):-person(X), not(likes(X,beer)),not(likes(X,wine)). 16 | 17 | water_drinker(X):-drinks(X,water). 18 | 19 | -------------------------------------------------------------------------------- /progs/show_tetris.pl: -------------------------------------------------------------------------------- 1 | :-[tetris_trace]. 2 | 3 | dims(20,10,32). 4 | 5 | go:-tetris_server. 6 | 7 | tetris_server:- 8 | is_prolog(Prolog), 9 | prolog_action(Prolog,Action), 10 | call(Action). 11 | tetris_server:- 12 | println('Please run this with Jinni or BinProlog!'). 13 | 14 | prolog_action(jinni_compiled,run_server). 15 | prolog_action(jinni_interpreted,run_server). 16 | prolog_action(binprolog,trust). 17 | 18 | -------------------------------------------------------------------------------- /progs/algraph.pl: -------------------------------------------------------------------------------- 1 | 2 | p:-[algraph]. 3 | 4 | path(X,X,[X]). 5 | path(X,Z,[X|Xs]):-c(X,Y),path(Y,Z,Xs). 6 | 7 | % data 8 | 9 | go(Xs):- 10 | (c(1,X1):-c1(X1)) -: 11 | (c(2,X2):-c2(X2)) -: 12 | (c(3,X3):-c3(X3)) -: 13 | (c(4,X4):-c4(X4)) -: 14 | path(1,5,Xs). 15 | 16 | c1(2). 17 | c1(3). 18 | 19 | c2(1). 20 | c2(4). 21 | 22 | c3(1). 23 | c3(5). 24 | 25 | c4(1). 26 | c4(5). 27 | 28 | % test 29 | 30 | go:-go(Xs),write(Xs),nl,fail. 31 | -------------------------------------------------------------------------------- /progs/lat_plan.pl: -------------------------------------------------------------------------------- 1 | :-[lattice]. 2 | % planets & attributes: must be sorted 3 | 4 | planet(earth,[moon,near,small]). 5 | planet(jupiter,[far,large,moon]). 6 | planet(mars,[moon,near,small]). 7 | planet(mercury,[near,single,small]). 8 | planet(neptune,[far,medium,moon]). 9 | planet(pluto,[far,moon,small]). 10 | planet(saturn,[far,large,moon]). 11 | planet(uranus,[far,medium,moon]). 12 | planet(venus,[near,single,small]). 13 | 14 | lcontext(L,Rs):-planet(L,Rs). 15 | -------------------------------------------------------------------------------- /library/prodoc.bat: -------------------------------------------------------------------------------- 1 | set PROJ=%1 2 | set BP_PATH=\tarau\BinProlog\library 3 | bp -q3 -b0 -h40000 -t10000 -s10000 -a20 -d21 prodoc.pl "xref(%1),halt" 4 | del /Q %PROJ%.pdf 5 | latex %PROJ%.tex 6 | bibtex %PROJ% 7 | latex %PROJ%.tex 8 | tth.exe <%PROJ%.tex >%PROJ%.html -L%PROJ% -a -e1 9 | pdflatex %PROJ%.tex 10 | del /Q %PROJ%.aux 11 | del /Q %PROJ%.bbl 12 | del /Q %PROJ%.log 13 | del /Q %PROJ%.blg 14 | del /Q %PROJ%.dvi 15 | del /Q %PROJ%.tex 16 | REM %PROJ%.html -------------------------------------------------------------------------------- /progs/drive_tetris.pl: -------------------------------------------------------------------------------- 1 | % Hor Vert Size - starts at 0 2 | 3 | :-[tetris]. 4 | 5 | % defines actions as (local) predicate calls 6 | 7 | scr_dir(D):-remote_run(scr_dir(D)). 8 | 9 | scr_init(N):-remote_run(scr_init(N)). 10 | 11 | scr_end :- remote_run(scr_end). 12 | 13 | scr_send(Position,Code):-remote_run(scr_send(Position,Code)). 14 | 15 | scr_score(Score):-remote_run(scr_score(Score)). 16 | 17 | scr_stat(Val):-remote_run(scr_stat(Val)). 18 | -------------------------------------------------------------------------------- /progs/nping.pl: -------------------------------------------------------------------------------- 1 | go:- 2 | for(I,0,255), 3 | to_string(I,S), 4 | namecat('ping -n 1 -w 200 192.168.1.',S,'',Cmd), 5 | % quiet(10), 6 | (pcollect(Cmd,Rs)->true;Rs=[]), 7 | % quiet(2), 8 | ( is_sstring("100%",Rs)->write(I),write(' ') 9 | ; nl,println(Cmd) 10 | ), 11 | fail. 12 | go. 13 | 14 | is_sstring(Ss,Cs):-append(_,Xs,Cs),is_sstring(Ss,Xs,_),!. 15 | 16 | is_sstring([])-->[]. 17 | is_sstring([X|Xs]) --> [X],is_sstring(Xs). 18 | -------------------------------------------------------------------------------- /progs/ic.pl: -------------------------------------------------------------------------------- 1 | ic([a,b,c]). 2 | ic([d,e]). 3 | 4 | ab([a,c,f]). 5 | ab([a,d]). 6 | ab([b,c,d]). 7 | 8 | violates(Abduced,IC):-select(X,Abduced,More),select(Y,More,_),member(X,IC),member(Y,IC). 9 | 10 | inconsistent(Abduced):-ic(IC),violates(Abduced,IC). 11 | 12 | select(X,[X|Xs],Xs). 13 | select(X,[Y|Xs],[Y|Ys]):-select(X,Xs,Ys). 14 | 15 | explanation(Abduced):- ab(Abduced), \+inconsistent(Abduced). 16 | 17 | go:-explanation(Abduced),write(Abduced),nl,fail. 18 | go. 19 | -------------------------------------------------------------------------------- /src/OLD/makeall.bat: -------------------------------------------------------------------------------- 1 | CALL remake.bat 2 | copy global.h ..\lib 3 | copy c_defs.h ..\lib 4 | copy c_defs.h ..\lib 5 | copy c.c ..\lib 6 | copy c.obj ..\lib 7 | copy bp.exe ..\bin 8 | call makedll.bat 9 | copy bp_lib.* ..\BP_DLL 10 | CALL makelib.bat bp.lib 11 | CALL genrun.bat 12 | copy bpr.exe ..\bin 13 | copy bpr_lib.* ..\BP_DLL 14 | CALL makelib.bat bpr.lib 15 | CALL cboot.bat 16 | del /Q *.obj 17 | del /Q *.exe 18 | del /Q *.dll 19 | del /Q *.lib 20 | del /Q *.exp 21 | 22 | -------------------------------------------------------------------------------- /library/if_syntax.pl: -------------------------------------------------------------------------------- 1 | :-op(970,fx,if). 2 | :-op(980,xfy,then). 3 | :-op(990,xfy,else). 4 | 5 | else(then(if(If),Then),Else):-If->Then;Else. 6 | 7 | then(if(If),Then):-If->Then. 8 | 9 | if_example(if 1>0 then if 2>0 then (write(yes),nl) else (write(no),nl)). 10 | if_example( 11 | if_max(1,2,3) then write(1) 12 | else if 2<0 then write(2) 13 | else write(3) 14 | ). 15 | 16 | if_test:-if_example(T),write(T),nl,display(T),nl,T,nl,nl,fail;nl. 17 | 18 | if_max(X,Y,Z) :- if X>Y then Z is X else Z is Y. 19 | -------------------------------------------------------------------------------- /progs/xreftest.pl: -------------------------------------------------------------------------------- 1 | % xref based program checking tools 2 | 3 | % :-write('use -h2000 -t1000 -b0'),nl. 4 | 5 | :-[library(xref2txt)]. 6 | 7 | 8 | % tests BinProlog 9 | wtest:-plain_xref(wam). 10 | 11 | % tests itself 12 | test:-plain_xref(library(xref)). 13 | 14 | %filter(FN):-FN == true/0. 15 | filter(F/N):-functor(P,F,N), \+ is_builtin(P). 16 | 17 | go:- 18 | dynbbgc, 19 | create_engine(2000,500,1000,E), 20 | load_engine(E,wtest,_), 21 | ask_engine(E,_), 22 | destroy_engine(E). 23 | 24 | -------------------------------------------------------------------------------- /progs/lsort.pl: -------------------------------------------------------------------------------- 1 | p:-[lsort]. 2 | 3 | % modified version of a Lolli program (sort.ll) by J. Hodas 4 | % I have added \+ hyp and got rid of original explicit continuation passing 5 | % as in BinProlog -<> is already defined in terms of assumel/1 6 | 7 | collect([]). 8 | collect([X]) :- hyp(X). 9 | collect([X,Y|L]) :- hyp(X), collect([Y|L]), X @=< Y. 10 | 11 | unpack([]). 12 | unpack([X|L]) :- assumel(hyp(X)), unpack(L). 13 | 14 | lsort(L,K) :- unpack(L), collect(K), \+ hyp(X). 15 | 16 | go:-lsort([10,2,33,10,24,2],R),write(R),nl,fail. 17 | go. 18 | -------------------------------------------------------------------------------- /progs/profile.pl: -------------------------------------------------------------------------------- 1 | % example of BinProlog Internet profile 2 | % usful if BinProlog is not able to 3 | % detect everything about your machine's 4 | % network environment 5 | 6 | % example 7 | 8 | master_server('139.103.16.4',7000). 9 | login(paul). 10 | password(evrika). 11 | this_host('139.103.16.4'). 12 | host('139.103.16.4'). 13 | %proxy_server('139.103.16.2'). % put this only if you really have it! 14 | 15 | % To meet other users: open 2 windows running BinProlog 16 | % do in the first one: ?-listen. 17 | % do in the second one: ?-chat. 18 | -------------------------------------------------------------------------------- /progs/bug.pl: -------------------------------------------------------------------------------- 1 | go:- 2 | quiet(0), 3 | timed_call(ok,(list_engines,repeat,sleep(1),fail),3,_), 4 | list_engines, 5 | fail. 6 | 7 | fixed1:- 8 | create_engine(256,64,64,E), 9 | list_engines, 10 | /* 11 | load_engine(E,append(As,Bs,[A,B,B,A]),As+Bs), 12 | ask_engine(E,R1),write(R1),nl, 13 | ask_engine(E,R2),write(R2),nl, 14 | load_engine(E,member(X,[1,2,3]),X), 15 | ask_engine(E,R3),write(R3),nl, 16 | ask_engine(E,R4),write(R4),nl, 17 | */ 18 | destroy_engine(E). 19 | 20 | /* 21 | 22 | 23 | */ 24 | -------------------------------------------------------------------------------- /progs/ilgraph.pl: -------------------------------------------------------------------------------- 1 | path(G,X,Z,[X|Xs]) :- 2 | linked(G,X,Ys)->member(Y,Ys),path(G,Y,Z,Xs) 3 | ; X=Z,Xs=[]. 4 | 5 | linked(G,X,Ys):-val(G,X,N-Ys),var(N),N=deja_vu. 6 | 7 | new_graph(G):- 8 | lval(G,1,_-[2,3]), 9 | lval(G,2,_-[1,4]), 10 | lval(G,3,_-[1,5]), 11 | lval(G,4,_-[1,5]). 12 | 13 | walk(G,Xs):- 14 | new_graph(G), 15 | path(G,1,5,Xs). 16 | 17 | go:-walk(g,Path),write(Path),nl,fail. 18 | 19 | % lval defines a 2 keyed backtrackable global variable 20 | % val gets the value of a 2 keyed backtrackable global variable if defined 21 | -------------------------------------------------------------------------------- /library/test_kernel_prolog.pl: -------------------------------------------------------------------------------- 1 | :-[kernel_prolog]. 2 | 3 | t1:-t1(_). 4 | 5 | t1(NewEs):- 6 | assertK( 7 | (a(13):-true), 8 | [], 9 | Es 10 | ), 11 | assertK( 12 | (a(14):-true), 13 | Es, 14 | NewEs 15 | ), 16 | clauseK(NewEs,a(X),true), 17 | println(X), 18 | fail. 19 | 20 | t2:- 21 | t1(Es), 22 | assertK((b(X):-a(X)),Es,NewEs), 23 | solveK(NewEs,b(R)), 24 | println(R), 25 | fail. 26 | 27 | 28 | :-dynamic a/1. 29 | :-dynamic b/1. 30 | 31 | a(1). 32 | a(2). 33 | 34 | b(X):-a(X). 35 | -------------------------------------------------------------------------------- /progs/lat_wam.pl: -------------------------------------------------------------------------------- 1 | :-[lattice]. 2 | 3 | wam(0,[constant,deep,head]). 4 | wam(1,[deep,head,structure]). 5 | wam(2,[deep,head,value]). 6 | wam(3,[deep,head,variable]). 7 | wam(4,[body,constant,deep]). 8 | wam(5,[body,deep,structure]). 9 | wam(6,[body,deep,value]). 10 | wam(7,[body,deep,variable]). 11 | wam(8,[constant,head,top]). 12 | wam(9,[head,structure,top]). 13 | wam(10,[head,top,value]). 14 | wam(11,[head,top,variable]). 15 | wam(12,[body,constant,top]). 16 | wam(13,[body,structure,top]). 17 | wam(14,[body,top,value]). 18 | wam(15,[body,top,variable]). 19 | 20 | lcontext(L,Rs):-wam(L,Rs). 21 | 22 | -------------------------------------------------------------------------------- /src/OLD/mac: -------------------------------------------------------------------------------- 1 | # generates BinProlog 2 | 3 | mv -f wam.c wam_c.txt 4 | mv -f wam.h wam_h.txt 5 | mv -f binpro.c binpro_c.txt 6 | mv -f binpro.h binpro_h.txt 7 | gcc -o ru *.c 8 | ./ru remake 9 | ./ru "and(cboot,halt)" 10 | mv -f stub.c stub.txt 11 | gcc -g -O3 -c *.c 12 | 13 | # makes static library in ../lib 14 | gcc -g -O3 -o bp *.o 15 | ar -q libbps.a *.o 16 | mv -f bp ../bin 17 | mv -f libbps.a ../lib 18 | 19 | cp c_defs.h global.h ../lib 20 | 21 | # clean up 22 | mv -f stub.txt stub.c 23 | rm -f wam_c.txt 24 | rm -f wam_h.txt 25 | rm -f binpro_c.txt 26 | rm -f binpro_h.txt 27 | rm -f *.o 28 | rm -f *.a 29 | rm -f *.so 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /library/file2or.pl: -------------------------------------------------------------------------------- 1 | file2clause(F0,C):- 2 | seeing(S), 3 | find_file(F0,F),!, 4 | see(F), 5 | repeat, 6 | read(X), 7 | ( X=end_of_file,!,see(F),seen,see(S),fail 8 | ; C=X 9 | ). 10 | 11 | 12 | file2byte(F0,C):- 13 | seeing(S), 14 | find_file(F0,F),!, 15 | see(F), 16 | repeat, 17 | get0(X), 18 | ( X =:= -1,!,see(F),seen,see(S),fail 19 | ; C=X 20 | ). 21 | 22 | file2pred(F0,FNCs):- 23 | seeing(S), 24 | find_file(F0,F),!, 25 | see(F), 26 | repeat, 27 | get_a_predicate(mem,FN,Cs), 28 | ( FN==end_of_file/0,Cs=[end_of_file],!, 29 | see(F),seen,see(S),fail 30 | ; FNCs=FN-Cs 31 | ). 32 | 33 | -------------------------------------------------------------------------------- /progs/q8.pl: -------------------------------------------------------------------------------- 1 | % Variant of a program by T. Fruhwrith 2 | 3 | go:-go('BMARK_q8:'). 4 | 5 | go(Mes):- 6 | statistics(runtime,_),queens(8,_),fail 7 | ; statistics(runtime,[_,T]),write(Mes=time(T)),nl. 8 | 9 | queens(N,Qs):- gen_list(N,Qs), place_queens(N,Qs,_,_). 10 | 11 | gen_list(0,[]). 12 | gen_list(N,[_|L]):- 13 | N>0, M is N-1, 14 | gen_list(M,L). 15 | 16 | place_queens(0,_,_,_). 17 | place_queens(I,Cs,Us,[_|Ds]):- 18 | I>0, J is I-1, 19 | place_queens(J,Cs,[_|Us],Ds), 20 | place_queen(I,Cs,Us,Ds). 21 | 22 | place_queen(I,[I|_],[I|_],[I|_]). 23 | place_queen(I,[_|Cs],[_|Us],[_|Ds]):- 24 | place_queen(I,Cs,Us,Ds). 25 | -------------------------------------------------------------------------------- /progs/dbsort.pl: -------------------------------------------------------------------------------- 1 | go:- dynbbgc,create_engine(8000,500,2000,Engine), 2 | load_engine(Engine,test(X),X), 3 | ask_engine(Engine,Answer), 4 | write(Answer),nl, 5 | destroy_engine(Engine). 6 | 7 | test(working):- 8 | abolish(i/4), 9 | consult('wam.txt'), 10 | functor(G,ii,4), 11 | findall(G,G,Gs), 12 | (length(Gs,L1),write(unsorted_facts(L1)),nl,fail;true), 13 | sort(Gs,Sorted), 14 | length(Sorted,L), 15 | statistics, 16 | write(sorted_facts(L)),nl, 17 | abolish(ii/4), 18 | member(X,Sorted), 19 | assert(X), 20 | fail. 21 | test(done):- 22 | functor(G,ii,4), 23 | findall(G,G,Gs), 24 | length(Gs,L), 25 | write(checked_facts(L)),nl. 26 | -------------------------------------------------------------------------------- /library/foldall.pro: -------------------------------------------------------------------------------- 1 | foldall(F,X^G,R):- 2 | new_engine('$found'(X),G,E), 3 | get(E,the(A)), 4 | check_return(A,R1), 5 | combine_with(E,F,R1,R2), 6 | !, 7 | R=R2. 8 | 9 | combine_with(E,F,R1,R3):- 10 | get(E,the(A)), 11 | check_return(A,X), 12 | call(F,R1,X,R), 13 | !, 14 | R2=R, 15 | combine_with(E,F,R2,R3). 16 | combine_with(_,_,R,R). 17 | 18 | check_return(R,X):-nonvar(R),R='$found'(A),!,X=A. 19 | check_return(Ret,_):-return(Ret),fail. 20 | 21 | freverse(Xs,Ys):-foldall(rcons,X^(X=[];member(X,Xs)),Ys). 22 | 23 | rcons(Y,X,[X|Y]). 24 | 25 | xdiv(X,Y,R):-(X=0;Y=0)->return(0);R is X//Y. 26 | 27 | ydiv(X,Y,R):-(X=0;Y=0)->fail;R is X//Y. 28 | 29 | -------------------------------------------------------------------------------- /progs/rpc_chat.pro: -------------------------------------------------------------------------------- 1 | go1:-bg(listen1),talk1. 2 | go2:-bg(listen2),talk2. 3 | 4 | listen1:- 5 | set_this_port(5001), 6 | trust. 7 | 8 | talk1:- 9 | set_that_port(5002), 10 | for(I,1,5), 11 | remote_run(println(one(I))), 12 | fail. 13 | 14 | listen2:- 15 | set_this_port(5002), 16 | trust. 17 | 18 | talk2:- 19 | set_that_port(5001), 20 | for(I,1,5), 21 | remote_run(println(two(I))), 22 | fail. 23 | 24 | one:- 25 | set_that_port(5002), 26 | remote_run( 27 | and( 28 | set_that_port(5003), 29 | remote_run(println(hello)) 30 | ) 31 | ). 32 | 33 | two:- 34 | set_this_port(5002), 35 | trust. 36 | 37 | three:- 38 | set_this_port(5003), 39 | trust. 40 | -------------------------------------------------------------------------------- /progs/bm.pl: -------------------------------------------------------------------------------- 1 | bm:-bm1,bm2,bm(pereira,[pbench]),halt. 2 | 3 | bm1:- 4 | bm(gc_and_speed,[nrev,boyer,tsp,tak,allperms,bfmeta,gc,choice]). 5 | 6 | bm2:- 7 | All0=[differen,q8,cnrev,fibo, 8 | lknight,qrev,cal,color,fknight,lat_plan,maxlist,primes,qsort,war, 9 | chat,cube,fq8,lat_wam,money,puzzle,subset,assertbm], 10 | sort(All0,All), 11 | println(All), 12 | bm(all,All). 13 | 14 | bm(Topic,Names):- 15 | println(testing(Topic)+Names), 16 | member(Name,Names), 17 | println(running(Name)), 18 | enter(Name,go), 19 | fail. 20 | bm(Topic,_):- 21 | println(end(Topic)). 22 | 23 | bug:- 24 | enter(nrev,go). 25 | 26 | bug1:- 27 | enter(nrev,bug). 28 | 29 | -------------------------------------------------------------------------------- /progs/coco_data.pl: -------------------------------------------------------------------------------- 1 | 2 | 3 | test:- 4 | init, % creates prototypes `unique' and `cloneable' 5 | prelude, % specific prelude 6 | login(wizard),clone(song), 7 | take(song,How), 8 | dig(room), 9 | go(room), 10 | drop(song,How), 11 | logout,listing, 12 | fail. 13 | 14 | go:- 15 | init, % creates prototypes `unique' and `cloneable' 16 | prelude, % specific prelude 17 | login(wizard), 18 | dig(room), 19 | go(room), 20 | craft(flower), 21 | move(flower,lobby), 22 | logout, 23 | login(mary), 24 | clone(poem), 25 | take(poem,Cloneable), 26 | go(room), 27 | drop(poem,Cloneable), 28 | logout, 29 | listing, 30 | fail. 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/OLD/makenew.bat: -------------------------------------------------------------------------------- 1 | mv -f wam.c wam_c.txt 2 | mv -f wam.h wam_h.txt 3 | mv -f binpro.c binpro_c.txt 4 | mv -f binpro.h binpro_h.txt 5 | gcc -DAIX -fomit-frame-pointer -g -o ru.exe *.c -lm 6 | ru.exe remake 7 | ru.exe "and(cboot,halt)" 8 | mv -f stub.c stub.txt 9 | gcc -DAIX -fomit-frame-pointer -g -O3 -c *.c -lm 10 | gcc -fomit-frame-pointer -g -O3 -o bp.exe *.o -lm 11 | gcc -DAIX -DNOMAIN -DEXTERNAL_TSTORE -fomit-frame-pointer -g -O3 -c builtins.c c.c -lm 12 | ar -q libbps.a *.o 13 | mv -f libbps.a ../lib 14 | cp c_defs.h global.h ../lib 15 | mv -f stub.txt stub.c 16 | rm -f wam_c.txt 17 | rm -f wam_h.txt 18 | rm -f binpro_c.txt 19 | rm -f binpro_h.txt 20 | :end 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /progs/or_engtest.pl: -------------------------------------------------------------------------------- 1 | /* 2 engines are created and run in parallel */ 2 | /* both fully backtrack through their search-tree */ 3 | /* the result of the consumer is kept through a side-effect (assert) */ 4 | 5 | 6 | new_engine(G,X,E):- 7 | create_engine(100,100,100,E), 8 | load_engine(E,G,X). 9 | 10 | p(P):-new_engine(append(X,Y,[A,A]),sol(X,Y),P). 11 | 12 | consume(P,[X|Xs]):-ask_engine(P,A),!,copy_term(A,X),consume(P,Xs). 13 | consume(_,[]). 14 | 15 | keep(P):-consume(P,Xs),assert(sol(P,Xs)). 16 | 17 | c(P,C):-new_engine(keep(P),_,C). 18 | 19 | go:-p(A),c(A,B), 20 | multitask_engines(100), 21 | retract(sol(P,Xs)), 22 | !, 23 | destroy_engine(A), 24 | destroy_engine(B), 25 | write(P+Xs),nl. 26 | 27 | 28 | -------------------------------------------------------------------------------- /progs/ffibo.pl: -------------------------------------------------------------------------------- 1 | fibo(N,X):-N=<1,!,X=1. 2 | fibo(N,X):-N1 is N-1,N2 is N-2,fibo(N1,X1),fibo(N2,X2),X is X1+X2. 3 | 4 | range(Min,Min,Max):-Min=>X, 9 | dx>>DX, 10 | NewX is X+DX, 11 | x<>DX,write(dx=DX),nl, 30 | inc,inc,x>>AA, 31 | plus(15,14,BB), 32 | *(15,14,CC) 33 | ), 34 | 35 | d with a:=44, 36 | 37 | write([X,AA,BB,CC]),nl, 38 | 39 | oblist. 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /progs/tsp.pl: -------------------------------------------------------------------------------- 1 | % derived from a program by Thomas Conway 2 | 3 | travel(Places, Route) :- 4 | findall(Cost - Order, 5 | ( cperm(Places, Order), dist(Order, Cost)), 6 | Solns), 7 | sort(Solns, [_ - Route|_]). 8 | 9 | cperm([First|Is],CircPs):-perm([First|Is],Ps),append(Ps,[First],CircPs). 10 | 11 | perm([],[]). 12 | perm([X|Xs],Zs):- 13 | perm(Xs,Ys), 14 | insert(X,Ys,Zs). 15 | 16 | insert(X,Ys,[X|Ys]). 17 | insert(X,[Y|Ys],[Y|Zs]):- 18 | insert(X,Ys,Zs). 19 | 20 | dist(Ps,Dist):-foldl(dist2,0,Ps,Dist). 21 | 22 | dist2(P,P,0):-!. 23 | dist2(P1,P2,D):- D is (P1+P2). 24 | 25 | ints(N,Is):-findall(I,for(I,1,N),Is). 26 | 27 | go(N):-ctime(T1),ints(N,Ps),travel(Ps,Route),ctime(T2),T is T2-T1, 28 | write(time(T)+route(Route)),nl. 29 | 30 | go:-go(7). 31 | -------------------------------------------------------------------------------- /progs/bm2.bat: -------------------------------------------------------------------------------- 1 | ..\bin\bp -q5 [color] tell('bm2.txt') call(go) call(told) call(halt) 2 | ..\bin\bp -q5 [cube] tell_at_end('bm2.txt') call(go) call(told) call(halt) 3 | ..\bin\bp -q5 [han] tell_at_end('bm2.txt') call(go) call(told) call(halt) 4 | ..\bin\bp -q5 [fibo] tell_at_end('bm2.txt') call(go) call(told) call(halt) 5 | ..\bin\bp -q5 [knight] tell_at_end('bm2.txt') call(go) call(told) call(halt) 6 | ..\bin\bp -q5 [nnet] tell_at_end('bm2.txt') call(go) call(told) call(halt) 7 | ..\bin\bp -q5 [puzzle] tell_at_end('bm2.txt') call(go) call(told) call(halt) 8 | ..\bin\bp -q5 [lat_wam] tell_at_end('bm2.txt') call(go) call(told) call(halt) 9 | @echo ..\bin\bp -q5 [bm_tetris] tell_at_end('bm2.txt') call(go) call(told) call(halt) 10 | REM ..\bin\bp -q5 -b0 [pbench] tell_at_end('bm2.txt') call(go) call(told) call(halt) 11 | 12 | -------------------------------------------------------------------------------- /src/OLD/mac64: -------------------------------------------------------------------------------- 1 | echo ---------------------- 2 | echo generates BinProlog 3 | 4 | mv -f wam.c wam_c.txt 5 | mv -f wam.h wam_h.txt 6 | mv -f binpro.c binpro_c.txt 7 | mv -f binpro.h binpro_h.txt 8 | gcc -o ru *.c 9 | ./ru remake 10 | ./ru "and(cboot,halt)" 11 | mv -f stub.c stub.txt 12 | 13 | echo makes static library in ../lib 14 | gcc -DW64 -m64 -arch x86_64 -g -O3 -c *.c 15 | gcc --DW64 -m64 -arch x86_64 -g -O3 -o bp *.o 16 | 17 | echo --------------------- 18 | echo calls ar 19 | ar -q libbps.a *.o 20 | mv -f bp ../bin 21 | mv -f libbps.a ../lib 22 | 23 | cp c_defs.h global.h ../lib 24 | 25 | echo ------------------------ 26 | echo clean up 27 | mv -f stub.txt stub.c 28 | rm -f wam_c.txt 29 | rm -f wam_h.txt 30 | rm -f binpro_c.txt 31 | rm -f binpro_h.txt 32 | rm -f *.o 33 | rm -f *.a 34 | rm -f *.so 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /library/coord1.pl: -------------------------------------------------------------------------------- 1 | init:- 2 | bb_let(server,host,localhost), 3 | bb_let(server,port,7001), 4 | bb_let(server,password,eureka). 5 | 6 | server:- 7 | bg(run_server). 8 | 9 | cons:- 10 | remote_run(consumer(X)), 11 | println(got=X). 12 | 13 | consumer(R):- 14 | wait_for(in_range(ship,R),R<10). 15 | 16 | prod:- 17 | Bad=11, 18 | remote_run(producer(Bad)), 19 | println(produced=Bad), 20 | sleep(3), 21 | Good=9, 22 | remote_run(producer(Good)), 23 | println(produced=Good). 24 | 25 | 26 | producer(X):- 27 | notify_about(in_range(ship,X)). 28 | 29 | /* 30 | server window 31 | ?-server. 32 | 33 | consumer window 34 | ?- cons. 35 | got = 9 36 | yes 37 | 38 | producer window 39 | 40 | ?- prod. 41 | produced = 11 42 | produced = 9 43 | yes 44 | */ 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /src/OLD/makenew: -------------------------------------------------------------------------------- 1 | # generates BinProlog 2 | 3 | mv -f wam.c wam_c.txt 4 | mv -f wam.h wam_h.txt 5 | mv -f binpro.c binpro_c.txt 6 | mv -f binpro.h binpro_h.txt 7 | cc -DAIX -o ru *.c -lm 8 | ./ru remake 9 | ./ru "and(cboot,halt)" 10 | mv -f stub.c stub.txt 11 | cc -DAIX -g -O4 -c *.c -lm 12 | 13 | # makes static library in ../lib 14 | cc -DAIX -g -O4 -o bp *.o -lm 15 | ar -q libbps.a *.o 16 | mv -f bp ../bin 17 | mv -f libbps.a ../lib 18 | 19 | # makes dynamic lib in ../lib - AIX specific 20 | 21 | rm -f *.o 22 | cc -g -O4 -brtl -G -DAIX -c -lm *.c 23 | ar -q libbp.so *.o 24 | cp libbp.so ../lib 25 | cp c_defs.h global.h ../lib 26 | 27 | # clean up 28 | mv -f stub.txt stub.c 29 | rm -f wam_c.txt 30 | rm -f wam_h.txt 31 | rm -f binpro_c.txt 32 | rm -f binpro_h.txt 33 | rm -f *.o 34 | rm -f *.a 35 | rm -f *.so 36 | 37 | -------------------------------------------------------------------------------- /src/OLD/mac32mt: -------------------------------------------------------------------------------- 1 | echo ---------------------- 2 | echo generates BinProlog 3 | 4 | mv -f wam.c wam_c.txt 5 | mv -f wam.h wam_h.txt 6 | mv -f binpro.c binpro_c.txt 7 | mv -f binpro.h binpro_h.txt 8 | gcc -o ru *.c 9 | ./ru remake 10 | ./ru "and(cboot,halt)" 11 | mv -f stub.c stub.txt 12 | 13 | echo makes static library in ../lib 14 | gcc -g -O3 -DTHREADS=1 -fomit-frame-pointer -c *.c 15 | gcc -g -O3 -DTHREADS=1 -fomit-frame-pointer -lpthread -o bp *.o 16 | 17 | echo --------------------- 18 | echo calls ar 19 | ar -q libbps.a *.o 20 | mv -f bp ../bin 21 | mv -f libbps.a ../lib 22 | 23 | cp c_defs.h global.h ../lib 24 | 25 | echo ------------------------ 26 | echo clean up 27 | mv -f stub.txt stub.c 28 | rm -f wam_c.txt 29 | rm -f wam_h.txt 30 | rm -f binpro_c.txt 31 | rm -f binpro_h.txt 32 | rm -f *.o 33 | rm -f *.a 34 | rm -f *.so 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/OLD/makemac: -------------------------------------------------------------------------------- 1 | # generates BinProlog 2 | 3 | mv -f wam.c wam_c.txt 4 | mv -f wam.h wam_h.txt 5 | mv -f binpro.c binpro_c.txt 6 | mv -f binpro.h binpro_h.txt 7 | gcc -o ru *.c -lm 8 | ./ru remake 9 | ./ru "and(cboot,halt)" 10 | mv -f stub.c stub.txt 11 | gcc -arch i386 -arch ppc -g -O4 -c *.c -lm 12 | 13 | # makes static library in ../lib 14 | gcc -arch i386 -arch ppc -g -O4 -o bp *.o -lm 15 | ar -q libbps.a *.o 16 | mv -f bp ../bin 17 | mv -f libbps.a ../lib 18 | 19 | # makes dynamic lib in ../lib 20 | 21 | rm -f *.o 22 | gcc -arch i386 -arch ppc -g -O4 -brtl -c -lm *.c 23 | ar -q libbp.so *.o 24 | cp libbp.so ../lib 25 | cp c_defs.h global.h ../lib 26 | 27 | # clean up 28 | mv -f stub.txt stub.c 29 | rm -f wam_c.txt 30 | rm -f wam_h.txt 31 | rm -f binpro_c.txt 32 | rm -f binpro_h.txt 33 | rm -f *.o 34 | rm -f *.a 35 | rm -f *.so 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /src/go.sh: -------------------------------------------------------------------------------- 1 | echo ---------------------- 2 | echo generates BinProlog 3 | 4 | mv -f wam.c wam_c.txt 5 | mv -f wam.h wam_h.txt 6 | mv -f binpro.c binpro_c.txt 7 | mv -f binpro.h binpro_h.txt 8 | gcc -o ru *.c 9 | ./ru remake 10 | ./ru "and(cboot,halt)" 11 | mv -f stub.c stub.txt 12 | 13 | echo makes static library in ../lib 14 | gcc -DW64 -DTHREADS=1 -m64 -arch x86_64 -g3 -O3 -Wall -lpthread -c *.c 15 | gcc -DW64 -DTHREADS=1 -m64 -arch x86_64 -g3 -O3 -Wall -lpthread -o bp *.o 16 | 17 | echo --------------------- 18 | echo calls ar 19 | ar -q libbps.a *.o 20 | mv -f bp ../bin 21 | mv -f libbps.a ../lib 22 | 23 | #cp c_defs.h global.h ../lib 24 | 25 | echo ------------------------ 26 | echo clean up 27 | mv -f stub.txt stub.c 28 | rm -f wam_c.txt 29 | rm -f wam_h.txt 30 | rm -f binpro_c.txt 31 | rm -f binpro_h.txt 32 | rm -f *.o 33 | rm -f *.a 34 | rm -f *.so 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/mac64mt.sh: -------------------------------------------------------------------------------- 1 | echo ---------------------- 2 | echo generates BinProlog 3 | 4 | mv -f wam.c wam_c.txt 5 | mv -f wam.h wam_h.txt 6 | mv -f binpro.c binpro_c.txt 7 | mv -f binpro.h binpro_h.txt 8 | gcc -o ru *.c 9 | ./ru remake 10 | ./ru "and(cboot,halt)" 11 | mv -f stub.c stub.txt 12 | 13 | echo makes static library in ../lib 14 | gcc -DW64 -DTHREADS=1 -m64 -arch x86_64 -g3 -O3 -Wall -lpthread -c *.c 15 | gcc -DW64 -DTHREADS=1 -m64 -arch x86_64 -g3 -O3 -Wall -lpthread -o bp *.o 16 | 17 | echo --------------------- 18 | echo calls ar 19 | ar -q libbps.a *.o 20 | mv -f bp ../bin 21 | mv -f libbps.a ../lib 22 | 23 | #cp c_defs.h global.h ../lib 24 | 25 | echo ------------------------ 26 | echo clean up 27 | mv -f stub.txt stub.c 28 | rm -f wam_c.txt 29 | rm -f wam_h.txt 30 | rm -f binpro_c.txt 31 | rm -f binpro_h.txt 32 | rm -f *.o 33 | rm -f *.a 34 | rm -f *.so 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /doc/crossref.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \textheight 21 cm 4 | \textwidth 14 cm 5 | 6 | \topmargin -1mm 7 | \marginparwidth 0mm 8 | \evensidemargin 1.5 cm 9 | \oddsidemargin 1.5 cm 10 | 11 | \begin{document} 12 | \pagestyle{plain} 13 | \bibliographystyle{abbrv} 14 | 15 | \title{ 16 | \Huge 17 | BinProlog Professional Edition\\ 18 | Predicate Cross-Reference Guide \\ 19 | \vskip 5cm 20 | } 21 | 22 | \author{ 23 | \Large 24 | Written by BinProlog Itself\\ 25 | under the kind regards of:\\ 26 | \large 27 | Paul Tarau\\ 28 | BinNet Corp.\\ 29 | WWW: http://www.binnetcorp.com\\ 30 | \normalsize 31 | } 32 | 33 | \maketitle 34 | \newpage 35 | \input preds.tex 36 | 37 | Related BinProlog documentation is available at: 38 | \cite{bp7user,bp7advanced,bp7interface,bp7crossref}. 39 | 40 | \bibliography{tarau} 41 | 42 | \end{document} 43 | -------------------------------------------------------------------------------- /progs/fmoney.pl: -------------------------------------------------------------------------------- 1 | go:- 2 | time(_), 3 | puzzle(Show,[0,1,2,3,4,5,6,7,8,9],_), 4 | time(T), 5 | Show, 6 | write(time(T)),nl. 7 | 8 | 9 | puzzle(show(S,E,N,D,M,O,R,Y))--> 10 | digit(D),digit(E),{add_digit(D,E,Y, 0,R1)},digit(Y), 11 | digit(N),digit(R),{add_digit(N,R,E, R1,R2)}, 12 | digit(O), {add_digit(E,O,N, R2,R3)}, 13 | digit(S),{S>0}, 14 | digit(M),{M>0}, {add_digit(S,M,O, R3, 15 | M)}. 16 | 17 | add_digit(C1,C2,Res,R1,R2):- 18 | S is C1+C2+R1, 19 | Res is S mod 10, 20 | R2 is S // 10. 21 | 22 | digit(X,[X|Xs],Xs). 23 | digit(X,[Y|Xs],[Y|Ys]):-digit(X,Xs,Ys). 24 | 25 | show(S,E,N,D,M,O,R,Y):- 26 | write(' '), 27 | write([S,E,N,D]), 28 | write(+),nl, 29 | write(' '), 30 | write([M,O,R,E]), 31 | write(=),nl, 32 | write([M,O,N,E,Y]),nl, 33 | fail 34 | ; nl. 35 | 36 | time(T):-statistics(runtime,[_,T]). 37 | -------------------------------------------------------------------------------- /progs/tak.pl: -------------------------------------------------------------------------------- 1 | % 2 | % tak 3 | % 4 | % Evan Tick (from Lisp version by R. P. Gabriel) 5 | % 6 | % (almost) Takeuchi function (recursive arithmetic) 7 | % arithmetics reordered for optimal inline execution - Paul Tarau 1994 8 | 9 | :-write('In BinProlog use: -h1200 '),nl. 10 | :-set_c_threshold(9). 11 | 12 | go :- statistics(global_stack,[H1,_]), 13 | statistics(runtime,_), 14 | tak, 15 | statistics(runtime,[_,T]), 16 | statistics(global_stack,[H2,_]),H is H2-H1, 17 | nl,write('BMARK_tak:' = [time=T,heap=H]), nl. 18 | 19 | 20 | tak :- tak(18,12,6,R), write(tak(18,12,6)=R), nl. 21 | 22 | tak(X,Y,Z,A):- 23 | X =< Y,!, 24 | A = Z. 25 | tak(X,Y,Z,A):- 26 | X1 is X - 1, 27 | Y1 is Y - 1, 28 | Z1 is Z - 1, 29 | tak(X1,Y,Z,A1), 30 | tak(Y1,Z,X,A2), 31 | tak(Z1,X,Y,A3), 32 | tak(A1,A2,A3,A). 33 | 34 | -------------------------------------------------------------------------------- /src/OLD/makenew1: -------------------------------------------------------------------------------- 1 | # generates BinProlog 2 | 3 | mv -f wam.c wam_c.txt 4 | mv -f wam.h wam_h.txt 5 | mv -f binpro.c binpro_c.txt 6 | mv -f binpro.h binpro_h.txt 7 | cc -DAIX -o ru *.c -lm 8 | ru remake 9 | ru "and(cboot,halt)" 10 | mv -f stub.c stub.txt 11 | cc -DAIX -g -O4 -c *.c -lm 12 | 13 | # makes static library in ../lib 14 | cc -g -O4 -o bp *.o -lm 15 | cc -DAIX -DEXTERNAL_TSTORE -g -O4 -c builtins.c c.c -lm 16 | ar -q libbps.a *.o 17 | mv -f bp ../bin 18 | mv -f libbps.a ../lib 19 | 20 | # makes dynamic lib in ../lib - AIX specific 21 | 22 | rm -f *.o 23 | cc -g -O4 -brtl -G -DEXTERNAL_TSTORE -DAIX -c -lm *.c 24 | ar -q libbp.so *.o 25 | cp libbp.so ../lib 26 | cp c_defs.h global.h ../lib 27 | 28 | # clean up 29 | mv -f stub.txt stub.c 30 | rm -f wam_c.txt 31 | rm -f wam_h.txt 32 | rm -f binpro_c.txt 33 | rm -f binpro_h.txt 34 | rm -f *.o 35 | rm -f *.a 36 | rm -f *.so 37 | 38 | -------------------------------------------------------------------------------- /progs/queens.pl: -------------------------------------------------------------------------------- 1 | go:- N=24, 2 | statistics(runtime,_), 3 | queens(N,L), statistics(runtime,[_,Y]), 4 | write(L), nl, 5 | write('BMARK_queens:'=[time(Y),'N'=N]), nl. 6 | 7 | 8 | 9 | 10 | queens(N,Qs):- 11 | range(1,N,Ns), 12 | queens(Ns,[],Qs). 13 | 14 | 15 | queens([],Qs,Qs). 16 | queens(UnplacedQs,SafeQs,Qs):- 17 | sel(UnplacedQs,UnplacedQs1,Q), 18 | not_attack(SafeQs,Q), 19 | queens(UnplacedQs1,[Q|SafeQs],Qs). 20 | 21 | 22 | not_attack(Xs,X):-not_attack(Xs,X,1). 23 | 24 | not_attack([],_,_):-!. 25 | not_attack([Y|Ys],X,N):- 26 | X =\= Y+N, 27 | X =\= Y-N, 28 | N1 is N+1, 29 | not_attack(Ys,X,N1). 30 | 31 | sel([X|Xs],Xs,X). 32 | sel([Y|Ys],[Y|Zs],X):- 33 | sel(Ys,Zs,X). 34 | 35 | range(N,N,[N]):- !. 36 | range(M,N,[M|Ns]):- 37 | M < N, 38 | M1 is M+1, 39 | range(M1,N,Ns). 40 | 41 | -------------------------------------------------------------------------------- /progs/subset.pl: -------------------------------------------------------------------------------- 1 | subset([],[]). 2 | subset([_|Xs],Ys):-subset(Xs,Ys). 3 | subset([X|Xs],[X|Ys]):-subset(Xs,Ys). 4 | 5 | gen_list(0,[]). 6 | gen_list(N,[_|L]):- 7 | N>0, M is N-1, 8 | gen_list(M,L). 9 | 10 | test(S):-gen_list(14,L),subset(L,S). 11 | 12 | nondet:-gen_list(16,L),subset(L,_),fail. 13 | nondet. 14 | 15 | t:- 16 | statistics(runtime,_),all,fail 17 | ; statistics(runtime,[_,T]),write(time=T),nl. 18 | 19 | 20 | pow(S,Xs):-findall(X,subset(S,X),Xs). 21 | 22 | pow2(S,XXs):-findall(Xs,(pow(S,P),member(X,P),pow(X,Xs)),XXs). 23 | 24 | g(N):-gen_list(N,Xs),pow2(Xs,S),length(S,L),write(L),nl. 25 | 26 | go(Mes):-write('use bp -h20000'),nl, 27 | statistics(runtime,_), 28 | nondet, 29 | statistics(runtime,[_,T0]), 30 | findall(Q,test(Q),Qs), 31 | statistics(runtime,[_,T]), 32 | length(Qs,L), 33 | write(Mes=[nondet^16=T0,findall(L)=T]),nl. 34 | 35 | go:-go('BMARK_subset'). 36 | 37 | p:-[subset]. 38 | -------------------------------------------------------------------------------- /progs/thread_test.pro: -------------------------------------------------------------------------------- 1 | go :- bg(say_hello, Thread, EngineAddr, EngineId), 2 | println(thread(Thread)), 3 | println(engine(Thread,EngineAddr,same(EngineId))), 4 | !. 5 | 6 | say_hello :- 7 | println('hello from background thread'), 8 | current_engine_addr(Addr), 9 | current_engine_id(Id), 10 | current_thread(T), 11 | println(bg_engine(T,Addr,same(Id))), 12 | !. 13 | 14 | go1:- 15 | bg(bg_process,Thread), 16 | fg_process(Thread), 17 | println(threads_joined). 18 | 19 | bg_process:- 20 | println(starting(bg_process)), 21 | local_in(a(X)), 22 | println(bg_process_got(a(X))), 23 | sleep(10), 24 | println(bg_meeting_point_1). 25 | 26 | fg_process(Thread):- 27 | sleep(5), 28 | println(starting(fg_process)), 29 | local_out(a(1)), 30 | thread_join(Thread), 31 | println(fg_meeting_point_1_with(Thread)). 32 | 33 | -------------------------------------------------------------------------------- /progs/bm1.bat: -------------------------------------------------------------------------------- 1 | ..\bin\bp -q5 [brev] tell('bm.txt') call(big) call(told) call(halt) 2 | ..\bin\bp -q5 [cal] tell_at_end('bm.txt') go(100000) call(told) call(halt) 3 | ..\bin\bp -q5 -h8000 -t1000 [boyer] tell_at_end('bm.txt') call(go) call(told) call(halt) 4 | ..\bin\bp -q5 -h7000 [tsp] tell_at_end('bm.txt') call(go) call(told) call(halt) 5 | ..\bin\bp -q5 -h3000 [tak] tell_at_end('bm.txt') call(go) call(told) call(halt) 6 | ..\bin\bp -q5 -h20000 -t2000 -b0 [allperms] tell_at_end('bm.txt') call(go) call(told) call(halt) 7 | ..\bin\bp -q5 [bfmeta] tell_at_end('bm.txt') call(go) call(told) call(halt) 8 | ..\bin\bp -q5 -h20000 -t2000 [gc] tell_at_end('bm.txt') call(go) call(told) call(halt) 9 | ..\bin\bp -q5 -h2000 -s16000 [choice] tell_at_end('bm.txt') call(go) call(told) call(halt) 10 | ..\bin\bp -q5 [war] tell_at_end('bm.txt') call(go) call(told) call(halt) 11 | ..\bin\bp -q5 -h2000 [chat] tell_at_end('bm.txt') call(go) call(told) call(halt) 12 | -------------------------------------------------------------------------------- /progs/fibo.pl: -------------------------------------------------------------------------------- 1 | fibo(N,X):-N=<1,!,X=1. 2 | fibo(N,X):-N1 is N-1,N2 is N-2,fibo(N1,X1),fibo(N2,X2),X is X1+X2. 3 | 4 | range(Min,Min,Max):-Min=Fs=[Files];Fs=Files), 5 | foreach(member(F,Fs),portable_consult(F,Db)), 6 | db_save(Db,File). 7 | 8 | portable_consult(File,Db):- 9 | ( is_prolog(binprolog)->consult(File,Db) 10 | ; db_consult(File,Db) 11 | ). 12 | 13 | /* 14 | 15 | Usually you make a file like: 16 | 17 | project.pl containing: 18 | 19 | :-[myfile1]. 20 | :-[myfile2]. 21 | ... 22 | 23 | and then call to_simple with it. Here is an example 24 | with a single file - note that discontiguous predicates are handled 25 | without problems. The same applies to multifile predicates. 26 | 27 | ?- to_simple('t1.pl','t2.pl'). 28 | 29 | % input: file: t1.pl 30 | 31 | a(1). 32 | 33 | b(X):-a(X). 34 | 35 | a(2). 36 | 37 | 38 | % output: file: t2.pl 39 | 40 | ':-'(a(1),true). 41 | ':-'(a(2),true). 42 | ':-'(b(_x2647),a(_x2647)). 43 | 44 | */ 45 | -------------------------------------------------------------------------------- /progs/ltak.pl: -------------------------------------------------------------------------------- 1 | :-write('Program: ltak.pl'),nl. 2 | :-write('Author: Paul Tarau'),nl. 3 | :-write('tak program with constant acces and create-time lemmas'),nl. 4 | 5 | tak(X,Y,Z,A) :- X =< Y, !, Z = A. 6 | tak(X,Y,Z,A) :- 7 | X1 is X - 1, 8 | Y1 is Y - 1, 9 | Z1 is Z - 1, 10 | ltak(X1,Y,Z,A1), 11 | ltak(Y1,Z,X,A2), 12 | ltak(Z1,X,Y,A3), 13 | ltak(A1,A2,A3,A). 14 | 15 | ltak(X,Y,Z,A):- 16 | tak_encode(X,Y,XY), 17 | tak_lemma(XY,Z,tak(X,Y,Z,A),A). 18 | 19 | tak_encode(Y,Z,Key):-Key is Y<<16 \/ Z. 20 | tak_decode(Key,Y,Z):-Y is Key>>16, Z is Key <<17>>17 . 21 | 22 | %optimized lemma --> O (instantiated executing G) 23 | tak_lemma(P,I,_,O):-val(P,I,X),!,X=O. 24 | tak_lemma(P,I,G,O):-G,!,def(P,I,O). 25 | 26 | go:- statistics(runtime,_), 27 | tak(24,16,8,X), 28 | statistics(runtime,[_,T]),statistics, 29 | write('BMARK_ltak:'=[time=T,tak=X]), nl. 30 | 31 | -------------------------------------------------------------------------------- /progs/lmoney.pl: -------------------------------------------------------------------------------- 1 | % quick SEND+MORE=MONEY with linear implication 2 | 3 | :-dynamic digit/1. 4 | 5 | go:- 6 | time(_), 7 | digit(0)-:digit(1)-:digit(2)-:digit(3)-:digit(4)-: 8 | digit(5)-:digit(6)-:digit(7)-:digit(8)-:digit(9)-: puzzle(Show), 9 | time(T), 10 | Show, 11 | write(time(T)),nl. 12 | 13 | 14 | puzzle(show(S,E,N,D,M,O,R,Y)):- 15 | digit(D),digit(E),add_digit(D,E,Y, 0,C1),digit(Y), 16 | digit(N),digit(R),add_digit(N,R,E, C1,C2), 17 | digit(O), add_digit(E,O,N, C2,C3), 18 | digit(S),S>0, 19 | digit(M),M>0, add_digit(S,M,O, C3, 20 | M). 21 | 22 | add_digit(D1,D2,Res,C1,C2):- 23 | S is D1+D2+C1, 24 | Res is S mod 10, 25 | C2 is S // 10. 26 | 27 | show(S,E,N,D,M,O,R,Y):- 28 | write(' '), 29 | write([S,E,N,D]), 30 | write(+),nl, 31 | write(' '), 32 | write([M,O,R,E]), 33 | write(=),nl, 34 | write([M,O,N,E,Y]),nl, 35 | fail 36 | ; nl. 37 | 38 | time(T):-statistics(runtime,[_,T]). 39 | -------------------------------------------------------------------------------- /progs/lmap.pl: -------------------------------------------------------------------------------- 1 | go:- go(Xs),write(Xs),nl. 2 | 3 | color_map([]). 4 | color_map([R|Rs]) :- 5 | color(red)-: 6 | color(yellow)-: 7 | color(blue)-: 8 | color(white)-: 9 | color_region(R), 10 | color_map(Rs). 11 | 12 | color_region(region(Color,Neighbors)):- 13 | color(Color), 14 | color_neighbors(Neighbors). 15 | 16 | 17 | color_neighbors([]). 18 | color_neighbors([X|Xs]) :- 19 | color(X), 20 | color(X)-:color_neighbors(Xs). 21 | 22 | 23 | go([france=F,belgium=B,holland=H,germany=G,luxembourg=L, 24 | italy=I,switzerland=S,austria=A]):- 25 | Rs= 26 | [ 27 | region(F,[I,S,B,G,L]), 28 | region(B,[F,H,L,G]), 29 | region(H,[B,G]), 30 | region(G,[F,A,S,H,B,L]), 31 | region(L,[F,B,G]), 32 | region(I,[F,A,S]), 33 | region(S,[F,I,A,G]), 34 | region(A,[I,S,G]) 35 | ], 36 | color_map(Rs). 37 | 38 | 39 | % Linear logic version of map coloring prog. 14.4 from Sterling & Shapiro 40 | -------------------------------------------------------------------------------- /library/bpxref.pl: -------------------------------------------------------------------------------- 1 | % xref based program checking tools 2 | 3 | :-[library(xref2latex)]. 4 | 5 | % tests on BinProlog, retunrns full latex document 6 | bptest:-xref(wam). 7 | 8 | % tests itself 9 | selftest:-xref(bpxref). 10 | 11 | % filters out unwanted predicates 12 | 13 | non_trivial(FN):-FN \== true/0,FN\==(!)/0. % FN\==fail/0, 14 | 15 | %filter(FN):-non_trivial(FN). 16 | %filter(F/N):-functor(P,F,N), \+ is_builtin(P). 17 | %filter(F/N):-non_trivial(F/N), functor(P,F,N), is_builtin(P). 18 | 19 | filter(F/N):-has_info(F/N),non_trivial(F/N). 20 | 21 | % adds some predicates that the system cannot see 22 | generator(F/N):- 23 | db_clause(wam,bu0(P1,_,_,_),_), 24 | functor(P1,F,N1), 25 | N is N1-1. 26 | 27 | go:- 28 | dynbbgc, 29 | create_engine(2000,1000,1000,E), 30 | load_engine(E,xref(wam,0),_), % \input this into ../doc/art.tex 31 | ask_engine(E,_), 32 | destroy_engine(E), 33 | system('mv wam.tex ../doc/preds.tex'). 34 | 35 | -------------------------------------------------------------------------------- /src/OLD/makenew2: -------------------------------------------------------------------------------- 1 | # generates BinProlog 2 | 3 | mv -f wam.c wam_c.txt 4 | mv -f wam.h wam_h.txt 5 | mv -f binpro.c binpro_c.txt 6 | mv -f binpro.h binpro_h.txt 7 | cc -DAIX -o ru *.c -lm 8 | ru remake 9 | ru "and(cboot,halt)" 10 | mv -f stub.c stub.txt 11 | cc -DAIX -DTHREADS=1 -g -O4 -c *.c -lm -lpthread 12 | 13 | # makes static library in ../lib 14 | cc -g -O4 -o bp *.o -lm -lpthread 15 | cc -DAIX -DTHREADS=1 -DEXTERNAL_TSTORE -g -O4 -c builtins.c c.c -lm -lpthread 16 | ar -q libbps.a *.o 17 | mv -f bp ../bin 18 | mv -f libbps.a ../lib 19 | 20 | # makes dynamic lib in ../lib - AIX specific 21 | 22 | rm -f *.o 23 | cc -g -O4 -brtl -G -DEXTERNAL_TSTORE -DAIX -DTHREADS=1 -c -lm -lpthread *.c 24 | ar -q libbp.so *.o 25 | cp libbp.so ../lib 26 | cp c_defs.h global.h ../lib 27 | 28 | # clean up 29 | mv -f stub.txt stub.c 30 | rm -f wam_c.txt 31 | rm -f wam_h.txt 32 | rm -f binpro_c.txt 33 | rm -f binpro_h.txt 34 | rm -f *.o 35 | rm -f *.a 36 | rm -f *.so 37 | 38 | -------------------------------------------------------------------------------- /progs/gc.pl: -------------------------------------------------------------------------------- 1 | go:-go(1000000),go1(1000000),go2(10000). 2 | 3 | go(N):-loop(N),statistics. 4 | 5 | loop(0). 6 | loop(N):-N>0,N1 is N-1,make_garbage(N1,_),loop(N1). 7 | 8 | make_garbage(X,g(X)). 9 | 10 | go1(N):-loop1(N,dummy),statistics. 11 | 12 | loop1(0,_). 13 | loop1(N,X):-N>0,N1 is N-1,make_garbage(X,X1),loop1(N1,X1). 14 | 15 | go2(N) :- 16 | mkfreelist(N,L), 17 | ctime(A), 18 | (mmc(N,L), fail ; true), 19 | ctime(B), 20 | X is B - A, 21 | write(time(X)), nl, fail 22 | ; statistics. 23 | 24 | mmc(N,L) :- 25 | N > 0, 26 | M is N - 1, 27 | mmc(M,L), 28 | !. 29 | mmc(_,L) :- 30 | mkground(L). 31 | 32 | mkfreelist(N,L) :- 33 | (N = 0 -> 34 | L = [] 35 | ; 36 | NN is N - 1, 37 | L = [_|R], 38 | mkfreelist(NN,R) 39 | ). 40 | 41 | mkground([]). 42 | mkground([a|R]) :- 43 | mkground(R). 44 | 45 | -------------------------------------------------------------------------------- /progs/money.pl: -------------------------------------------------------------------------------- 1 | go:- 2 | time(_), 3 | puzzle(Show,[0,1,2,3,4,5,6,7,8,9],_), 4 | time(T), 5 | Show, 6 | write('BMARK_money:'=time(T)),nl. 7 | 8 | 9 | puzzle(show(S,E,N,D,M,O,R,Y))--> 10 | add_digits(D,E,Y, 0,R1), 11 | add_digits(N,R,E, R1,R2), 12 | add_digits(E,O,N, R2,R3), 13 | add_digits(S,M,O, R3, 14 | M), 15 | {S>0,M>0}. 16 | 17 | digit(X)-->{integer(X)},!. 18 | digit(X)-->select(X). 19 | 20 | add_digits(C1,C2,Res,R1,R2)--> 21 | digit(C1), 22 | digit(C2), 23 | digit(Res), 24 | {add_with_carry(C1,C2,R1,Res,R2)}. 25 | 26 | add_with_carry(C1,C2,R1,Res,R2):- 27 | S is C1+C2+R1, 28 | Res is S mod 10, 29 | R2 is S // 10. 30 | 31 | select(X,[X|Xs],Xs). 32 | select(X,[Y|Xs],[Y|Ys]):-select(X,Xs,Ys). 33 | 34 | show(S,E,N,D,M,O,R,Y):- 35 | write(' '), 36 | write([S,E,N,D]), 37 | write(+),nl, 38 | write(' '), 39 | write([M,O,R,E]), 40 | write(=),nl, 41 | write([M,O,N,E,Y]),nl, 42 | fail 43 | ; nl. 44 | 45 | time(T):-statistics(runtime,[_,T]). 46 | -------------------------------------------------------------------------------- /progs/move.pl: -------------------------------------------------------------------------------- 1 | /* 2 | % wrap_thread(Goal):-capture_cont_for(Goal). 3 | wrap_thread(Goal,LeftOver):-left_over_cont(LeftOver)-::capture_cont_for(Goal). 4 | 5 | move:- 6 | % assumes wrap_thread(...) has been executed before 7 | call_with_cont(run_and_return). 8 | 9 | run_and_return(Gs):- 10 | println(Gs), 11 | the( 12 | from_to(Gs,Cont), 13 | wrap_thread(Gs,Cont), % this send left over 14 | Result 15 | ), 16 | println(Result), 17 | eq(the(from_to(Gs,NewGs)),Result), 18 | ( var(NewGs)->true 19 | ; NewGs 20 | ). 21 | 22 | return:- 23 | call_with_cont(collect_left_over), 24 | true. % should be here: simplifies cont. cutting algo 25 | 26 | collect_left_over(Gs):- assumed(left_over_cont(Gs)). 27 | */ 28 | 29 | % should send canonical terms over sockets !!! 30 | 31 | go:-wrap_thread(go1). 32 | 33 | go1:- 34 | eq(X,1), 35 | there,move, 36 | member(Y,[X,2,X]),println(remote_values(X,Y)),return, 37 | println(back(X,Y)). 38 | 39 | 40 | go2:- 41 | there,move,println(there),return. 42 | -------------------------------------------------------------------------------- /doc/.log: -------------------------------------------------------------------------------- 1 | This is pdfeTeX, Version 3.141592-1.20a-2.2 (MiKTeX 2.4) (preloaded format=latex 2004.10.3) 25 SEP 2005 22:34 2 | entering extended mode 3 | **.tex 4 | (C:\texmf\tex\latex\tools\.tex 5 | LaTeX2e <2003/12/01> 6 | Babel and hyphenation patterns for english, french, german, ngerman, du 7 | mylang, nohyphenation, loaded. 8 | File ignored) 9 | * 10 | ! Emergency stop. 11 | <*> .tex 12 | 13 | End of file on the terminal! 14 | 15 | 16 | Here is how much of TeX's memory you used: 17 | 7 strings out of 95518 18 | 102 string characters out of 1189590 19 | 44801 words of memory out of 1048577 20 | 3206 multiletter control sequences out of 35000 21 | 3640 words of font info for 14 fonts, out of 500000 for 1000 22 | 14 hyphenation exceptions out of 607 23 | 5i,0n,1p,85b,8s stack positions out of 1500i,500n,5000p,200000b,32768s 24 | 0 PDF objects out of 300000 25 | 0 named destinations out of 300000 26 | 1 words of extra memory for PDF output out of 65536 27 | No pages of output. 28 | -------------------------------------------------------------------------------- /library/coord.pl: -------------------------------------------------------------------------------- 1 | server:- 2 | bg(run_server). 3 | 4 | cons:- 5 | bg(start_consumer), 6 | wait_for_consumer(X), 7 | println(redy_to_use=X). 8 | 9 | start_consumer:- 10 | remote_run(consumer(X)), 11 | println(received=X), 12 | db_assert(data,range(X)). 13 | 14 | wait_for_consumer(X):- 15 | for(_,1,20), 16 | sleep(1), 17 | db_asserted(data,range(X)), 18 | !. 19 | wait_for_consumer(no_range_found). 20 | 21 | 22 | consumer(R):- 23 | wait_for(in_range(ship,R),R<10), 24 | println(consumed(R)). 25 | 26 | prod:- 27 | Bad=11, 28 | remote_run(producer(Bad)), 29 | println(produced=Bad), 30 | sleep(3), 31 | Good=9, 32 | remote_run(producer(Good)). 33 | 34 | producer(X):- 35 | notify_about(in_range(ship,X)), 36 | println(produced(X)). 37 | 38 | /* 39 | server window 40 | ?-server. 41 | 42 | consumer window 43 | ?- cons. 44 | got = 9 45 | yes 46 | 47 | producer window 48 | 49 | ?- prod. 50 | produced = 11 51 | produced = 9 52 | yes 53 | */ 54 | -------------------------------------------------------------------------------- /progs/bm_tetris.pl: -------------------------------------------------------------------------------- 1 | bm:-random_seed(13),go,show_game. 2 | 3 | :-[tetris]. 4 | 5 | scr_init(N):- 6 | max(MaxL,MaxC), 7 | [Board]="#", 8 | (for(L,6,MaxL),scr_send(p(L,MaxC),Board),fail; true), 9 | (for(C,0,MaxC),scr_send(p(MaxL,C),Board),fail; true), 10 | N=0, 11 | scr_score(N), 12 | !. 13 | 14 | scr_end :- 15 | println(end), 16 | abort. 17 | 18 | scr_send(p(L0,C0),Char):-let(L0,C0,Char). 19 | 20 | scr_score(Score):- 21 | show_game, 22 | println('Score:'(Score)), 23 | nl. 24 | 25 | % show_game. 26 | 27 | show_game_:- 28 | max(MaxL,MaxC), 29 | for(L,1,MaxL), 30 | nl, 31 | for(C,1,MaxC), 32 | val(L,C,Char), 33 | put(Char), 34 | fail. 35 | show_game_:- 36 | nl,nl. 37 | 38 | show_game. 39 | 40 | scr_stat(Val):- 41 | statistics(global_stack,HStat), 42 | show_game, 43 | % println([energie(Val),heap(HStat)]), 44 | nl. 45 | 46 | % reading a direction: default falling direction 47 | scr_dir(1). 48 | -------------------------------------------------------------------------------- /progs/disj.pl: -------------------------------------------------------------------------------- 1 | :-module(prolog). 2 | 3 | disj(A,B,NewAB):- 4 | avoid_replacing_cut((A;B)),!, 5 | r_disj0(A,B,NewAB). 6 | disj(A,B,Head):- 7 | make_new_head(or(A,B),Head), 8 | r_disj((A;B),Ns,[]), 9 | delay_disj(Head,Ns). 10 | 11 | 12 | delay_disj(Head,Ns):- 13 | member(N,Ns), 14 | compile_later(Head,N), 15 | fail. 16 | delay_disj(_,_). 17 | 18 | r_disj0(If,C,if(NewA,NewB,NewC)):-nonvar(If),If=(A->B),!, 19 | repl_body(A,NewA), 20 | repl_body(B,NewB), 21 | repl_body(C,NewC). 22 | r_disj0(A,B,or(NewA,NewB)):- 23 | repl_body(A,NewA), 24 | repl_body(B,NewB). 25 | 26 | 27 | r_disj((A;B))-->!, 28 | r_disj(A), 29 | r_disj(B). 30 | r_disj((A->B))-->!, 31 | { repl_body(A,NA), 32 | repl_macro('!',CUT), 33 | repl_body(B,NB) 34 | }, 35 | [(NA,CUT,NB)]. 36 | r_disj(A)--> 37 | {repl_body(A,NA)}, 38 | [NA]. 39 | 40 | 41 | 42 | :-module(user). 43 | 44 | go:-X=(m;(n1;n2);p,q),'prolog:disj'(X,(a->b;c,X;d),R), 45 | pp_clause(R),nl, 46 | listing. 47 | -------------------------------------------------------------------------------- /progs/tetris_trace.pl: -------------------------------------------------------------------------------- 1 | scr_init(N):- 2 | dims(MaxL,MaxC,_), 3 | [Board]="#", 4 | (for(L,6,MaxL),scr_send(p(L,MaxC),Board),fail; true), 5 | (for(C,0,MaxC),scr_send(p(MaxL,C),Board),fail; true), 6 | N=0, 7 | scr_score(N), 8 | !. 9 | 10 | scr_end :- 11 | println(end), 12 | abort. 13 | 14 | scr_send(p(L0,C0),Char):-let(L0,C0,Char). 15 | 16 | scr_score(Score):- 17 | show_game, 18 | println('Score:'(Score)), 19 | nl. 20 | 21 | show_game:- 22 | dims(MaxL,MaxC,_), 23 | for(L,0,MaxL), 24 | nl, 25 | for(C,0,MaxC), 26 | get_val(L,C,Char), 27 | put(Char), 28 | fail. 29 | show_game:- 30 | sleep(1), 31 | nl,nl. 32 | 33 | get_val(L,C,Char):- val(L,C,X),!,Char=X. 34 | get_val(_,_,Space):- [Space]=" ". 35 | 36 | scr_stat(Val):- 37 | statistics(global_stack,HStat), 38 | show_game, 39 | println([energie(Val),heap(HStat)]), 40 | nl. 41 | 42 | % reading a direction: default falling direction 43 | scr_dir(1). 44 | 45 | -------------------------------------------------------------------------------- /progs/setarg_dcg.pl: -------------------------------------------------------------------------------- 1 | 2 | % DCGs with no preprocessor 3 | % expects: Sicstus-style backtrackable setarg + 4 | % BinProlog's backtrackable global variables 5 | 6 | % tools 7 | 8 | begin_dcg(Name,Xs):-lval(dcg,Name,Xs-Xs). 9 | 10 | end_dcg(Name,Xs):-lval(dcg,Name,Xs-[]). 11 | 12 | w(Word,Name):- 13 | lval(dcg,Name,State), 14 | State=_-[Word|Xs2], 15 | setarg(2,State,Xs2). 16 | 17 | begin_dcg(Xs):-begin_dcg(default,Xs). 18 | end_dcg(Xs):-end_dcg(default,Xs). 19 | w(Word):-w(Word,default). 20 | 21 | % grammar 22 | x:-ng,v. 23 | 24 | ng:-a,n. 25 | 26 | a:-w(the). 27 | a:-w(a). 28 | 29 | n:-w(cat). 30 | n:-w(dog). 31 | 32 | v:-w(walks). 33 | v:-w(sleeps). 34 | 35 | % test 36 | go:-begin_dcg(Xs),x,end_dcg(Ys),write(Ys),nl,fail. 37 | 38 | p:-[setarg_dcg]. 39 | 40 | /* 41 | 42 | ?- [setarg_dcg]. 43 | compiling(to(mem),myprogs/setarg_dcg.pl,...) 44 | compile_time(134) 45 | ?- go. 46 | [the,cat,walks] 47 | [the,cat,sleeps] 48 | [the,dog,walks] 49 | [the,dog,sleeps] 50 | [a,cat,walks] 51 | [a,cat,sleeps] 52 | [a,dog,walks] 53 | [a,dog,sleeps] 54 | 55 | */ 56 | -------------------------------------------------------------------------------- /progs/eassert.pl: -------------------------------------------------------------------------------- 1 | % emulating assert with backtrackable assumptions 2 | % on top of an extra engine in BinProlog 4.xx 3 | 4 | new_engine(E):- 5 | engine_params(H,S,T), 6 | new_engine(H,S,T,make_worker(X),X,E). 7 | 8 | new_engine(H,S,T,Goal,Answer,Handle):- 9 | create_engine(H,S,T,Handle), 10 | load_engine(Handle,Goal,Answer). 11 | 12 | send_engine(E,Goal):-assumel(todo(Goal)),ask_engine(E,_). 13 | 14 | make_worker(E):-current_engine(E),worker. 15 | 16 | worker:- 17 | todo(X),X\==done, 18 | copy_term(X,G), 19 | (G->true;true), 20 | co_worker. 21 | 22 | co_worker. 23 | co_worker:-worker. 24 | 25 | eassert(E,A):-send_engine(E,assumei(A)). 26 | 27 | % query 28 | 29 | go:- 30 | engine_params(200,100,100)=> 31 | new_engine(E), 32 | send_engine(E,ttyprint(hello)), 33 | eassert(E,a(1)), 34 | eassert(E,a(2)), 35 | listing, 36 | send_engine(E,done), 37 | destroy_engine(E). 38 | 39 | /* 40 | ?-go. 41 | 42 | hello 43 | % assumed a/1: 44 | a(1). 45 | a(2). 46 | 47 | % assumed todo/1: 48 | 49 | % assumed engine_params/3: 50 | */ 51 | -------------------------------------------------------------------------------- /library/xref2txt.pl: -------------------------------------------------------------------------------- 1 | :-[library(xref)]. 2 | 3 | plain_xref(File):- 4 | plain_xref_checks(File), 5 | plain_list_call_graph(File). 6 | 7 | 8 | plain_list_call_graph(File):- 9 | db_proc(File,FN), 10 | nl,write('*** PREDICATE ***: '),write(FN), 11 | nl,nl, 12 | write('CALLS: '), 13 | forall(calles_to(File,FN,Callee),(write(Callee),write(' '))), 14 | nl,nl, 15 | write('CALLED FROM: '), 16 | forall(called_from(File,FN,Caller),(write(Caller),write(' '))), 17 | nl,nl,nl, 18 | fail 19 | ; nl. 20 | 21 | 22 | plain_xref_checks(File):- 23 | plain_xref_checks(File, 24 | write('UNDEFINED:'), 25 | write('UNUSED (statically unreachable from definitions)') 26 | ), 27 | !. 28 | 29 | 30 | plain_undef_check(DB):- 31 | undefined(DB,F/N), 32 | write(F/N),nl, 33 | fail 34 | ; nl. 35 | 36 | 37 | plain_check_unused(DB):- 38 | unused(DB,F/N), 39 | write(F/N),nl, 40 | fail 41 | ; nl. 42 | 43 | plain_xref_checks(File,A1,A2):- 44 | init_xref(File), 45 | nl,A1,nl,nl, 46 | plain_undef_check(File), 47 | nl,A2,nl,nl, 48 | plain_check_unused(File). 49 | 50 | -------------------------------------------------------------------------------- /progs/netscale.pl: -------------------------------------------------------------------------------- 1 | /* run this on the server side */ 2 | light_server:- 3 | heap(500)=>trail(100)=>stack(100)=>trust. 4 | 5 | jserver:- 6 | run_server(7001,none,400,100,100). 7 | 8 | one_task(Id,I,IdleTime):- 9 | println(task_for(Id,I)), 10 | sleep(IdleTime). 11 | 12 | one_client(Id,Times,IdleTime):- 13 | for(I,1,Times), 14 | println(start_task(Id,I)), 15 | remote_run(one_task(Id,I,IdleTime)), 16 | println(end_task(Id,I)), 17 | sleep(IdleTime), 18 | fail. 19 | one_client(Id,_,_):- 20 | remote_run(println(finished(Id))), 21 | halt. 22 | 23 | /* run this, with various parameters on a W2000 or XP system */ 24 | rruns(Clients,Times,IdleTime):- 25 | for(I,1,Clients), 26 | swrite(one_client(I,Times,IdleTime),Goal), 27 | make_cmd(['START bp netscale ',Goal],Cmd), 28 | println(Cmd), 29 | bg(system(Cmd)), 30 | sleep(IdleTime), 31 | fail 32 | ; 33 | println(started(all)). 34 | 35 | /* example of small test which works fine */ 36 | go:- 37 | G=rruns(20,3,2), 38 | println(G), 39 | G. 40 | 41 | test:- 42 | G=rruns(3,2,1), 43 | println(G), 44 | G. 45 | -------------------------------------------------------------------------------- /progs/lfibo.pl: -------------------------------------------------------------------------------- 1 | :-write('Program: lfibo.pl'),nl. 2 | :-write('Author: Paul Tarau'),nl. 3 | :-write('fibonacci(40) program with constant time lemmas'),nl. 4 | :-write('executed 10000 times'),nl. 5 | 6 | go:- 7 | I=10000,N=40, 8 | statistics(runtime,_), 9 | statistics(global_stack,[H1,_]), 10 | statistics(trail,[TR1,_]), 11 | f_iter(I,N,R), 12 | statistics(runtime,[_,T]), 13 | statistics(global_stack,[H2,_]), 14 | statistics(trail,[TR2,_]), 15 | H is H2-H1,TR is TR2-TR1, 16 | bb, 17 | write([time=T,heap=H,trail=TR,fibo(N,R)]),nl. 18 | 19 | range(Min,Min,Max):-Min= --> X (P,I,O must be atomic) 36 | fibo_lemma(P,I,O):-val(P,I,X),!,X=O. 37 | fibo_lemma(P,I,O):-functor(G,P,2),arg(1,G,I),G,!, 38 | arg(2,G,O), 39 | def(P,I,O). 40 | -------------------------------------------------------------------------------- /progs/ja_primes.pl: -------------------------------------------------------------------------------- 1 | /* 2 | Elegant prime number program by Jamie Andrews 3 | posted in comp.lang.prolog on 23 Apr 1999 4 | Generates one prime at a time, on backtracking 5 | 6 | Modified by Paul Tarau - to use difference list prime queue 7 | */ 8 | 9 | primes_to(N,Ps):- 10 | this_or_later_prime(2, Xs-Xs, P), 11 | P>N, 12 | !, 13 | append(Xs,[],Ps). 14 | 15 | prime(P) :- 16 | this_or_later_prime(2, Xs-Xs, P). 17 | 18 | this_or_later_prime(P, _, P). 19 | this_or_later_prime(This, Previous_primes, P) :- 20 | N is This+1, 21 | % append newest prime at end because earlier primes will 22 | % detect composite numbers faster 23 | enq(This,Previous_primes,Previous_primes2), 24 | try_prime(N, Previous_primes2, P). 25 | 26 | enq(X,Xs-[X|Ys],Xs-Ys). 27 | 28 | try_prime(N, Previous, P) :- 29 | divisible_by_some(N, Previous), 30 | !, 31 | N1 is N+1, 32 | try_prime(N1, Previous, P). 33 | try_prime(N, Previous, P) :- 34 | this_or_later_prime(N, Previous, P). 35 | 36 | divisible_by_some(N, [P|_]-_) :- 37 | nonvar(P), 38 | 0 is N mod P. 39 | divisible_by_some(N, [_|Ps]-Qs) :- 40 | nonvar(Ps), 41 | divisible_by_some(N, Ps-Qs). 42 | -------------------------------------------------------------------------------- /progs/bmark.pl: -------------------------------------------------------------------------------- 1 | timer(T):-statistics(runtime,[T,_]). 2 | 3 | test_times(It,Goal):- range(_,1,It),Goal,fail. 4 | test_times(_,_). 5 | 6 | dummy. 7 | dummy(_). 8 | dummy(_,_). 9 | dummy(_,_,_). 10 | dummy(_,_,_,_). 11 | dummy(_,_,_,_,_). 12 | 13 | make_dummy(Goal,Dummy):-Goal=..[_|Xs],Dummy=..[dummy|Xs]. 14 | 15 | range(Min,Min,Max):-Min= 3 | 4 | #ifdef TSTORE 5 | 6 | #if !defined(EXTERNAL_TSTORE) 7 | #include "term.h" 8 | #include "termStore.h" 9 | 10 | /* 11 | TODO: provide here implementations for the prototypes 12 | described in termStore.h 13 | 14 | THE folowing provide STUBS for trying out the API - to 15 | be progressively replaced with the real thing !!! 16 | */ 17 | 18 | static Term theTerm=NULL; 19 | 20 | void pushTerm(Term key, Term value){theTerm=value;} 21 | void putTerm(Term key, Term value){theTerm=value;} 22 | ulong newIterator(Term key){return ZERO;} 23 | void closeIterator(ulong iterator) {} 24 | BYTE hasTerms(Term key) {return NULL!=theTerm;} 25 | Term getNextTerm(ulong iterator) {return theTerm;} 26 | void removeCurrentTerm(ulong iterator) {theTerm=NULL;} 27 | void updateCurrentTerm(ulong iterator,Term value) {theTerm=value;} 28 | void deleteAllTerms(Term key) {theTerm=NULL;} 29 | bp_long countTerms(Term key) {return 1;} 30 | ulong newKeyIterator(){return ZERO;} 31 | Term processTerm(bp_long OpCode,Term arg){return arg;} 32 | char *newTermString(char *s) {return strdup(s);} 33 | void freeTermString(char *s) {free(s);} 34 | #endif 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /progs/igmoney.pl: -------------------------------------------------------------------------------- 1 | % quick SEND+MORE=MONEY with invisible grammars 2 | 3 | go:- 4 | time(_), 5 | dcg_def([0,1,2,3,4,5,6,7,8,9]), 6 | puzzle(Show), 7 | time(T), 8 | Show, 9 | write(time(T)),nl. 10 | 11 | 12 | puzzle(show(S,E,N,D,M,O,R,Y)):- 13 | digit(D),digit(E),add_digit(D,E,Y, 0,C1),digit(Y), 14 | digit(N),digit(R),add_digit(N,R,E, C1,C2), 15 | digit(O), add_digit(E,O,N, C2,C3), 16 | digit(S),S>0, 17 | digit(M),M>0, add_digit(S,M,O, C3, 18 | M). 19 | 20 | digit(D):-dcg_val(Xs),select(D,Xs,Ys),dcg_def(Ys). 21 | 22 | select(X,[X|Xs],Xs). 23 | select(X,[Y|Xs],[Y|Ys]):-select(X,Xs,Ys). 24 | 25 | add_digit(D1,D2,Res,C1,C2):- 26 | S is D1+D2+C1, 27 | Res is S mod 10, 28 | C2 is S // 10. 29 | 30 | show(S,E,N,D,M,O,R,Y):- 31 | write(' '), 32 | write([S,E,N,D]), 33 | write(+),nl, 34 | write(' '), 35 | write([M,O,R,E]), 36 | write(=),nl, 37 | write([M,O,N,E,Y]),nl, 38 | fail 39 | ; nl. 40 | 41 | time(T):-statistics(runtime,[_,T]). 42 | 43 | /* 44 | 45 | % in BinProlog 3.30 46 | 47 | ?- go. 48 | [9,5,6,7]+ 49 | [1,0,8,5]= 50 | [1,0,6,5,2] 51 | 52 | time(140) <= it seems faster than with the best FD constraint solvers!!! 53 | 54 | */ 55 | -------------------------------------------------------------------------------- /progs/lknight.pl: -------------------------------------------------------------------------------- 1 | p:-[lknight]. 2 | 3 | go:-go(5). 4 | 5 | go(N):- 6 | time(_),make_board(N,Board,NbMoves), 7 | knight(NbMoves,1,1,Board),!, 8 | time(T), 9 | write(time=T),nl,statistics,show(N,Board). 10 | 11 | make_board(N,Board,M):- 12 | length(L,N), 13 | findall(L,nth_member(_,L,_),Board), 14 | M is N*N. 15 | 16 | val(I,J,V,Board):-nth_member(L,Board,I),nth_member(V,L,J),!. 17 | 18 | knight(0,_,_,_) :- !. 19 | knight(K,A,B,Board) :- 20 | K1 is K-1, 21 | val(A,B,K,Board), 22 | move(Dx,Dy), 23 | step(K1,A,B,Dx,Dy,Board). 24 | 25 | step(K1,A,B,Dx,Dy,Board):- 26 | C is A + Dx, 27 | D is B + Dy, 28 | knight(K1,C,D,Board). 29 | 30 | show(N,Board):- 31 | nth_member(L,Board,_I),nth_member(V,L,J), 32 | write(' '),X is 1-V // 10, tab(X),write(V), 33 | (J=N->nl;true), 34 | fail. 35 | show(_):-nl. 36 | 37 | move( 2, 1). 38 | move( 2,-1). 39 | move(-2, 1). 40 | move(-2,-1). 41 | move( 1, 2). 42 | move(-1, 2). 43 | move( 1,-2). 44 | move(-1,-2). 45 | 46 | /* % now already in BinProlog 47 | nth_member(X,Xs,N):-member_i(X,Xs,1,N). 48 | 49 | member_i(X,[X|_],N,N). 50 | member_i(X,[_|Xs],N1,N3):- 51 | N2 is N1+1, 52 | member_i(X,Xs,N2,N3). 53 | */ 54 | 55 | time(T) :- statistics(runtime,[_,T]). 56 | 57 | -------------------------------------------------------------------------------- /library/monad.pl: -------------------------------------------------------------------------------- 1 | % tools 2 | 3 | id(X,X). 4 | 5 | compose(F,G,X,Z):-call(F,X,Y),call(G,Y,Z). 6 | 7 | % basic operations on the monad of Lists 8 | 9 | unitList(X,[X]). 10 | 11 | bindList([],_,[]). 12 | bindList([X|Xs],K,R):- 13 | call(K,X,Ys), 14 | bindList(Xs,K,Zs), 15 | append(Ys,Zs,R). 16 | 17 | % derived operations on the monad of Lists 18 | 19 | joinList(Xss,Xs) :- bindList(Xss,id,Xs). 20 | 21 | mapList(F,Xs,Ys):-bindList(Xs,compose(F,unitList),Ys). 22 | 23 | 24 | % test predicates and data 25 | 26 | filterList(P,X,Xs) :- call(P,X), !, unitList(X,Xs). 27 | filterList(_,_,[]). 28 | 29 | flip(F,X,Y):-call(F,Y,X). 30 | 31 | dupList(X,[X,X]). 32 | 33 | %pair(X,Y,R):- 34 | % unitList(X,Xs), 35 | % unitList(Y,Ys), 36 | % bindList([Xs,Ys],id,R). 37 | 38 | mapcan(F,Xs,R):-bindList(Xs,F,R). 39 | 40 | test(L,R):-bindList(L,dupList,R). 41 | test(L,R):-bindList(L,compose(joinList,compose(dupList,dupList)),R). 42 | test(L,R):-bindList(L,unitList,R). 43 | test(L,R):-joinList([L,L,L,L],R). 44 | test(L,R):-mapList(unitList,L,Xss),joinList(Xss,R). 45 | test(L,R):-mapList(filterList(>(3)),L,Xss),joinList(Xss,R). 46 | test(L,R):-mapList(+(10),L,R). 47 | test(L,R):-mapList(compose(unitList,flip(unitList)),L,R). 48 | 49 | go:-test([1,2,3,4],R),write(R),nl,fail. 50 | -------------------------------------------------------------------------------- /progs/ham.pl: -------------------------------------------------------------------------------- 1 | % benchmark by D. Diaz from the WAMCC distribution 2 | % slightly modified to remove irrelevant output by Paul tarau 3 | 4 | go:- statistics(runtime,_), 5 | ham, 6 | statistics(runtime,[_,Y]), 7 | write('Hamilton benchmark time : '), write(Y), nl. 8 | 9 | ham:-cycle_ham([a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t],_),fail. 10 | ham. 11 | 12 | 13 | cycle_ham([X|Y],[X,T|L]):- 14 | chain_ham([X|Y],[],[T|L]), 15 | edge(T,X). 16 | 17 | 18 | chain_ham([X],L,[X|L]). 19 | chain_ham([X|Y],K,L):- 20 | del(Z,Y,T), 21 | edge(X,Z), 22 | chain_ham([Z|T],[X|K],L). 23 | 24 | del(X,[X|Y],Y). 25 | del(X,[U|Y],[U|Z]):- 26 | del(X,Y,Z). 27 | 28 | edge(X,Y):- 29 | connect(X,L), 30 | el(Y,L). 31 | 32 | el(X,[X|_]). 33 | el(X,[_|L]):- 34 | el(X,L). 35 | 36 | connect(a,[b,j,k]). 37 | connect(b,[a,c,p]). 38 | connect(c,[b,d,l]). 39 | connect(d,[c,e,q]). 40 | connect(e,[d,f,m]). 41 | connect(f,[e,g,r]). 42 | connect(g,[f,h,n]). 43 | connect(h,[i,g,s]). 44 | connect(i,[j,h,o]). 45 | connect(j,[a,i,t]). 46 | connect(k,[o,l,a]). 47 | connect(l,[k,m,c]). 48 | connect(m,[l,n,e]). 49 | connect(n,[m,o,g]). 50 | connect(o,[n,k,i]). 51 | connect(p,[b,q,t]). 52 | connect(q,[p,r,d]). 53 | connect(r,[q,s,f]). 54 | connect(s,[r,t,h]). 55 | connect(t,[p,s,j]). 56 | 57 | 58 | 59 | -------------------------------------------------------------------------------- /progs/primes.pl: -------------------------------------------------------------------------------- 1 | :-write('computes primes using bboard operations for fast tabultation'),nl. 2 | 3 | max_prime(5000). 4 | 5 | go:-max_prime(Max),go(Max). 6 | 7 | cputime(T):-statistics(runtime,[_,T]). 8 | 9 | go(N):-cputime(_),primes_to(N),cputime(T),write(time=T),nl,statistics. 10 | 11 | primes_to(N):- 12 | init_primes, 13 | prime(2,N,Prime), 14 | Prime>N-100, 15 | write(Prime),nl, 16 | fail 17 | ; true. 18 | 19 | init_primes:-def(prime,limit,2),!,push(primes,2). 20 | init_primes. 21 | 22 | prime(Min,Max,P) :- 23 | range(P,Min,Max), 24 | sqr(P,Lim), 25 | \+(divisible(P,Lim)). 26 | 27 | divisible(P,Lim):- 28 | memo_prime(Lim,I), 29 | 0 is P mod I. 30 | 31 | range(Min,Min,Max):-Min=N,!,S is S1-1. 38 | 39 | memo_prime(Lim,I):-Lim>2, 40 | val(prime,limit,Old),Old>=Lim,!, 41 | stack(primes,Ps), 42 | member(I,Ps). 43 | memo_prime(Lim,I):-Lim>2, 44 | val(prime,limit,Old),Old, member(X,Xs)). 4 | 5 | % The following is an efficient implementation 6 | % of bestof/3 using the blackboard. 7 | % You add it to extra.pl and type ?-boot. to integrate it in the kernel 8 | % if you plan to use it. 9 | 10 | % true if X is an answer of Generator such that 11 | % X Rel Y for every other answer Y of Generator 12 | bestof(X,Closure,Generator):- 13 | copy_term(X,Y), 14 | Closure=..L1, 15 | det_append(L1,[X,Y],L2), 16 | Test=..L2, 17 | bestof0(X,Y,Generator,Test). 18 | 19 | bestof0(X,Y,Generator,Test):- 20 | inc_level(bestof,Level), 21 | Generator, 22 | update_bestof(Level,X,Y,Test), 23 | fail. 24 | bestof0(X,_,_,_):- 25 | dec_level(bestof,Level), 26 | val(bestof,Level,X), 27 | rm(bestof,Level). 28 | 29 | % uses Rel to compare New with so far the best answer 30 | update_bestof(Level,New,Old,Test):- 31 | val(bestof,Level,Old),!, 32 | Test, 33 | bb_set(bestof,Level,New). 34 | update_bestof(Level,New,_,_):- 35 | bb_let(bestof,Level,New). 36 | 37 | % ensure correct implementation of embedded calls to bestof/3 38 | inc_level(Obj,X1):-val(Obj,Obj,X),!,X1 is X+1,bb_set(Obj,Obj,X1). 39 | inc_level(Obj,1):-bb_def(Obj,Obj,1). 40 | 41 | dec_level(Obj,X):-val(Obj,Obj,X),X>0,X1 is X-1,bb_set(Obj,Obj,X1). 42 | 43 | -------------------------------------------------------------------------------- /progs/lq8.pl: -------------------------------------------------------------------------------- 1 | make_board([l1,l2,l3,l4,l5,l6,l7,l8],[c1,c2,c3,c4,c5,c6,c7,c8]):- 2 | lval(c1,on,[A8 -B1 ,A9 -B2 ,A10-B3 ,A11-B4 ,A12-B5 ,A13-B6 ,A14-B7 ,A15-B8 ]), 3 | lval(c2,on,[A7 -B2 ,A8 -B3 ,A9 -B4 ,A10-B5 ,A11-B6 ,A12-B7 ,A13-B8 ,A14-B9 ]), 4 | lval(c3,on,[A6 -B3 ,A7 -B4 ,A8 -B5 ,A9 -B6 ,A10-B7 ,A11-B8 ,A12-B9 ,A13-B10]), 5 | lval(c4,on,[A5 -B4 ,A6 -B5 ,A7 -B6 ,A8 -B7 ,A9 -B8 ,A10-B9 ,A11-B10,A12-B11]), 6 | lval(c5,on,[A4 -B5 ,A5 -B6 ,A6 -B7 ,A7 -B8 ,A8 -B9 ,A9 -B10,A10-B11,A11-B12]), 7 | lval(c6,on,[A3 -B6 ,A4 -B7 ,A5 -B8 ,A6 -B9 ,A7 -B10,A8 -B11,A9 -B12,A10-B13]), 8 | lval(c7,on,[A2 -B7 ,A3 -B8 ,A4 -B9 ,A5 -B10,A6 -B11,A7 -B12,A8 -B13,A9 -B14]), 9 | lval(c8,on,[A1 -B8 ,A2 -B9 ,A3 -B10,A4 -B11,A5 -B12,A6 -B13,A7 -B14,A8 -B15]). 10 | 11 | queens(LCs):- 12 | make_board(Ls,Cs), 13 | queens(Ls,Cs,LCs). 14 | 15 | queens([],[],[]). 16 | queens([L|Ls],OldCs,[L-C|LCs]):- 17 | select(C,OldCs,NewCs), 18 | lval(C,on,Diags), 19 | mark(Ls,L,Diags), 20 | queens(Ls,NewCs,LCs). 21 | 22 | select(X,[X|Xs],Xs). 23 | select(X,[Y|Xs],[Y|Ys]):-select(X,Xs,Ys). 24 | 25 | mark([],L,[L-L|_]). 26 | mark([_|Ls],L,[_|Diags]):-mark(Ls,L,Diags). 27 | 28 | test(T):- 29 | statistics(runtime,_), 30 | ( 31 | queens(Qs), 32 | % write(Qs),nl, 33 | fail 34 | ; 35 | true 36 | ), 37 | statistics(runtime,[_,T]). 38 | 39 | go:-test(T),write(T),nl. 40 | 41 | -------------------------------------------------------------------------------- /progs/qsort.pl: -------------------------------------------------------------------------------- 1 | p:-[qsort]. 2 | 3 | go:-go('BMARK_qsort:'). 4 | 5 | go(Mes):- 6 | write('use bp -h4000 -t1000 -s1000'),nl, 7 | list(L),augment(L,L3),augment(L3,L9),augment(L9,L27), 8 | statistics(global_stack,[H1,_]), 9 | statistics(trail,[TR1,_]), 10 | time(_), 11 | qsort(L27,_Sorted,[]), 12 | time(T), 13 | statistics(global_stack,[H2,_]),H is H2-H1, 14 | statistics(trail,[TR2,_]),TR is TR2-TR1, 15 | write(Mes=[time(T),heap(H),trail(TR)]),nl. 16 | 17 | go1:-L=[3,4,1,2,1,2,5,1,3,0,9,7],qsort(L,R,[]),write(L-R),nl. 18 | 19 | on(X,[X|_]). 20 | on(X,[_|Xs]):-on(X,Xs). 21 | 22 | augment(L,R):-findall(X,(on(Y,L),(X is Y+1;Y=X;X is Y-1)),R). 23 | 24 | list([27,74,17,33,94,18,46,83,65, 2, 25 | 32,53,28,85,99,47,28,82, 6,11, 26 | 55,29,39,81,90,37,10, 0,66,51, 27 | 7,21,85,27,31,63,75, 4,95,99, 28 | 11,28,61,74,18,92,40,53,59, 8]). 29 | 30 | qsort([],S,S). 31 | qsort([Y|L],S1,S3) :- partition(L,Y,S1,S3). 32 | 33 | partition([],Y,[Y|S],S). 34 | partition([X|L],Y,S1,S3) :- 35 | partition1(L,Y,L1,L2,X), 36 | qsort(L1,S1,[Y|S2]), 37 | qsort(L2,S2,S3). 38 | 39 | partition1(L,Y,[X|L1],L2,X) :- 40 | X =< Y,!, 41 | partition2(L,Y,L1,L2). 42 | partition1(L,Y,L1,[X|L2],X) :- 43 | partition2(L,Y,L1,L2). 44 | 45 | partition2([],_,[],[]). 46 | partition2([X|L],Y,L1,L2) :- partition1(L,Y,L1,L2,X). 47 | 48 | time(T):-statistics(runtime,[_,T]). 49 | -------------------------------------------------------------------------------- /progs/bincont.pl: -------------------------------------------------------------------------------- 1 | % converts a definite clause to a binary metaclause 2 | % where each metavariable Cont represents a "continuation" 3 | % and a goal G is represented by a clause :- G. 4 | 5 | def_to_binary((H:-B),M):-!,def_to_binary0(H,B,M). 6 | def_to_binary(H,M):-def_to_binary0(H,true,M). 7 | 8 | def_to_binary0('@@'(H,Upper),B,(HC:-BC)) :- nonvar(H),!, 9 | % term_append(H,cont(ContH),HC), 10 | H=..FXs, 11 | append(FXs,[ContH],FXsC), 12 | HC=..FXsC, 13 | add_upper_continuation(B,Upper,ContH,BC). 14 | def_to_binary0(H,B,(HC:-BC)) :- 15 | term_append(H,cont(Cont),HC), 16 | add_continuation(B,Cont,BC). 17 | 18 | add_upper_continuation(B,Upper,ContH,BC):-nonvar(Upper),!, 19 | add_continuation(Upper,ContU,ContH), 20 | add_continuation(B,ContU,BC). 21 | add_upper_continuation(B,Upper,ContH,BC):- 22 | add_continuation((strip_continuation(ContH,Upper,ContU),B),ContU,BC). 23 | 24 | % adds a continuation to a term 25 | 26 | add_continuation((true,Gs),C,GC):-!,add_continuation(Gs,C,GC). 27 | add_continuation((fail,_),C,fail(C)):-!. 28 | add_continuation((G,Gs1),C,GC):-!, 29 | add_continuation(Gs1,C,Gs2), 30 | term_append(G,cont(Gs2),GC). 31 | add_continuation(G,C,GC):-term_append(G,cont(C),GC). 32 | 33 | %term_append(H,cont(Cont),HC), 34 | -------------------------------------------------------------------------------- /progs/ag_ic.pl: -------------------------------------------------------------------------------- 1 | :-op(200,xf,(?)). 2 | 3 | ic([a,b,c]). 4 | ic([d,e]). 5 | 6 | violates(Abduced,IC):- 7 | select(X,Abduced,More), 8 | select(Y,More,_), 9 | member(X,IC), 10 | member(Y,IC). 11 | 12 | inconsistent(Abduced):-ic(IC),violates(Abduced,IC). 13 | 14 | select(X,[X|Xs],Xs). 15 | select(X,[Y|Xs],[Y|Ys]):-select(X,Xs,Ys). 16 | 17 | explain(G,Explanation):- 18 | G, 19 | \+ ( 20 | -Abduced, 21 | inconsistent(Abduced) 22 | ), 23 | findall(Abduced,-Abduced,As), 24 | sort(As,Explanation). 25 | 26 | /* 27 | to add an instance A of an abducible do: 28 | 29 | for all instances B of the same abducible 30 | take out B 31 | if B is more general than A, then succeed 32 | else 33 | remove B, 34 | if A does not violate any constraints 35 | then add A 36 | else fail 37 | */ 38 | 39 | pick_subsumed(A,Bs):- 40 | functor(A,F,N), 41 | functor(B,F,N), 42 | -B, 43 | ( subsumes_check(A,B)->Bs=[B|MoreBs] 44 | ; Bs=MoreBs 45 | ), 46 | !, 47 | pick_subsumed(A,MoreBs). 48 | pick_subsumed(_,[]). 49 | 50 | add_abduced(A):- 51 | - abduced(B), 52 | ( -B, subsumes_check(B,A) -> +B 53 | ; +A 54 | ). 55 | 56 | '?'(X):-add_abduced(X). 57 | 58 | go:-explain(g,Explanation),write(Explanation),nl,fail. 59 | go. 60 | 61 | g:- a?,h?,i. 62 | h:- i,b?,c? . 63 | h:- i,d?,c? . 64 | i:- f? . 65 | -------------------------------------------------------------------------------- /progs/term2io.pl: -------------------------------------------------------------------------------- 1 | % EXAMPLE of override/2 and hiden argument grammar (HAG) synergy 2 | % needs source license so you can recompile BinProlog 3 | % with -DJUMP_COMPRESS=0 - it still might work in some cases without 4 | 5 | % written by Paul Tarau - Thu Sep 14 21:51:52 ADT 1995 6 | 7 | go:- 8 | t2s(f(a,b,A,A,_),S),write(S),nl, 9 | s2t(S,T),write(T),nl. 10 | 11 | % term to string 12 | 13 | t2s(T,S):-findall(S,do_t2s(T,S),[S]). 14 | 15 | do_t2s(T,S):- 16 | override(nl,my_nl), 17 | override(put_code(_),my_put_code(_)), 18 | override(fast_write(_),my_cwrite(_)), 19 | numbervars(T,0,_), 20 | dcg_def(S), 21 | generic_write(T,write), 22 | dcg_val([]). 23 | 24 | % the only way to properly emulate write is with side effects 25 | % as write itself fail to save heap space after doing its work 26 | % however, generic_write/2 is clean 27 | % of side effects so grammar emulation is ok 28 | 29 | % string to term 30 | 31 | s2t(S,T):-findall(T,do_s2t(S,T),[T]). 32 | 33 | do_s2t(S,T):- 34 | override(get_code(_),my_get_code(_)), 35 | append(S,[46,10],NewS), % adds "." and end-of-line 36 | dcg_def(NewS), 37 | read(T), 38 | dcg_val([]). 39 | 40 | 41 | % tools using HAGs (hidden argument grammars - highly recommended !) 42 | 43 | my_get_code(X):- #X. 44 | 45 | my_nl:- #10. 46 | my_put_code(X) :- #X. 47 | my_cwrite(X):- name(X,Xs), my_write_name(Xs). 48 | 49 | my_write_name([]). 50 | my_write_name([X|Xs]):- #X, my_write_name(Xs). 51 | -------------------------------------------------------------------------------- /progs/l.pl: -------------------------------------------------------------------------------- 1 | % permutation with linear assumptions 2 | % to be accelerated with a compiled implementation of linear assumptions 3 | 4 | max(7). 5 | 6 | t1(Mes):-test(Mes,lin_perm,g1). 7 | 8 | t2(Mes):-test(Mes,lperm,g2). 9 | 10 | t3(Mes):-test(Mes,lin_perm_with_findall,g3). 11 | 12 | go(Mes):- 13 | write('execute with -h20000 option'),nl, 14 | t1(Mes),fail;t2(Mes),fail;t3(Mes),fail. 15 | 16 | go:-go('BMARK_linperms'). 17 | 18 | nats(Max,Max):-!,assumel(n(Max)). 19 | nats(Curr,Max):- 20 | Curr wrong - X and f(...X...) could be in the 44 | same segment 45 | 46 | => a fast (how fast?) unification with occure check 47 | algorithm seem to be possible to be implemented by 48 | checking for cycles from the value trailed cells after 49 | successful unifications. 50 | 51 | 52 | */ 53 | -------------------------------------------------------------------------------- /progs/fknight.pl: -------------------------------------------------------------------------------- 1 | p:-compile('fknight.pl'). 2 | 3 | /* 4 | adapted by Paul Tarau from (partial) KnightTour benchmark originally 5 | written by Evan Tick 6 | */ 7 | 8 | go:-go(5). 9 | 10 | go(N):- 11 | time(_), 12 | make_board(N,Board,NbMoves), 13 | knight(NbMoves,1,1,N,Board),!, 14 | time(T), 15 | nl,write('BMARK_fknight'=[time(T),'N'=N]),nl, 16 | statistics,show(N,Board). 17 | 18 | make_board(N,Board,M):- 19 | M is N*N, 20 | functor(Line,line,N), 21 | findall(Line,range(_,1,N),LBoard), 22 | Board=..[board|LBoard]. 23 | 24 | val(I,J,Val,N,Board):- 25 | I>0,I=0,J=nl;true), 53 | fail. 54 | show(_,_):-nl. 55 | 56 | move( 2, 1). 57 | move( 2,-1). 58 | move(-2, 1). 59 | move(-2,-1). 60 | move( 1, 2). 61 | move(-1, 2). 62 | move( 1,-2). 63 | move(-1,-2). 64 | 65 | 66 | time(T) :- statistics(runtime,[_,T]). 67 | 68 | -------------------------------------------------------------------------------- /progs/qrev.pl: -------------------------------------------------------------------------------- 1 | app([],Ys,Ys). 2 | app([A|Xs],Ys,[A|Zs]):- 3 | app(Xs,Ys,Zs). 4 | 5 | nrev([],[]). 6 | nrev([X|Xs],R):- 7 | nrev(Xs,T), 8 | det_append(T,[X],R). % deterministic append 9 | 10 | range(Min,Min,Max):-Min=I), 11 | instance_of(I,T1), 12 | println(instance:I=>T1), 13 | instance_of(I,T2), 14 | println(instance:I=>T2), 15 | free_term(I), 16 | println(T=T1), 17 | (T=T1->println(equal);println(not_equal)), 18 | ctime(S1), 19 | ( for(_,1,N), 20 | new_term(T,Handle), 21 | instance_of(Handle,_), 22 | free_term(Handle), 23 | fail 24 | ; true 25 | ), 26 | ctime(S2), 27 | S0 is S2-S1, 28 | S is S0/3000.00001, 29 | OT is S/N, 30 | ST is N/S, 31 | println([create_free(N), total=S0, total_ms_per_op=S,one=OT, per_sec=ST]). 32 | 33 | go2:- 34 | K=f(a,b), 35 | push_term(K,g(c,d)), 36 | T0=h(f(123,b,U),g(m,3.14,U),n), 37 | put_term(K,T0), 38 | count_terms(K,N), 39 | new_iterator(K,Iter), 40 | println(t0=T0), 41 | println([count=N,iter=Iter]), 42 | ( for(I,1,N), 43 | get_next_term(Iter,T), 44 | println(K:I=>T), 45 | fail 46 | ; close_iterator(Iter) 47 | ), 48 | delete_all_terms(K), 49 | (has_terms(K)->println(has_terms);println(no_terms_left)). 50 | 51 | 52 | go1:- 53 | T0=f(a,X,[1,2],g(314,X),77), 54 | put_term(111,T0), 55 | new_iterator(a,I), 56 | get_next_term(I,T), 57 | println(T0=T), 58 | T=T0, 59 | println(equal). 60 | 61 | -------------------------------------------------------------------------------- /progs/knight.pl: -------------------------------------------------------------------------------- 1 | /*---------------------------------------------------------------------------- 2 | Program: Knight's Tour 3 | Author: E. Tick 4 | Date: September 10 1989 5 | Notes: 6 | % adapted and optimized for BinProlog: Paul Tarau, August 1992 7 | % changed semantics: the knight has to cover the board completely 8 | 9 | 1. To run: 10 | ?- go(N,T,S). 11 | for input N (side of board), output T is execution time, and S is the number 12 | of solutions. Usually we run go(5,X,Y). 13 | 14 | ---------------------------------------------------------------------------- 15 | :- sequential. 16 | :- parallel move/2. 17 | */ 18 | 19 | p:-[knight]. 20 | 21 | 22 | go:-go(5). 23 | 24 | go(N):-time(_),init(N,M),knight(M,1,1),!,time(T), 25 | write(time=T),nl,statistics,show(N). 26 | 27 | init(N,_):- 28 | for(I,1,N), 29 | for(J,1,N), 30 | bb_def(I,J,_NewVar), 31 | fail. 32 | init(N,M):- 33 | M is N*N. 34 | 35 | knight(0,_,_) :- !. 36 | knight(K,A,B) :- 37 | K1 is K-1, 38 | val(A,B,K), 39 | move(Dx,Dy), 40 | step(K1,A,B,Dx,Dy). 41 | 42 | step(K1,A,B,Dx,Dy):- 43 | C is A + Dx, 44 | D is B + Dy, 45 | knight(K1,C,D). 46 | 47 | % wam.c: strange bug when cells are not cast to (int) in arith ops!!! 48 | show(N):- 49 | cwrite('The Board'),nl, 50 | for(I,1,N), 51 | nl, 52 | for(J,1,N), 53 | val(I,J,V), 54 | X is 1-V // 10, 55 | cwrite(' '),tab(X),cwrite(V), 56 | fail. 57 | show(_):-nl. 58 | 59 | move( 2, 1). 60 | move( 2,-1). 61 | move(-2, 1). 62 | move(-2,-1). 63 | move( 1, 2). 64 | move(-1, 2). 65 | move( 1,-2). 66 | move(-1,-2). 67 | 68 | time(T) :- statistics(runtime,[_,T]). 69 | -------------------------------------------------------------------------------- /progs/bugs.pl: -------------------------------------------------------------------------------- 1 | go:-tbug. 2 | 3 | % SOLVED - by ensuring unique ids 4 | % exhibits tcall/4 bug at small scale 5 | 6 | tbug:-quiet(1),bgtask,bgtask. 7 | 8 | bgtask:- 9 | println(making_bg_task), 10 | create_engine(1000,300,300,Engine), 11 | load_engine(Engine,topcall(loop(300)),_), 12 | ask_thread(Engine,Thread), 13 | sleep(4), 14 | ENGINE_ID=7, 15 | get_engine_prop(Engine,ENGINE_ID,ID), 16 | destroy_engine(Engine), 17 | println(destroying(engine(Engine),id(ID),thread(Thread))). 18 | 19 | loop(N):- 20 | for(I,1,N), 21 | println(wait_step(I)), 22 | sleep(1), 23 | fail. 24 | loop(_). 25 | 26 | badcall(G):-catch(metacall(G),_,true). 27 | 28 | /* 29 | - the bug seems to come from the fact 30 | that assumptions use an engine number - which 31 | if the engines memory address is reused will refer 32 | to dead memory areas 33 | => make assumptions use always new numbers - or make 34 | engine ids alswas new - independently of their 35 | recycling mechanism 36 | */ 37 | 38 | /* pbench: also in assertbm - FIXED - by making sure assumptions are ignored 39 | in bb_gc 40 | 41 | index took 42 | user cpu (5148-380)/364431 = 0.0130834 ms/iteration 43 | 4 ??? warning: *** bad stamp or empty slot in set/3 or rm/2 *** 44 | >>> blackboard overflow, left only(126476): culprit(bb_put_1([1206000,1212588],4 45 | ,cont_marker(_x109229),f(3,_x2322))) 46 | *** discarding inconsistent blackboard content 47 | *** BB_OVERFLOW: 48 | addq(user,(null)/0 ??? warning: *** bad data in args(1) of name/2 *** 49 | (addq(user,(null)/0 ??? warning: *** bad data in args(1) of name/2 *** 50 | */ -------------------------------------------------------------------------------- /progs/catch.pl: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | ISO: 4 | catch(Goal,Ball,Do) 5 | 6 | execute Goal 7 | on throw(Term): look for closest catch 8 | copy Term 9 | undo bindings until call to catch; remove choices 10 | unify with Ball 11 | if fail: throw Ball again 12 | if succeed: call Do, continuation of catch goal 13 | 14 | 15 | catch(Goal,Ball,Do,Cont) ::- c4(Goal,Ball,Do,Cont,Cont) . 16 | catch(_,_,_) :- fail . 17 | 18 | c4(Goal,Ball,Do,Cont) :- get_neck_cut(Choice) , 19 | (catchmarker(Ball,Do,Choice,Cont) -:: dogoal(Goal)) . 20 | 21 | dogoal(Goal) :- Goal. 22 | 23 | throw(Term) :- copy_term(Term,Copied) , 24 | catchmarker(Ball1,Do1,Choice,Cont1) , ! , 25 | Ball1 = Ball , 26 | Do1 = Do, 27 | Cont1 = Cont , 28 | _Copied1 = Copied , 29 | untrail_to(Choice) , 30 | (Ball = Copied -> call2(Do,Cont) ; throw(Term)) . 31 | 32 | call2(Do,NewCont,_) ::- call(Do,NewCont) . 33 | */ 34 | 35 | /* non exhaustive tests follow */ 36 | 37 | l :- [catch4] . 38 | 39 | 40 | a :- catch(b,X,write(ball(X))) , write(7) . 41 | 42 | b :- throw(1) . 43 | 44 | c :- catch(d,X,write(ball(X))) , write(7) , nl, fail . 45 | 46 | d . 47 | d :- throw(66) , write(oei) . 48 | d . 49 | 50 | f :- catch(g,X,write(h(X))) , write(99) , nl , fail . 51 | 52 | g :- catch(h,3,write(c(3))) , write(bla) , nl . 53 | 54 | h :- throw(4) . 55 | h :- write(h2) . 56 | 57 | 58 | k :- catch(s,X,t(h(X))) , write(99) , nl, fail . 59 | m :- catch(s,X,t(h(X))) , write(99) , nl , ! , fail . 60 | 61 | s :- throw(137) . 62 | 63 | t(X) :- write(X) , nl . 64 | t(X) :- write(2-X) , nl . 65 | 66 | 67 | u :- catch(g(X),B,write(f(B,X))) . 68 | 69 | g(X) :- X = 2 , throw(X) . 70 | -------------------------------------------------------------------------------- /progs/over_ex.pl: -------------------------------------------------------------------------------- 1 | % needs source license so you can recompile BinProlog 2 | % with -DJUMP_COMPRESS=0 - it still might work in some cases without 3 | 4 | go:-g0,fail;g1,fail;g2,fail;g3,fail;g4,fail;g,fail. 5 | %bug,fail; 6 | %not_a_bug_anymore. 7 | 8 | a(1). 9 | a(2). 10 | 11 | b(10). 12 | b(20). 13 | 14 | c(100). 15 | c(200). 16 | 17 | d(1000). 18 | d(2000). 19 | d(3000). 20 | d(X):-X=4000. 21 | 22 | g0:-override(a(_),b(_)), 23 | override(b(_),c(_)), 24 | (override(c(_),d(_)),a(X),write(X),nl,fail; 25 | dummy,c(X),write(c(X)),nl,fail). 26 | 27 | 28 | forward(F,N,G,M):- 29 | functor(P,F,N), 30 | functor(Q,G,M), 31 | override(P,Q). 32 | 33 | g:-forward(a,1,b,1),forward(b,1,c,1),g1. 34 | g1:-dummy,a(X),write(X),nl,fail. 35 | 36 | dummy. 37 | 38 | g2:-override(a(_),d(_)),a(X),write(X),nl,fail. %NO 39 | 40 | g3:-override(d(_),a(_)),d(X),write(X),nl,fail. %NO 41 | 42 | g4:-override(d(_),a(_)),d(X),write(X),nl,fail. % YES 43 | 44 | 45 | let_pred(F/N,G/M,InG):- 46 | forward(F,N,G,M), 47 | InG, 48 | forward(G,M,F,N). % this gives a loop 49 | 50 | 51 | not_a_bug_anymore:-let_pred(b/1,c/1,b(X)),b(Y),write(X+Y),nl,fail. 52 | 53 | %bug:-override(put(_),string_put(_)),put_string("gaga"). 54 | 55 | bug:-override(put(_),string_put(_)),put_string("gaga"),nl,fail. 56 | bug:-override(my_put(_),string_put(_)),put_string("gaga"),nl,fail. 57 | bug:-put_string("gaga"),nl. 58 | 59 | put_string([]). 60 | put_string([X|Xs]):- 61 | % put(X), -- impossible to override inline builtins -- trigers the bug 62 | my_put(X), 63 | put_string(Xs). 64 | 65 | string_put(X):-cwrite(X),nl. % only for tracing purpose 66 | 67 | my_put(X):-put(X). 68 | -------------------------------------------------------------------------------- /progs/rnet.pl: -------------------------------------------------------------------------------- 1 | /* 2 | % new networking 3 | 4 | % server side 5 | 6 | server:- 7 | server(7001,none). 8 | 9 | server(Port,Password):- 10 | new_server(Port,Server), 11 | serve(Server,Password). 12 | 13 | serve(Server,Password):- 14 | repeat, 15 | ( new_service(Server,Service)-> 16 | bg(service_loop(Service,Password)), 17 | fail 18 | ; true 19 | ), 20 | !. 21 | 22 | starting_service:-let(service_finished,no). 23 | stop_service:-let(service_finished,yes). 24 | service_stopped:-val(service_finished,yes). 25 | 26 | service_loop(Service,Password):- 27 | starting_service, 28 | repeat, 29 | ( service_stopped->true 30 | ; answer_one_query(Service,Password)->fail 31 | ; true 32 | ), 33 | !, 34 | 'prolog:disconnect'(Service). 35 | 36 | 37 | % client side 38 | 39 | 40 | ask(Client,X,G,R):- 41 | 'prolog:ask_service'(Client,X,G,none,R). 42 | 43 | ask(Client,G):-ask(Client,G,G,the(G)). 44 | 45 | stop_service(Client):- 46 | ask(Client,stop_service), 47 | 'prolog:disconnect'(Client). 48 | */ 49 | 50 | ctest1:- 51 | ctest(1000,_,true). 52 | 53 | ctest2:- 54 | ctest(100,I,println(I)). 55 | 56 | ctest3:- 57 | ctest(100,_,findall(K,for(K,1,10),Ks)), 58 | println(Ks). 59 | 60 | ctest(N,I,G):- 61 | println(ctest(N,G)), 62 | ctest(N,I,G,T), 63 | println(time=T). 64 | 65 | ctest(N,I,G,T):- 66 | new_client(C), 67 | ctime(T1), 68 | for(I,1,N), 69 | ( ask(C,G)->true 70 | ; !,println(unexpected_failure(I,G)) 71 | ), 72 | I=N, 73 | stop_service(C), 74 | ctime(T2), 75 | T is T2-T1. 76 | 77 | -------------------------------------------------------------------------------- /library/record.pl: -------------------------------------------------------------------------------- 1 | % fairly efficient legacy recorda-recordz familly 2 | % still useful for running old programs 3 | 4 | % sorry for explicit Refs, but as they are not present in ISO prolog 5 | % anymore, and are unsafe with gc, they are discontinued... 6 | % they will be emulated by returning the terms themselves 7 | % but this will be inefficient 8 | 9 | record(Key,Term,Term):-record(Key,Term). 10 | recorda(Key,Term,Term):-recorda(Key,Term). 11 | recordz(Key,Term,Term):-recordz(Key,Term). 12 | recorded(Key,Term,Term):-recorded(Key,Term). 13 | erase(Term):-recorded_key(Key),erase(Key,Term),!. 14 | 15 | % end of */3 emultaion 16 | 17 | record(Key,Term):-recordz(Key,Term). 18 | 19 | recorda(Key,Term):- 20 | pushq('$recorded',Key,Term), 21 | record_key(Key). 22 | 23 | recordz(Key,Term):- 24 | addq('$recorded',Key,Term), 25 | record_key(Key). 26 | 27 | recorded(Key,Term):-var(Key),!, 28 | recorded_key(Key), 29 | get_recorded(Key,Term). 30 | recorded(Key,Term):- 31 | get_recorded(Key,Term). 32 | 33 | erase(Key,Term):- 34 | cdelq('$recorded',Key,Term,_). 35 | 36 | current_key(Name,Key):- 37 | recorded_key(Key), 38 | functor(Key,Name,_). 39 | 40 | % hidden tools 41 | 42 | record_key(Key):- 43 | functor(Key,F1,N1), 44 | rmemoq('$keys','$recorded',F1/N1). 45 | 46 | recorded_key(Key):- 47 | cmembq('$keys','$recorded',F1/N1), 48 | functor(Key,F1,N1). 49 | 50 | get_recorded(Key,Term):- 51 | cmembq('$recorded',Key,Term). 52 | 53 | 54 | % adds a (assumed ground) object unless it is there 55 | rmemoq(Key,Name,X):- 56 | cmembq(Key,Name,X),!. 57 | rmemoq(Key,Name,X):- 58 | addq(Key,Name,X). 59 | -------------------------------------------------------------------------------- /progs/cont.pl: -------------------------------------------------------------------------------- 1 | % CONTINUATIONS ARE FIRST ORDER OBJECTS: some tools based on this 2 | 3 | % calls Goal with current continuation available to its inner calls 4 | capture_cont_for(Goal):- 5 | assumeal(cont_marker(End)), 6 | Goal, 7 | end_cont(End). 8 | 9 | % passes Closure to be called on accumulated continuation 10 | call_with_cont(Closure):- 11 | assumed(cont_marker(End)), 12 | consume_cont(Closure,End). 13 | 14 | % gathers in conjunction goals from the current continuation 15 | % until Marker is reached when it calls Closure ont it 16 | consume_cont(Closure,Marker):- 17 | get_cont(Cont), 18 | consume_cont1(Marker,(_,_,_,Cs),Cont,NewCont), % first _ 19 | call(Closure,Cs), % second _ 20 | % sets current continuation to leftover NewCont 21 | call_cont(NewCont). % third _ 22 | 23 | % gathers goals in Gs until Marker is hit in continuation Cont 24 | % when leftover LastCont continuation (stripped of Gs) is returned 25 | consume_cont1(Marker,Gs,Cont,LastCont):- 26 | strip_cont(Cont,Goal,NextCont), 27 | ( NextCont==true-> !,errmes(in_consume_cont,expected_marker(Marker)) 28 | ; arg(1,NextCont,X),Marker==X-> 29 | Gs=Goal,arg(2,NextCont,LastCont) 30 | ; Gs=(Goal,OtherGs), 31 | consume_cont1(Marker,OtherGs,NextCont,LastCont) 32 | ). 33 | 34 | % this `binarized clause' gets the current continuation 35 | get_cont(Cont,Cont)::-true(Cont). 36 | 37 | % setes calls NewCont as continuation to be called next 38 | call_cont(NewCont,_) ::- true(NewCont). 39 | 40 | % sets NewCont as continuation to be called next 41 | % instead of OldCont which is returned in arg 2 42 | swap_cont(NewCont,OldCont,OldCont) ::- true(NewCont). 43 | -------------------------------------------------------------------------------- /src/tstore.pl: -------------------------------------------------------------------------------- 1 | 2 | 3 | % API 4 | 5 | tstest(K,V,R):-term_store_op(0,K,V,R). 6 | push_term(K,T):-term_store_op(1,K,T,_). 7 | put_term(K,T):-term_store_op(2,K,T,_). 8 | new_iterator(K,I):-term_store_op(3,K,0,I). 9 | close_iterator(I):-term_store_op(4,I,0,_). 10 | has_terms(K):-term_store_op(5,K,0,YN), YN=1. 11 | get_next_term(I,T):-term_store_op(6,I,0,T). 12 | remove_current_term(I):-term_store_op(7,I,0,_). 13 | update_current_term(I,T):-term_store_op(8,I,0,T). 14 | delete_all_terms(K):-term_store_op(9,K,0,_). 15 | count_terms(K,N):-term_store_op(10,K,0,N). 16 | 17 | new_term(K,R):-term_store_op(11,K,0,R). 18 | instance_of(K,R):-term_store_op(12,K,0,R). 19 | free_term(K):-term_store_op(13,K,0,_). 20 | 21 | new_key_iterator(I):-term_store_op(14,0,0,I). 22 | 23 | process_term(OpCode,Input,Output):- 24 | term_store_op(15,OpCode,Input,Output). 25 | 26 | % derived operations 27 | 28 | get_term(K,T):-get_term(K,0,T). 29 | 30 | remove_term(K,T):-get_term(K,1,T). 31 | 32 | get_term(K,Remove,T):- 33 | count_terms(K,N), 34 | N>0, 35 | new_iterator(K,Iter), 36 | for(I,1,N), 37 | get_next_term(Iter,T), 38 | (0=:=Remove->true;remove_current_term(Iter)), 39 | ( I=:=N-> 40 | close_iterator(Iter) 41 | ; true 42 | ). 43 | 44 | /* similar to findall(Term,get_hash(Key,Term),Terms) */ 45 | 46 | get_all_terms(Key,Ts):- 47 | new_iterator(Key,Iterator), 48 | get_one_more_term(Iterator,Ts), 49 | close_iterator(Iterator). 50 | 51 | /* collects on term at a time from a new iterator */ 52 | get_one_more_term(Iterator,[T|Ts]):- 53 | get_next_term(Iterator,T), 54 | !, 55 | get_one_more_term(Iterator,Ts). 56 | get_one_more_term(_Iterator,[]). 57 | 58 | -------------------------------------------------------------------------------- /progs/cperms.pl: -------------------------------------------------------------------------------- 1 | % ap4.pl 2 | 3 | all_permutations([],[[]]). 4 | all_permutations([X|Xs],Ps2):- 5 | all_permutations(Xs,Ps1), 6 | extend_permutations(Ps1,X,Ps2). 7 | 8 | extend_permutations([],_,[]). 9 | extend_permutations([P|Ps1],X,[[X|P]|Ps3]):- 10 | extend_permutations(Ps1,X,Ps2), 11 | insert_item(P,[],X,Ps2,Ps3). 12 | 13 | insert_item([],_,_,Ps,Ps). 14 | insert_item([Y|Ys],Ys0,X,Ps1,[Zs|Ps2]):- 15 | reverse_and_append(Ys0,Ys,X,Ps1,Ps2,[Y|Ys0],Zs,[Y,X|Ys]). 16 | 17 | reverse_and_append([],Ys,X,Ps1,Ps2,Ys1,Zs,Zs):- 18 | insert_item(Ys, Ys1, X,Ps1,Ps2). 19 | reverse_and_append([X1|Xs],Ys,X,Ps1,Ps2, Ys1,Zs,Zs1):- 20 | reverse_and_append(Xs,Ys,X,Ps1,Ps2,Ys1, Zs,[X1|Zs1]). 21 | 22 | nats(Max,Max,[Max]):-!. 23 | nats(Curr,Max,[Curr|Ns]):- 24 | Currusr_dir(C,D) 57 | ; ctime(T1), DeltaT is T1-T0,DeltaT>0.20,D is 1 58 | ). 59 | 60 | usr_dir(-77,0). % right -77 61 | usr_dir(-80,1). % down -80 62 | usr_dir(-75,2). % left -75 63 | usr_dir(-72,3). % up -72 64 | usr_dir(10,-1). % enter -1 65 | usr_dir(27,0):-scr_end. % escape 66 | */ -------------------------------------------------------------------------------- /progs/callbm.pl: -------------------------------------------------------------------------------- 1 | xfoldl(F,Z,Xs,R):-xfoldl0(Xs,F,Z,R). 2 | 3 | xfoldl0([],_,R,R). 4 | xfoldl0([X|Xs],F,R1,R3):-call(F,R1,X,R2),xfoldl0(Xs,F,R2,R3). 5 | 6 | xfoldr(F,Z,Xs,R):-xfoldr0(Xs,F,Z,R). 7 | 8 | xfoldr0([],_,Z,Z). 9 | xfoldr0([X|Xs],F,Z,R2):-xfoldr0(Xs,F,Z,R1),call(F,X,R1,R2). 10 | 11 | lsum(Nul,Xs,R):-xfoldl(+,Nul,Xs,R). 12 | 13 | rsum(Nul,Xs,R):-xfoldl(+,Nul,Xs,R). 14 | 15 | ok:-xfoldr((-),0,[1,2,3],R),write(R),nl. 16 | 17 | make_ints([],I,I):-!. 18 | make_ints([I0|L],I0,I):-I0true 27 | ; bb_error(N) 28 | ). 29 | 30 | bb_error(T):-functor(T,F,N), 31 | write(F/N), 32 | write(' ??? bb_def/3 expected before bb_set/3, bb_rm/2'),nl, 33 | fail. 34 | 35 | bb_let(N,K,_):-bb_rm(N,K),fail. 36 | bb_let(N,K,X):-bb_set(N,K,X). 37 | 38 | bb_def(K,X):-bb_def(K,K,X). 39 | 40 | bb_set(K,X):-bb_set(K,K,X). 41 | 42 | bb_val(K,X):-bb_val(K,K,X). 43 | 44 | bb_rm(K):-bb_rm(K,K). 45 | 46 | bb_let(K,X):-bb_let(K,K,X). 47 | 48 | bb:- 49 | bb(N,K,X),functor(N,Nf,Nn),functor(K,Kf,Kn), 50 | write(Nf/Nn+Kf/Kn=X),nl,fail 51 | ; nl. 52 | 53 | bb_assert(N,K,X):- 54 | term2key(N,NewN), 55 | term2key(K,NewK), 56 | assert(bb(NewN,NewK,X)). 57 | 58 | go:- 59 | bb_def(a,13),bb_set(a,10),bb_val(a,X),write(X),nl,fail 60 | ; bb_set(b,5) 61 | ; bb_def(f(1,1),g(2,2)),fail 62 | ; bb_val(f(a,a),X),write(X),nl,fail 63 | ; bb_rm(c,d) 64 | ; bb_def(_,_,_) 65 | ; bb. 66 | 67 | p:-reconsult('bb.pl'). 68 | -------------------------------------------------------------------------------- /doc/local.bib: -------------------------------------------------------------------------------- 1 | 2 | @inproceedings{Demoen91:RU, 3 | title={{I}mplementation of {P}rolog as binary definite {P}rograms}, 4 | author={Demoen, Bart and Mari\"{e}n, Andr\'{e}}, 5 | pages={165--176}, 6 | booktitle = {Logic Programming, RCLP Proceedings}, 7 | year = {1992}, 8 | editor = {Voronkov, Andrei}, 9 | publisher = {Springer-Verlag}, 10 | series = {Lecture Notes in Artificial Intelligence}, 11 | number = {592}, 12 | address = {Berlin, Heidelberg}, 13 | } 14 | 15 | 16 | @TECHREPORT{Demoen90:KUL, 17 | author={Demoen, Bart}, 18 | title = {On the {T}ransformation of a {P}rolog Program to a more efficient 19 | {B}inary Program}, 20 | institution = "K.U.Leuven", 21 | number = "130", 22 | month = dec, 23 | year = 1990, 24 | } 25 | 26 | @inproceedings{LOPSTR93:Neumerkel, 27 | author="Ulrich Neumerkel", 28 | title= "A Transformation Based on the Equality between Terms", 29 | booktitle= "Logic Program Synthesis and Transformation, LOPSTR 1993", 30 | publisher = "Springer-Verlag", 31 | year = "1993" 32 | } 33 | 34 | 35 | @PHDTHESIS{Neum92, 36 | author = "Neumerkel, Ulrich", 37 | title = "Specialization of {Prolog} Programs with Partially 38 | Static Goals and Binarization", 39 | type={PhD thesis}, 40 | school={Technische Universit\"{a}t Wien}, 41 | year = 1992, 42 | } 43 | 44 | @Misc{lindgren, 45 | author = "Lindgren, T.", 46 | title = "Compiling Logic Programs Using a Binary Continuation Style", 47 | month = dec, 48 | year = 1992, 49 | note = "draft, Uppsala University" 50 | } 51 | 52 | @TECHREPORT{WA83, 53 | author={Warren, D. H. D.}, 54 | title = "An {A}bstract {P}rolog {I}nstruction {S}et", 55 | institution = "SRI International", 56 | type="Technical Note", 57 | number=309, 58 | month = Oct, 59 | year = 1983, 60 | } 61 | 62 | -------------------------------------------------------------------------------- /progs/qbrev.pl: -------------------------------------------------------------------------------- 1 | nrev([],[]). 2 | nrev([X|Xs],R):- 3 | nrev(Xs,T), 4 | det_append(T,[X],R). 5 | 6 | full_range(It,L):- range(_,1,It),nrev(L,_), fail. 7 | full_range(_,_). 8 | 9 | dummy(_,_). 10 | 11 | empty_range(It,L):-range(_,1,It),dummy(L,_),fail. 12 | empty_range(_,_). 13 | 14 | range(Min,Min,Max):-Min=! %,fail 36 | ; true 37 | ). 38 | get_a_predicate(FN,Cs):- 39 | get_a_predicate(FN,Cs). 40 | 41 | read_predicate(FN,[C|Cs]):- 42 | rclause(FN,C), 43 | ( FN=end_of_file/0->Cs=[] 44 | ; get_all_clauses(FN,Cs) 45 | ). 46 | 47 | get_all_clauses(FN,Cs):-findall(C,get_a_clause(FN,C),Cs). 48 | 49 | get_a_clause(FN,C):- 50 | radd(NewFN,C), 51 | ( 52 | (NewFN = FN, NewFN\==(:-)/1) -> true 53 | ; !, bb_def(left,over,NewFN-C),fail 54 | ). 55 | get_a_clause(FN,C):- 56 | get_a_clause(FN,C). 57 | 58 | rclause(FN,C):-bb_val(left,over,FN-C),bb_rm(left,over),!. 59 | rclause(FN,C):-radd(FN,C). 60 | 61 | radd(FN,C):-read_clause(C),get_pred(C,FN). 62 | 63 | get_pred((H:-_),F/N):-!,functor(H,F,N). 64 | get_pred((::-(H,_)),F/N1):-!,functor(H,F,N),N1 is N-1. 65 | get_pred(H,F/N):-functor(H,F,N). 66 | 67 | 68 | '::-'(a(1,C),b(C)). 69 | a(2). 70 | 71 | b. 72 | 73 | :-write(a),nl. 74 | :-write(b),nl. 75 | 76 | c(X)-->{a(X)},[ok]. 77 | d(X)-->{X=3}. 78 | 79 | d(S,T):-c(2,S,T). 80 | ax(X)-->c(X);d(X). 81 | 82 | ax:-ax(X,Xs,[]),write(X+Xs),nl,fail. 83 | -------------------------------------------------------------------------------- /progs/fbrev.pl: -------------------------------------------------------------------------------- 1 | % uses builtin append 2 | 3 | nrev([],[]). 4 | nrev([X|Xs],R):- 5 | nrev(Xs,T), 6 | append(T,[X],R). 7 | 8 | full_range(It,L):- range(_,1,It),nrev(L,_), fail. 9 | full_range(_,_). 10 | 11 | dummy(_,_). 12 | 13 | empty_range(It,L):-range(_,1,It),dummy(L,_),fail. 14 | empty_range(_,_). 15 | 16 | range(Min,Min,Max):-Min= ex,[';']. 4 | 5 | ex --> term,terms. 6 | 7 | terms --> []. 8 | terms --> ['+'],term,terms. 9 | terms --> ['-'],term,terms. 10 | 11 | term --> factor,factors. 12 | 13 | factors --> []. 14 | factors --> ['*'],factor,factors. 15 | factors --> ['/'],factor,factors. 16 | 17 | factor --> [id], subfactors. 18 | factor --> ['(',ex,')']. 19 | 20 | subfactors --> []. 21 | subfactors --> ['('], ex, exs, [')']. 22 | 23 | exs --> []. 24 | exs --> [','],ex,exs. 25 | 26 | % HAG 27 | axiom :- ex, #(';'). 28 | 29 | ex :- term,terms. 30 | 31 | terms. 32 | terms :- #('+'),term,terms. 33 | terms :- #('-'),term,terms. 34 | 35 | term :- factor,factors. 36 | 37 | factors. 38 | factors :- #('*'),factor,factors. 39 | factors :- #('/'),factor,factors. 40 | 41 | factor :- #id, subfactors. 42 | factor :- #('('), ex, #(')'). 43 | 44 | subfactors. 45 | subfactors :- #('('), ex, exs, #(')'). 46 | 47 | exs. 48 | exs :- #(',') ,ex,exs. 49 | 50 | 51 | % common data 52 | 53 | terminal(id). 54 | terminal('+'). 55 | terminal('-'). 56 | terminal('*'). 57 | terminal('/'). 58 | terminal(','). 59 | terminal('('). 60 | terminal(')'). 61 | terminal(';'). 62 | 63 | % DCG vs. HAG comparison 64 | 65 | generate(0,[]). 66 | generate(N,[X|Xs]):-N>0,N1 is N-1,generate(N1,Xs),terminal(X). 67 | 68 | do(N,Goal):- 69 | write(begin(N)),nl, 70 | generate(N,Xs), 71 | arg(1,Goal,Xs), 72 | Goal, 73 | writeln(Xs), 74 | fail. 75 | do(N,_):-write(end(N)),nl. 76 | 77 | test(N,Mes,Goal):- 78 | time(T0), 79 | do(N,dummy(_)), 80 | time(T1), 81 | do(N,Goal), 82 | time(T2), 83 | T is (T2-T1)-(T1-T0), 84 | write(Mes=time(T)),nl,nl. 85 | 86 | writeln([]):-nl. 87 | writeln([X|Xs]):-write(X),writeln(Xs). 88 | 89 | time(T):-statistics(runtime,[T,_]). 90 | 91 | dcgs(Xs):-axiom(Xs,[]). 92 | 93 | hags(Xs):-dcg_def(Xs),axiom,dcg_val([]). 94 | 95 | dummy(_):-fail. 96 | 97 | go(N):- 98 | test(N,'DCG_bmark:',dcgs(_)), 99 | test(N,'HAG_bmark:',hags(_)). 100 | 101 | go:-go(4). 102 | -------------------------------------------------------------------------------- /progs/hag_bm1.pl: -------------------------------------------------------------------------------- 1 | % DCG 2 | 3 | axiom --> ex,[';']. 4 | 5 | ex --> term,terms. 6 | 7 | terms --> []. 8 | terms --> plus_op,term,terms. 9 | 10 | term --> factor,factors. 11 | 12 | factors --> []. 13 | factors --> mul_op,factor,factors. 14 | 15 | factor --> [id], subfactors. 16 | factor --> ['(',ex,')']. 17 | 18 | subfactors --> []. 19 | subfactors --> ['('], ex, exs, [')']. 20 | 21 | exs --> []. 22 | exs --> [','],ex,exs. 23 | 24 | plus_op --> ['+']. 25 | plus_op --> ['-']. 26 | 27 | mul_op --> ['*']. 28 | mul_op --> ['/']. 29 | 30 | 31 | % HAG 32 | axiom :- ex, #(';'). 33 | 34 | ex :- term,terms. 35 | 36 | terms. 37 | terms :- plus_op,term,terms. 38 | 39 | term :- factor,factors. 40 | 41 | factors. 42 | factors :- mul_op,factor,factors. 43 | 44 | factor :- #id, subfactors. 45 | factor :- #('('), ex, #(')'). 46 | 47 | subfactors. 48 | subfactors :- #('('), ex, exs, #(')'). 49 | 50 | exs. 51 | exs :- #(',') ,ex,exs. 52 | 53 | plus_op :- #('+'). 54 | plus_op :- #('-'). 55 | 56 | mul_op :- #('*'). 57 | mul_op :- #('/'). 58 | 59 | % common data 60 | 61 | terminal(id). 62 | terminal('+'). 63 | terminal('-'). 64 | terminal('*'). 65 | terminal('/'). 66 | terminal(','). 67 | terminal('('). 68 | terminal(')'). 69 | terminal(';'). 70 | 71 | % DCG vs. HAG comparison 72 | 73 | generate(0,[]). 74 | generate(N,[X|Xs]):-N>0,N1 is N-1,generate(N1,Xs),terminal(X). 75 | 76 | do(N,Goal):- 77 | write(begin(N)),nl, 78 | generate(N,Xs), 79 | arg(1,Goal,Xs), 80 | Goal, 81 | writeln(Xs), 82 | fail. 83 | do(N,_):-write(end(N)),nl. 84 | 85 | test(N,Mes,Goal):- 86 | time(T0), 87 | do(N,dummy(_)), 88 | time(T1), 89 | do(N,Goal), 90 | time(T2), 91 | T is (T2-T1)-(T1-T0), 92 | write(Mes=time(T)),nl,nl. 93 | 94 | writeln([]):-nl. 95 | writeln([X|Xs]):-write(X),writeln(Xs). 96 | 97 | time(T):-statistics(runtime,[T,_]). 98 | 99 | dcgs(Xs):-axiom(Xs,[]). 100 | 101 | hags(Xs):-dcg_def(Xs),axiom,dcg_val([]). 102 | 103 | dummy(_):-fail. 104 | 105 | go(N):- 106 | test(N,'DCG_bmark:',dcgs(_)), 107 | test(N,'HAG_bmark:',hags(_)). 108 | 109 | go:-go(4). 110 | -------------------------------------------------------------------------------- /progs/engtest.pl: -------------------------------------------------------------------------------- 1 | :-[allperms]. 2 | 3 | go1:- 4 | write(starting),nl, 5 | create_engine(256,64,64,E1), 6 | write(create=E1),nl, 7 | create_engine(128,64,64,E2), 8 | write(create=E2),nl, 9 | destroy_engine(E1), 10 | destroy_engine(E2), 11 | write(kill=E1+E2),nl. 12 | 13 | new_engine(E):-create_engine(256,64,64,E). 14 | 15 | go2:-create_engine(256,64,64,E1),create_engine(100,32,32,E2), 16 | load_engine(E1, append([1,2],[3,4],Xs), Xs), 17 | ask_engine(E1,R1),write(R1),nl, 18 | load_engine(E2, (statistics,append(As,Bs,[A,B,B,A])), As+Bs), 19 | ask_engine(E2,R2),write(R2),nl, 20 | destroy_engine(E2), 21 | destroy_engine(E1). 22 | 23 | go3:- 24 | create_engine(256,64,64,E), 25 | G=append(As,Bs,[A,B,B,A]), 26 | load_engine(E,G,As+Bs), 27 | ask_engine(E,R1),copy_term(R1,C1), 28 | write(G=>R1),nl, 29 | ask_engine(E,R2),copy_term(R2,C2), 30 | write(C1),nl, 31 | write(C2),nl, 32 | ask_engine(E,R),write(R),nl, 33 | ask_engine(E,R),write(R),nl, 34 | load_engine(E,member(X,[1,2,3]),X), 35 | ask_engine(E,S),write(S),nl, 36 | ask_engine(E,S1),write(S1),nl, 37 | ask_engine(E,S2),write(S2),nl, 38 | (ask_engine(E,R)->write(R),nl;true), 39 | destroy_engine(E). 40 | 41 | go4:- 42 | create_engine(256,64,64,E), 43 | load_engine(E,(go;statistics),true), 44 | ask_engine(E,true). 45 | 46 | go5:- 47 | create_engine(256,64,64,E), 48 | load_engine(E,append(As,Bs,[A,B,B,A]),As+Bs), 49 | ask_engine(E,R1),write(R1),nl, 50 | ask_engine(E,R2),write(R2),nl, 51 | load_engine(E,member(X,[1,2,3]),X), 52 | ask_engine(E,R3),write(R3),nl, 53 | ask_engine(E,R4),write(R4),nl, 54 | destroy_engine(E). 55 | 56 | make_engine(Goal,Answer,E):- 57 | new_engine(E), 58 | load_engine(E,Goal,Answer). 59 | 60 | suspend:-suspend_engine(0). 61 | 62 | consume(X):-repeat,suspend,nonvar(X),assert(answer(X)),!. 63 | 64 | produce(X):-perm([1,2,3],X),suspend,write(after),nl. 65 | 66 | go6:- 67 | make_engine(produce(X),X,P),write(prolog_engine=P),nl, 68 | make_engine(consume(X),X,C),write(prolog_engine=C),nl, 69 | multitask_engines(5000), 70 | % ask_engine(P,R), 71 | % ask_engine(C,R), 72 | listing. 73 | 74 | 75 | -------------------------------------------------------------------------------- /src/oper.pl: -------------------------------------------------------------------------------- 1 | :-op(1000,xfy,','). 2 | :-op(1100,xfy,(';')). 3 | 4 | :-op(1200,xfx,('-->')). 5 | :-op(1200,xfx,(':-')). 6 | :-op(1200,fx,(':-')). 7 | :-op(700,xfx,'is'). 8 | :-op(700,xfx,'='). 9 | 10 | :-op(1050,xfx,(@@)). 11 | 12 | :-op(500,yfx,'-'). 13 | :-op(200,fy,'-'). 14 | 15 | :-op(500,yfx,'+'). 16 | :-op(200,fy,'+'). 17 | 18 | :-op(400,yfx,'/'). 19 | :-op(400,yfx,'*'). 20 | :-op(400,fx,'*'). 21 | :-op(400,yfx,(mod)). 22 | :-op(200,yfx,(**)). 23 | :-op(200,xfy,(^)). 24 | 25 | :-op(300,fy,(~)). 26 | :-op(650,xfy,'.'). 27 | :-op(660,xfy,'++'). 28 | 29 | :-op(700,xfx,'>='). 30 | :-op(700,xfx,'>'). 31 | :-op(700,xfx,'=<'). 32 | :-op(700,xfx,(<)). 33 | :-op(700,xfx,(=\=)). 34 | :-op(700,xfx,(=:=)). 35 | 36 | :-op(400,yfx,(>>)). 37 | :-op(400,yfx,(<<)). 38 | :-op(400,yfx,(//)). 39 | 40 | :-op(200,yfx,(\/)). 41 | :-op(200,yfx,(/\)). 42 | :-op(200,yfx,(\)). 43 | :-op(200,fx,(\)). 44 | 45 | :-op(700,xfx,(@>=)). 46 | :-op(700,xfx,(@=<)). 47 | :-op(700,xfx,(@>)). 48 | :-op(700,xfx,(@<)). 49 | 50 | :-op(700,xfx,(\==)). 51 | :-op(700,xfx,(==)). 52 | :-op(700,xfx,(=..)). 53 | :-op(700,xfx,(\=)). 54 | 55 | :-op(900,fy,(not)). 56 | :-op(900,fy,(\+)). 57 | :-op(900,fx,(spy)). 58 | :-op(900,fx,(nospy)). 59 | 60 | :-op(950,fx,(##)). 61 | 62 | :-op(950,xfy,(=>)). 63 | :-op(950,xfx,(<=)). 64 | 65 | :-op(1050,xfy,(->)). 66 | 67 | /* 68 | :-op(1150,fx,(dynamic)). 69 | :-op(1150,fx,(public)). 70 | :-op(1150,fx,(module)). 71 | :-op(1150,fx,(mode)). 72 | :-op(1150,fx,(multifile)). 73 | :-op(1150,fx,(discontiguous)). 74 | */ 75 | 76 | :-op(850,fx,(dynamic)). 77 | :-op(850,fx,(public)). 78 | :-op(850,fx,(module)). 79 | :-op(850,fx,(mode)). 80 | :-op(850,fx,(multifile)). 81 | :-op(850,fx,(discontiguous)). 82 | 83 | :-op(1200,xfx,(::-)). 84 | 85 | :-op(50,yfx,(:)). 86 | 87 | % :-op(1200,fx,(?-)). 88 | 89 | :-op(100,fx,(@)). 90 | 91 | :-op(25,xfx,(@)). 92 | 93 | :-op(200,fx,(?)). 94 | 95 | :-op(50,fx,(^)). 96 | 97 | :-op(500,fx,(#>)). 98 | :-op(500,fx,(#<)). 99 | :-op(500,fx,(#:)). 100 | :-op(500,fx,(#+)). 101 | :-op(500,fx,(#*)). 102 | :-op(500,fx,(#=)). 103 | :-op(500,fx,(#-)). 104 | :-op(500,fx,(#?)). 105 | 106 | 107 | 108 | -------------------------------------------------------------------------------- /progs/bfmeta.pl: -------------------------------------------------------------------------------- 1 | :-op(600,xfx,<=). 2 | 3 | clauses([ 4 | app([],A,A,B)<=B, 5 | app([C|D],E,[C|F],G)<=app(D,E,F,G), 6 | 7 | nrev([],[],H)<=H, 8 | nrev([I|J],K,L)<=nrev(J,M,app(M,[I],K,L)), 9 | 10 | perm([],[],N)<=N, 11 | perm([O|P],Q,R)<=perm(P,S,ins(O,S,Q,R)), 12 | 13 | ins(T,U,[T|U],V)<=V, 14 | ins(W,[X|Y],[X|Z],X0)<=ins(W,Y,Z,X0) 15 | ]). 16 | 17 | all_(G,R):-clauses(C),all_instances(G,C,R). 18 | 19 | all_instances(Goal,Clauses,Answers):- 20 | derive_all([Goal<=Goal],Clauses,[],Answers). 21 | 22 | % derives all answers until there is no Arrow=(Answer<=Goal) left 23 | 24 | derive_all([],_,As,As). 25 | derive_all([Arrow|Fs],Cs,OldAs,NewAs):- 26 | derive_one(Arrow,Cs,Fs,NewFs,OldAs,As), 27 | derive_all(NewFs,Cs,As,NewAs). 28 | 29 | % if Answer<=true has been deduced then keep answer 30 | % else replace Answer<=Goal with its consequences Answer<=Body 31 | % obtained from input clauses of the form Goal<=Body 32 | 33 | derive_one(Answer<=true,_,Fs,Fs,As,[Answer|As]). 34 | derive_one(Answer<=Goal,Cs,Fs,NewFs,As,As):-Goal\==true, 35 | match_all(Cs,Answer<=Goal,Fs,NewFs). 36 | 37 | match_all([],_,Fs,Fs). 38 | match_all([Clause|Cs],Arrow,Fs1,Fs3):- 39 | match_one(Arrow,Clause,Fs1,Fs2), 40 | match_all(Cs,Arrow,Fs2,Fs3). 41 | 42 | % basic inference step 43 | 44 | match_one(F1,F2,Fs,[F3|Fs]):-compose(F1,F2,F3),!. 45 | match_one(_,_,Fs,Fs). 46 | 47 | /* 48 | compose(F1,F2,A<=C):- 49 | write(F1+F2=before),nl, 50 | copy_term(F1,A<=B), 51 | write(after(A<=B)),nl, 52 | copy_term(F2,B<=C),write(F1+F2=(A<=C)),nl 53 | . 54 | */ 55 | 56 | compose(A<=B1,B2<=C,R):-findall(A<=C,B1=B2,[R]). 57 | 58 | time(G,T):-statistics(runtime,_),G,!,statistics(runtime,[_,T]). 59 | 60 | i1:-G=nrev([a(X),b,c(X)],_,true), all_(G,R),write(R),nl. 61 | 62 | i2:-G=app(_,_,[a,b],true), all_(G,R),statistics,write(R),nl. 63 | 64 | i3:-G=perm([a,b,c],_,true), all_(G,R),statistics,write(R),nl. 65 | 66 | integers([],I,I):-!. 67 | integers([I0|L],I0,I):-I0 ex,[';']. 14 | 15 | ex --> term,terms. 16 | 17 | terms --> []. 18 | terms --> aterm,terms. 19 | 20 | aterm --> ['+'],term. 21 | aterm --> ['-'],term. 22 | 23 | term --> factor,factors. 24 | 25 | factors --> []. 26 | factors --> mfactor,factors. 27 | 28 | mfactor --> ['*'],factor. 29 | mfactor --> ['/'],factor. 30 | 31 | factor --> [id], subfactors. 32 | factor --> ['('], ex, [')']. 33 | 34 | subfactors --> []. 35 | subfactors --> ['('], ex, exs, [')']. 36 | 37 | exs --> []. 38 | exs --> [','],ex,exs. 39 | 40 | 41 | % equivalent HAG 42 | 43 | axiom :- ex, #(';'). 44 | 45 | ex :- term,terms. 46 | 47 | terms. 48 | terms :- aterm,terms. 49 | 50 | aterm:- #('+'),term. 51 | aterm:- #('-'),term. 52 | 53 | term :- factor,factors. 54 | 55 | factors. 56 | factors :- mfactor,factors. 57 | 58 | mfactor :- #('*'),factor. 59 | mfactor :- #('/'),factor. 60 | 61 | factor :- #id, subfactors. 62 | factor :- #('('), ex, #(')'). 63 | 64 | subfactors. 65 | subfactors :- #('('), ex, exs, #(')'). 66 | 67 | exs. 68 | exs :- #(',') ,ex,exs. 69 | 70 | 71 | % tools for DCG vs. HAG comparison 72 | 73 | dcgs(Xs):-axiom(Xs,[]). 74 | 75 | hags(Xs):-dcg_def(Xs),axiom,dcg_val([]). 76 | 77 | dummy(_):-fail. 78 | 79 | terminal(id). 80 | terminal('+'). 81 | terminal('-'). 82 | terminal('*'). 83 | terminal('/'). 84 | terminal(','). 85 | terminal('('). 86 | terminal(')'). 87 | terminal(';'). 88 | 89 | generate(0,[]). 90 | generate(N,[X|Xs]):-N>0,N1 is N-1,generate(N1,Xs),terminal(X). 91 | 92 | do(N,Goal):- 93 | write(begin(N)),nl, 94 | generate(N,Xs), 95 | arg(1,Goal,Xs), 96 | Goal, 97 | writeln(Xs), 98 | fail. 99 | do(N,_):-write(end(N)),nl. 100 | 101 | writeln([]):-nl. 102 | writeln([X|Xs]):-write(X),writeln(Xs). 103 | 104 | time(T):-statistics(runtime,[T,_]). 105 | 106 | test(N,Mes,Goal):- 107 | time(T0), 108 | do(N,dummy(_)), 109 | time(T1), 110 | do(N,Goal), 111 | time(T2), 112 | T is (T2-T1)-(T1-T0), 113 | write(Mes=time(T)),nl,nl. 114 | -------------------------------------------------------------------------------- /library/small_kernel_prolog.pl: -------------------------------------------------------------------------------- 1 | % Kernel Prolog - defining Prolog in terms of Horn Clauses + Engines 2 | % see demo at http://pc87043.csci.unt.edu/bp_cgi/kernel_prolog/query.html 3 | 4 | 5 | % interface with existing BinProlog functionality 6 | 7 | new_engineK(Goal,AnswerPattern,Handle):- 8 | open_engine(Goal,AnswerPattern,Handle). 9 | 10 | new_answerK(Engine,Answer):- 11 | ask_engine(Engine,X)->Answer=the(X) 12 | ; Answer=no. 13 | 14 | % basic kernel Prolog definitions 15 | first_solutionK(X,G,Answer):- 16 | new_engineK(G,X,E), 17 | new_answerK(E,R), 18 | destroy_engine(E), % ensures early gc 19 | Answer=R. 20 | 21 | onceK(G):-first_solutionK(G,G,the(G)). 22 | 23 | notK(G):-first_solutionK(_,G,no). 24 | 25 | copy_termK(X,CX):-first_solutionK(X,true,the(CX)). 26 | 27 | ifK(Cond,Then,Else):- 28 | first_solutionK(successful(Cond,Then),Cond,R), 29 | select_then_else(R,Cond,Then,Else). 30 | 31 | findallK(X,G,Xs):- 32 | new_engineK(G,X,E), 33 | new_answerK(E,Answer), 34 | collect_all_answersK(Answer,E,Xs). 35 | 36 | collect_all_answersK(no,_,[]). 37 | collect_all_answersK(the(X),E,[X|Xs]):- 38 | new_answerK(E,Answer), 39 | collect_all_answersK(Answer,E,Xs). 40 | 41 | % this shows that meta cals can be seen as instances of engine operations 42 | callK(Goal):- 43 | new_engineK(Goal,Goal,E), 44 | collect_callK(E,Goal). 45 | 46 | collect_callK(E,Goal):- 47 | new_answerK(E,the(Answer)), 48 | collect_moreK(E,Answer,Goal). 49 | 50 | collect_moreK(_,Answer,Answer). 51 | collect_moreK(E,_,Answer):-collect_callK(E,Answer). 52 | 53 | varK(X):-copy_termK(X,a),copy_termK(X,b). 54 | 55 | variant_ofK(Term,Variant):- 56 | copy_termK(Term,T1), 57 | copy_termK(Variant,T2), 58 | numbervarsK(T1,T), 59 | numbervarsK(T2,T). 60 | 61 | engine_memberK(E,Answer):- 62 | new_answerK(E,the(X)), 63 | other_engine_memberK(E,X,Answer). 64 | 65 | other_engine_memberK(_,Answer,Answer). 66 | other_engine_memberK(E,_,Answer):- 67 | engine_memberK(E,Answer). 68 | 69 | engine_unionK(Es,Answer):- 70 | member(E,Es), 71 | engine_memberK(E,Answer). 72 | 73 | memo_transformerK(BaseEngine,list_engine(Xs)):- 74 | findallK(X,engine_memberK(BaseEngine,X),Xs). 75 | 76 | new_memo_engineK(list_engine(Xs),E):- 77 | new_engineK(member(X,Xs),X,E). 78 | 79 | % data-structure to engine transformer 80 | list_engineK(Xs,E):- 81 | new_engineK(member(X,Xs),X,E). 82 | 83 | -------------------------------------------------------------------------------- /progs/fperms.pl: -------------------------------------------------------------------------------- 1 | perms([],T,R,[T|R]). 2 | perms([X|Xs],T,R):-cycle([],X,Xs,T,R). 3 | 4 | cycle(L,M,[],T,R):-perms(L,[M|T],R). 5 | cycle(L,M,[R|RR],T,P):- 6 | append(L,R,LR), 7 | perms(LR,[M|T], R), 8 | cycle([M|L],R,RR,T,P). 9 | 10 | fperms(Xs,Ps):-perms(Xs,[],[],Ps). 11 | 12 | go:-fperms([1,2,3],Xs),write(Xs),nl,fail. 13 | 14 | /* 15 | 16 | 17 | Although your automatic programming system sounds interesting, that 18 | conclusion would be a bit premature. Here's another program for 19 | generating permutations: 20 | 21 | fun perms ([], tail, res) = tail :: res 22 | | perms (x::xr, tail, res) = cycle([], x, xr, tail, res) 23 | and cycle (left, mid, [], tail, res) = 24 | perms(left, mid::tail, res) 25 | | cycle (left, mid, right as r::rr, tail, res) = 26 | cycle(mid::left, r, rr, tail, perms(left @ right, mid::tail, res)) 27 | 28 | fun fastperms xs = perms(xs, [], []) 29 | 30 | (* The idea is to build the permutations from the tail rather than the 31 | * head of the list; and to use an accumulating parameter for the 32 | * resulting list of permutations; both reduce the number of cons 33 | * operations. 34 | * 35 | * perms(xs, tail, res) = map (fn pm => pm @ tail) xs_perms @ res 36 | * where xs_perms is a list of permutations of xs 37 | *) 38 | 39 | The programs compare as follows under SML/NJ 108.18 (on a Linux/133MHz 40 | Pentium): 41 | 42 | (1) The permutation algorithm generated by adate: 43 | 44 | time (length o f) [1,2,3,4,5,6,7,8,9]; 45 | User: 34.600 System: 3.920 GC: 27.780 Real: 40.425 46 | Memory: 39 MB resident 47 | 48 | (2) The above program: 49 | 50 | time (length o fastperms) [1,2,3,4,5,6,7,8,9]; 51 | User: 11.700 System: 1.240 GC: 8.460 Real: 13.743 52 | Memory: 18 MB resident 53 | 54 | 55 | I have received five permutation programs by e-mail. Asymptotically, the 56 | program written by Peter Sestoft seems to be the fastest. 57 | 58 | Rewritten into the ADATE subset of ML, this program is as follows. 59 | 60 | fun f(Xs) = 61 | let 62 | fun perms(As,Tail,Res) = 63 | case As of 64 | nil => Tail::Res 65 | | X::Xr => cycle(nil, X, Xr, Tail, Res) 66 | and cycle(Left, Mid, Right, Tail1, Res1) = 67 | case Right of 68 | nil => perms(Left,Mid::Tail1,Res1) 69 | | R::Rr => 70 | cycle(Mid::Left, R, Rr, Tail1, perms(Left@Right, Mid::Tail1, Res1)) 71 | in 72 | perms(Xs, nil, nil) 73 | end 74 | 75 | 76 | */ 77 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | #include "global.h" 2 | 3 | #if VCCDLL 4 | /* 5 | #define DLL_EXPORT(Type) __declspec(dllexport) Type __stdcall 6 | */ 7 | #define DLL_EXPORT(Type) __declspec(dllexport) Type __cdecl 8 | #else 9 | #define DLL_EXPORT(Type) Type 10 | #endif 11 | 12 | extern void bp_exit_mes(string mes, bp_long i); 13 | extern void *init_bp0(bp_long argc, char **argv,FILE* bp_stdin,FILE* bp_stdout); 14 | extern char *run_bp0(register stack wam,char *query,bp_long *retcode); 15 | 16 | DLL_EXPORT(void*) init_bp(bp_long argc, char **argv, FILE* bp_stdin, FILE* bp_stdout) { 17 | 18 | char *default_argv[]={"bp.dll",NULL}; 19 | char **bp_argv; 20 | if(NULL==bp_stdin) bp_stdin=stdin; 21 | if(NULL==bp_stdout) bp_stdout=stdout; 22 | if(NULL==argv) { 23 | bp_argv=default_argv; 24 | argc=1; 25 | } 26 | else 27 | bp_argv=argv; 28 | 29 | return init_bp0(argc, bp_argv, bp_stdin, bp_stdout); 30 | } 31 | 32 | DLL_EXPORT(char*) run_bp(void *wam, char *query) { 33 | bp_long retcode=0; 34 | return run_bp0((stack)wam,query,&retcode); /* ignores retcode */ 35 | } 36 | 37 | /* inialisation work in c.c, useful if BinProlog is embedded \ 38 | in a C application 39 | */ 40 | 41 | extern int init_c(void); 42 | 43 | DLL_EXPORT(int) bp_main(int argc, char **argv) 44 | { int ok; bp_long retcode=0; int initcode=0; 45 | void *wam=init_bp(argc,argv,stdin,stdout); 46 | ok=(!!wam); 47 | initcode=init_c(); 48 | printf("Started Prolog Runtime System %d.\n",initcode); 49 | ok=ok && (initcode>0); /* inialise C-code for the host in c.c */ 50 | 51 | if(ok) { 52 | #if 0 53 | /* not used, but possible: see similar code in dir BP_DLL */ 54 | 55 | /* query/answer then stop */ 56 | char *query; 57 | char *answer; 58 | 59 | query="^(X,(for(X,1,5),>(X,2)))"; 60 | answer=run_bp(wam,query); 61 | if(NULL==answer) answer="no"; 62 | printf("query=>%s\nanswer=>%s\n",query,answer); 63 | 64 | query="*(I,for(I,1,10))"; 65 | answer=run_bp(wam,query); 66 | if(NULL==answer) answer="no"; 67 | printf("query=>%s\nanswer=>%s\n",query,answer); 68 | 69 | query="*(:(2,X),member(X,[a,b,c,d]))"; 70 | answer=run_bp(wam,query); 71 | if(NULL==answer) answer="no"; 72 | printf("query=>%s\nanswer=>%s\n",query,answer); 73 | 74 | ok=1; 75 | #else 76 | run_bp0(wam,NULL,&retcode); /* plain toplevel: keeps retcode info */ 77 | #endif 78 | } 79 | else 80 | retcode=!ok; 81 | bp_exit_mes("halted, code",retcode); 82 | return retcode; 83 | } 84 | -------------------------------------------------------------------------------- /progs/cube.pl: -------------------------------------------------------------------------------- 1 | /*---------------------------------------------------------------------------- 2 | Program: Instant Insanity (fused gen & test) 3 | Author: E. Tick 4 | Date: August 26 1989 5 | 6 | Notes: 7 | 1. To run: 8 | ?- go(7,N,T,S). 9 | where output S is the list of solutions, N=48 the number of solutions 10 | (for 7-cubes), and T is the execution time. 11 | -------------------------------------------------------------------- 12 | :- sequential. 13 | :- parallel set/2, rotate/3. 14 | */ 15 | p:-[cube]. 16 | 17 | go:-go('BMARK_cube:'). 18 | 19 | go(Mes):-go(7,N,T,_S),write(Mes=[sols=N,time=T]),nl. 20 | 21 | go(C,N,T,S) :- time(_), 22 | findall(X,sol(C,X),S), count(S,N), 23 | time(T). 24 | 25 | sol(C,X) :- cubes(C,Q), sol(Q,[],X). 26 | 27 | sol([],A,A). 28 | sol([Q|Qs],A,F) :- 29 | set_cube(Q,P), 30 | check(A,P), 31 | sol(Qs,[P|A],F). 32 | 33 | check([],_). 34 | check([q(A1,B1,C1,D1)|As],P) :- 35 | P = q(A2,B2,C2,D2), 36 | A1 =\= A2, B1 =\= B2, C1 =\= C2, D1 =\= D2, 37 | check(As,P). 38 | 39 | set_cube(q(P1,P2,P3),P) :- rotate(P1,P2,P). 40 | set_cube(q(P1,P2,P3),P) :- rotate(P2,P1,P). 41 | set_cube(q(P1,P2,P3),P) :- rotate(P1,P3,P). 42 | set_cube(q(P1,P2,P3),P) :- rotate(P3,P1,P). 43 | set_cube(q(P1,P2,P3),P) :- rotate(P2,P3,P). 44 | set_cube(q(P1,P2,P3),P) :- rotate(P3,P2,P). 45 | 46 | rotate(p(C1,C2),p(C3,C4),q(C1,C2,C3,C4)). 47 | rotate(p(C1,C2),p(C3,C4),q(C1,C2,C4,C3)). 48 | rotate(p(C1,C2),p(C3,C4),q(C2,C1,C3,C4)). 49 | rotate(p(C1,C2),p(C3,C4),q(C2,C1,C4,C3)). 50 | 51 | cubes(4,[q(p(0,1),p(2,0),p(1,3)), 52 | q(p(3,3),p(2,0),p(1,2)), 53 | q(p(0,3),p(3,1),p(1,2)), 54 | q(p(0,0),p(3,0),p(1,2))]). 55 | cubes(5,[q(p(2,1),p(1,4),p(3,1)), 56 | q(p(3,2),p(2,0),p(3,4)), 57 | q(p(1,4),p(3,1),p(0,4)), 58 | q(p(1,0),p(2,2),p(0,4)), 59 | q(p(4,2),p(4,3),p(0,3))]). 60 | cubes(6,[q(p(0,5),p(1,5),p(3,1)), 61 | q(p(2,1),p(3,4),p(4,0)), 62 | q(p(3,0),p(4,5),p(2,4)), 63 | q(p(1,3),p(5,1),p(0,1)), 64 | q(p(0,2),p(0,2),p(5,2)), 65 | q(p(4,4),p(2,3),p(4,5))]). 66 | cubes(7,[q(p(5,1),p(0,5),p(3,1)), 67 | q(p(2,3),p(1,4),p(4,0)), 68 | q(p(3,6),p(0,0),p(2,4)), 69 | q(p(6,4),p(6,1),p(0,1)), 70 | q(p(1,5),p(3,2),p(5,2)), 71 | q(p(5,0),p(2,3),p(4,5)), 72 | q(p(4,2),p(2,6),p(0,3))]). 73 | 74 | time(T) :- statistics(runtime,[_,T]). 75 | 76 | count(L,N) :- count(L,0,N). 77 | count([],N,N). 78 | count([X|Xs],M,N) :- M1 is M+1, count(Xs,M1,N). 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /progs/dcomp.pl: -------------------------------------------------------------------------------- 1 | make_static(F/N):- 2 | functor(H,F,N), 3 | is_asserted(H), 4 | make_undefined(H), 5 | make_static1(F/N), 6 | !. 7 | make_static(FN):- 8 | errmes(unable_to,make_static(FN)). 9 | 10 | restore_dynamic(F/N):- 11 | functor(H,F,N), 12 | enable(F/N), 13 | make_undefined(H), 14 | !. 15 | restore_dynamic(FN):- 16 | errmes(unable_to,restore_dynamic(FN)). 17 | 18 | make_static1(F/N):- 19 | vget0(code_top,Top), 20 | vget0(code_oldtop,OldTop), 21 | vset(code_oldtop,Top), 22 | make_static0(F/N), 23 | 'prolog:terminate_file'(mem,1), 24 | disable(F/N), % if we disable before, it becomes strongly linked!!! 25 | vset(code_oldtop,OldTop). 26 | 27 | make_static0(F/N):- 28 | a_clause(F/N,C), 29 | 'prolog:maincomp'(mem,C), 30 | fail. 31 | make_static0(_). 32 | 33 | a_clause(F/N,(H:-B)):- 34 | functor(H,F,N), 35 | clause(H,B). 36 | 37 | make_undefined(H):-is_compiled(H),!,override(2,H,fail). 38 | make_undefined(_). 39 | 40 | disable(FN):- 41 | current_db(DB), 42 | db_disable(DB,FN). 43 | 44 | enable(FN):- 45 | current_db(DB), 46 | db_enable(DB,FN). 47 | 48 | db_disable(DB,F/N):- 49 | functor(P,F,N), 50 | val(DB,P,Adr), 51 | def(P,DB,Adr), 52 | rm(DB,P). 53 | 54 | db_enable(DB,F/N):- 55 | functor(P,F,N), 56 | val(P,DB,Adr), 57 | def(DB,P,Adr), 58 | rm(P,DB). 59 | 60 | 61 | % ----------------- 62 | test:- 63 | consult(nrev30), 64 | make_static(app/3), 65 | list_asm(app,3,20), 66 | make_static(nrev/2), 67 | list_asm(nrev,2,20), 68 | go. 69 | 70 | g1:- 71 | vget0(code_top,Top), 72 | vget0(code_oldtop,OldTop), 73 | vset(code_oldtop,Top), 74 | ( translate_clause((a(13):-true),mem) 75 | ; translate_clause((a(14):-true),mem) 76 | ; 'prolog:terminate_file'(mem,1) 77 | ), 78 | vset(code_oldtop,OldTop), 79 | list_asm(a,1,10). 80 | 81 | 82 | g2:- 83 | vget0(code_top,Top), 84 | vget0(code_oldtop,OldTop), 85 | vset(code_oldtop,Top), 86 | ( translate_clause((b(X):-a(X)),mem) 87 | ; translate_clause((b(15):-true),mem) 88 | ; 'prolog:terminate_file'(mem,1) 89 | ), 90 | vset(code_oldtop,OldTop), 91 | list_asm(b,1,10). 92 | 93 | bug:- 94 | assert(buggy(1)), 95 | vget0(code_top,Top), 96 | vget0(code_oldtop,OldTop), 97 | vset(code_oldtop,Top), 98 | ( translate_clause((buggy(2):-true),mem) 99 | ; 'prolog:terminate_file'(mem,1) 100 | ), 101 | vset(code_oldtop,OldTop), 102 | list_asm(buggy,1,10). 103 | 104 | -------------------------------------------------------------------------------- /progs/nrev.pl: -------------------------------------------------------------------------------- 1 | app([],Ys,Ys). 2 | app([A|Xs],Ys,[A|Zs]):- 3 | app(Xs,Ys,Zs). 4 | 5 | nrev([],[]). 6 | nrev([X|Xs],Zs):- 7 | nrev(Xs,Ys), 8 | app(Ys,[X],Zs). 9 | 10 | fnrev([],[]). 11 | fnrev([X|Xs],Zs):- 12 | fnrev(Xs,Ys), 13 | det_app(Ys,[X],Zs). 14 | 15 | full_range(It,L):- range(_,1,It),nrev(L,_),fail. 16 | full_range(_,_). 17 | 18 | dummy(_,_). 19 | 20 | empty_range(It,L):-range(_,1,It),dummy(L,_),fail. 21 | empty_range(_,_). 22 | 23 | range(Min,Min,Max):-Min=Query=Goal,Answer=Vars 28 | ; QueryTerm=(Vars^Goal)->Query=Goal,Answer=Vars 29 | ; QueryTerm=the(Vars,Goal)->Query=the(Vars,Goal,Answer) 30 | ; QueryTerm=(K:Vars*Goal),nonvar(K)->Query=find_at_most(K,Vars,Goal,List),Answer=List 31 | ; QueryTerm=(Vars*Goal)->Query=findall(Vars,Goal,List),Answer=List 32 | ; Query=the(QueryTerm,QueryTerm,Answer) % NEW from 7.36 ! 33 | ), 34 | ( topcall(Query)->AnswerTerm=Answer 35 | ; AnswerTerm=no 36 | ). 37 | 38 | the(X,G,R):-copy_term(the(X,G),the(NewX,NewG)),NewG,!,R=the(NewX). 39 | the(_,_,no). 40 | 41 | the(X,G):-the(X,G,the(X)). 42 | the(G):-the(G,G). 43 | 44 | % LOCAL OR REMOTE TOPLEVEL 45 | 46 | toplevel:- 47 | % quiet(2), 48 | repeat, 49 | topstep('?- '), 50 | fail. 51 | 52 | topstep(Prompt):- 53 | ttyprin(Prompt),flush, 54 | ttyin(top_read_term(Body,Vs)), 55 | report_answers(Vs,Body,YN), 56 | ttyprint(YN). 57 | 58 | report_answers([],Goal,YN):- 59 | topcall(Goal)->YN=yes 60 | ; YN=no. 61 | report_answers([V|Vs],Goal,YN):- 62 | ask_answers(Goal,[V|Vs],YN). 63 | 64 | ask_answers(Goal,[V|Vs],YN):- 65 | topcall(Goal), 66 | report_one_var(V),report_top_vars(Vs), 67 | another_sol(Ok), 68 | ( Ok=no,!,YN=yes 69 | ; fail 70 | ) 71 | ; YN=no,!. 72 | 73 | report_top_vars(Eqs):- 74 | member(Eq,Eqs), 75 | ttyprint(','),report_one_var(Eq), 76 | fail. 77 | report_top_vars(_). 78 | 79 | report_one_var(V=E):- 80 | ttyprin(V),ttyprin(=),ttyout(writeq(E)). 81 | 82 | another_sol(Ok):- 83 | is_interactive,!, 84 | ttyin(get_code(A)),user_action(A,Ok),ttynl. 85 | another_sol(yes):-ttyprint(';'),ttynl. 86 | 87 | user_action(10,no):-!. 88 | user_action(59,yes):-!,ttyin(get_code(10)). 89 | user_action(_,Ok):-ttyprin(' ; for more, otherwise '), 90 | ttyin(get_code(10)),ttyin(get_code(U)),user_action(U,Ok). 91 | 92 | -------------------------------------------------------------------------------- /library/catch_cont.pl: -------------------------------------------------------------------------------- 1 | go:-catch(go2,Any,println(uncought=Any)). 2 | 3 | go2:- 4 | catch( 5 | ( member(X,[a,f(A,A),c]), 6 | X=f(_,_), 7 | println(before_throw=X), 8 | throw(goooot(X)), 9 | println(after_trow) 10 | ), 11 | got(Y), 12 | println(cought(Y)) 13 | ), 14 | println(after(caught(Y))). 15 | 16 | ignore(_). 17 | 18 | go1:-consume_cont(println,boo),println(one),println(two),ignore(boo),println(hi). 19 | 20 | /* implementation of catch/throw - with first order continuations 21 | 22 | catch(Goal,Ball,Do,Cont) ::- catch0(Goal,Ball,Do,Cont,Cont) . 23 | catch(_,_,_) :- fail . 24 | 25 | catch0(Goal,Ball,Do,Cont) :- 26 | get_neck_cut(Choice), 27 | Goal, 28 | '$to_catch'('$catch_looking_for_throw'([Ball,Do,Choice,Cont])). 29 | 30 | '$to_catch'(_). 31 | 32 | '$process_catch'(Term,[Ball,Do,Choice,Cont],_):-copy_term(Term,Copy), 33 | % println(found(Term=Ball,Do)), 34 | untrail_to(Choice), 35 | do_or_throw_again(Term,Copy,Ball,Do,Cont). 36 | 37 | 38 | throw(Term):-consume_cont('$process_catch'(Term,X),'$catch_looking_for_throw'(X)). 39 | 40 | throw_with_cont(Term,Cont,_)::-throw(Term,Cont). 41 | 42 | do_or_throw_again(_Term,Ball,Ball,Do,Cont):- !,Do,call_cont(Cont). 43 | do_or_throw_again(Term,_Ball,_Copied,_Do,Cont):-throw_with_cont(Term,Cont). 44 | 45 | % gathers in conjunction goals from the current continuation 46 | % until Marker is reached when it calls Closure ont it 47 | consume_cont(Closure,Marker):- 48 | get_cont(Cont), 49 | consume_cont1(Marker,(_,_,_,Cs),Cont,NewCont), % first _ 50 | call(Closure,Cs), % second _ 51 | % sets current continuation to leftover NewCont 52 | call_cont(NewCont). % third _ 53 | 54 | % gathers goals in Gs until Marker is hit in continuation Cont 55 | % when leftover LastCont continuation (stripped of Gs) is returned 56 | consume_cont1(Marker,Gs,Cont,LastCont):- 57 | strip_cont(Cont,Goal,NextCont), 58 | ( nonvar(NextCont),NextCont=true-> !,errmes(in_consume_cont,expected_marker(Marker)) 59 | ; arg(1,NextCont,X),nonvar(X),Marker=X-> 60 | Gs=Goal,arg(2,NextCont,LastCont) 61 | ; Gs=(Goal,OtherGs), 62 | consume_cont1(Marker,OtherGs,NextCont,LastCont) 63 | ). 64 | 65 | % this `binarized clause' gets the current continuation 66 | get_cont(Cont,Cont)::-true(Cont). 67 | 68 | % setes calls NewCont as continuation to be called next 69 | call_cont(NewCont,_) ::- true(NewCont). 70 | 71 | % sets NewCont as continuation to be called next 72 | % instead of OldCont which is returned in arg 2 73 | swap_cont(NewCont,OldCont,OldCont) ::- true(NewCont). 74 | */ 75 | -------------------------------------------------------------------------------- /progs/allperms.pl: -------------------------------------------------------------------------------- 1 | fast_findall(X,G,Xs):-findall(X,G,Xs). 2 | 3 | all_permutations([],[[]]). 4 | all_permutations([X|Xs],Perms2):- 5 | all_permutations(Xs,Perms1), 6 | extend_permutations(Perms1,X,Perms2). 7 | 8 | extend_permutations([],_,[]). 9 | extend_permutations([Perm|Perms1],X,[[X|Perm]|Perms3]):- 10 | extend_permutations(Perms1,X,Perms2), 11 | insert_item(Perm,X,[],Perms2,Perms3). 12 | 13 | insert_item([],_,_,Perms,Perms). 14 | insert_item([Y|Ys],X,Acc,Perms1,[Zs|Perms2]):- 15 | reverse_and_append(Acc,[Y,X|Ys],Zs), 16 | insert_item(Ys,X,[Y|Acc],Perms1,Perms2). 17 | 18 | reverse_and_append([],Acc,Acc). 19 | reverse_and_append([X|Xs],Acc,Zs):- 20 | reverse_and_append(Xs,[X|Acc],Zs). 21 | 22 | nats(Max,Max,[Max]):-!. 23 | nats(Curr,Max,[Curr|Ns]):- 24 | Curr$(PROJ).ps 54 | dvips $(PROJ) 55 | 56 | dvi: $(PROJ).dvi 57 | yap $(PROJ).dvi 58 | 59 | ps: $(PROJ).ps 60 | 61 | psview: 62 | #ghostview -swap -magstep 0 $(PROJ).ps 63 | #gw $(PROJ).ps 64 | #pageview $(PROJ).ps 65 | 66 | txt: $(PROJ).txt 67 | 68 | $(PROJ).txt: 69 | dvi2tty -l -w112 $(PROJ).dvi > $(PROJ).txt 70 | 71 | pdf $(PROJ).pdf: $(PROJ).tex 72 | toPDF.bat $(PROJ) 73 | 74 | html $(PROJ).html: $(PROJ).tex 75 | tth.exe <$(PROJ).tex >$(PROJ).html -L$(PROJ) -a -e1 76 | 77 | preds preds.tex: ../src/headers.pl 78 | bp -h40000 -s2000 -t2000 -b40000 preds.pro 79 | 80 | 81 | oldhtml: art.tex preds.tex 82 | rm -f -r html 83 | latex2html -split 2 -link 2 -contents_in_navigation -show_section_numbers -bottom_navigation art.tex 84 | mv art html 85 | (cd html; ln -s ../icons .) 86 | (cd html; perl -n -i.bak -e "s{/opt/tools/latex2html-95.3/}{}g;print;" *.html) 87 | (cd html; rm -f *.bak) 88 | 89 | 90 | print: art.ps 91 | lpr art.ps 92 | 93 | see: art.tex 94 | dvi2tty -l -w112 art 95 | 96 | wc: 97 | dvi2tty -l -w132 art | wc 98 | 99 | clean: 100 | rm -f crossref.ps *.aux *.blg *.log *.dlog *.bbl *.dvi 101 | 102 | realclean: clean 103 | rm -f *.bbl *.dvi *.ps *.html 104 | 105 | -------------------------------------------------------------------------------- /progs/dlg.pl: -------------------------------------------------------------------------------- 1 | % Requires BinProlog 5.40 2 | 3 | % Datalog `preprocessor' : made obsolete by the possibility 4 | % to override BinProlog's generic Assumption Grammar mechanism. 5 | % well, the DCG preprocessor is made obsolete too :-) 6 | 7 | % CODE 8 | 9 | % this defines advancement in Datalog `phrase' given as a set of w/3 facts 10 | 11 | w(X):- 12 | dcg_val(From), 13 | w(From,To,X), 14 | dcg_def(To). 15 | 16 | % this recognizes a phrase From..To 17 | 18 | dlg_phrase(From,To):-dcg_def(From),axiom,dcg_val(To). 19 | 20 | % DATA 21 | 22 | % grammar 23 | 24 | axiom:-ng,v. 25 | 26 | ng:-a,n. 27 | 28 | a:-w(the). 29 | a:-w(a). 30 | 31 | n:-w(cat). 32 | n:-w(dog). 33 | 34 | v:-w(walks). 35 | v:-w(sleeps). 36 | 37 | % recognizing a sentence 38 | 39 | % input phrase in Datalog form 40 | 41 | w(0,1,the). 42 | w(1,2,cat). 43 | w(2,3,walks). 44 | 45 | % TEST 46 | 47 | test:-dlg_phrase(0,3). 48 | 49 | % ?-test. % will answer yes 50 | 51 | /* 52 | ?-reconsult(dlg). 53 | .. 54 | ?-trace(test). 55 | 56 | Call: test 57 | !!! clause: test/0 58 | Call: dlg_phrase(0,3) 59 | !!! clause: dlg_phrase/2 60 | Call: dcg_def(0) 61 | !!! compiled(dcg_def/1) 62 | Exit: dcg_def(0) 63 | Call: axiom 64 | !!! clause: axiom/0 65 | Call: ng 66 | !!! clause: ng/0 67 | Call: a 68 | !!! clause: a/0 69 | Call: w(the) 70 | !!! clause: w/1 71 | Call: dcg_val(_x4907) 72 | !!! compiled(dcg_val/1) 73 | Exit: dcg_val(0) 74 | Call: w(0,_x4903,the) 75 | !!! clause: w/3 76 | Exit: w(0,1,the) 77 | Call: dcg_def(1) 78 | !!! compiled(dcg_def/1) 79 | Exit: dcg_def(1) 80 | Exit: w(the) 81 | Exit: a 82 | Call: n 83 | !!! clause: n/0 84 | Call: w(cat) 85 | !!! clause: w/1 86 | Call: dcg_val(_x6533) 87 | !!! compiled(dcg_val/1) 88 | Exit: dcg_val(1) 89 | Call: w(1,_x6529,cat) 90 | !!! clause: w/3 91 | Exit: w(1,2,cat) 92 | Call: dcg_def(2) 93 | !!! compiled(dcg_def/1) 94 | Exit: dcg_def(2) 95 | Exit: w(cat) 96 | Exit: n 97 | Exit: ng 98 | Call: v 99 | !!! clause: v/0 100 | Call: w(walks) 101 | !!! clause: w/1 102 | Call: dcg_val(_x8159) 103 | !!! compiled(dcg_val/1) 104 | Exit: dcg_val(2) 105 | Call: w(2,_x8155,walks) 106 | !!! clause: w/3 107 | Exit: w(2,3,walks) 108 | Call: dcg_def(3) 109 | !!! compiled(dcg_def/1) 110 | Exit: dcg_def(3) 111 | Exit: w(walks) 112 | Exit: v 113 | Exit: axiom 114 | Call: dcg_val(3) 115 | !!! compiled(dcg_val/1) 116 | Exit: dcg_val(3) 117 | Exit: dlg_phrase(0,3) 118 | Exit: test 119 | 120 | */ 121 | -------------------------------------------------------------------------------- /progs/lattice.pl: -------------------------------------------------------------------------------- 1 | 2 | go:- 3 | statistics(runtime,_), 4 | findall(C,concept(C),Cs), 5 | statistics(runtime,[_,T]), 6 | write(time=T),nl,statistics, 7 | set_member(C,Cs), 8 | write(C),nl, 9 | fail. 10 | go. 11 | 12 | 13 | gen_all:- 14 | findall(X,gen_one(X),Is), 15 | fill_instr(Is,0,_), 16 | pp_is(Is). 17 | 18 | gen_one(wam(_,L)):- 19 | set_member(X,[deep,top]), 20 | set_member(Y,[head,body]), 21 | set_member(Z,[constant,structure,value,variable]), 22 | sort([X,Y,Z],L). 23 | 24 | fill_instr([],N,N). 25 | fill_instr([wam(N1,_)|Is],N1,N2):- 26 | N is N1+1, 27 | fill_instr(Is,N,N2). 28 | 29 | pp_is(Is):-set_member(I,Is),write(I),write('.'),nl,fail. 30 | pp_is(_). 31 | 32 | context(L,R):-lcontext(L,Rs),set_member(R,Rs). 33 | 34 | rcontext(R,Ls):-setof(L,context(L,R),Ls). 35 | 36 | lset(Ls):-findall(L,lcontext(L,_),Ls). 37 | rset(Rs):-findall(R,rcontext(R,_),Rs). 38 | 39 | an_intent([I|Is]):- 40 | lset(Ls), 41 | subset(Ls,Xs), 42 | extent2intent(Xs,[I|Is]). 43 | 44 | intent(Is):- 45 | findall(Is,an_intent(Is),Unsorted), 46 | sort(Unsorted,Iss), 47 | set_member(Is,Iss). 48 | 49 | % Finds the lattice of concepts defined on on context 50 | % as defined at pp. 221-236 in Davey & Priestley, 51 | % Introduction to Lattices and Order (Cambridge Univ. Press, 1990) 52 | % the theory of Formal Concept Analysis is due to R. WILLE 53 | 54 | concept(Es-Is):- 55 | intent(Is), 56 | intent2extent(Is,Es). 57 | 58 | % tools 59 | 60 | extent2intent([X|Xs], Ans) :- lcontext(X,L),intersect_extents(Xs, L, Ans). 61 | 62 | intent2extent([X|Xs], Ans) :- rcontext(X,R),intersect_intents(Xs, R, Ans). 63 | 64 | intersect_extents([], Ans, Ans). 65 | intersect_extents([X|Xs], Ans0, Ans) :- 66 | lcontext(X,L), 67 | ord_intersect(Ans0, L, Ans1), 68 | intersect_extents(Xs, Ans1, Ans). 69 | 70 | intersect_intents([], Ans, Ans). 71 | intersect_intents([X|Xs], Ans0, Ans) :- 72 | rcontext(X,R), 73 | ord_intersect(Ans0, R, Ans1), 74 | intersect_intents(Xs, Ans1, Ans). 75 | 76 | ord_intersect(_, [], []) :- !. 77 | ord_intersect([], _, []) :- !. 78 | ord_intersect([Head1|Tail1], [Head2|Tail2], Intersection) :- 79 | compare(Order, Head1, Head2), 80 | ord_intersect(Order, Head1, Tail1, Head2, Tail2, Intersection). 81 | 82 | ord_intersect(=, Head, Tail1, _, Tail2, [Head|Intersection]) :- 83 | ord_intersect(Tail1, Tail2, Intersection). 84 | ord_intersect(<, _, Tail1, Head2, Tail2, Intersection) :- 85 | ord_intersect(Tail1, [Head2|Tail2], Intersection). 86 | ord_intersect(>, Head1, Tail1, _, Tail2, Intersection) :- 87 | ord_intersect([Head1|Tail1], Tail2, Intersection). 88 | 89 | subset([],[]). 90 | subset([_|Xs],Ys):-subset(Xs,Ys). 91 | subset([X|Xs],[X|Ys]):-subset(Xs,Ys). 92 | 93 | set_member(X,[X|_]). 94 | set_member(X,[_|Xs]):- 95 | set_member(X,Xs). 96 | -------------------------------------------------------------------------------- /progs/calibrate.pro: -------------------------------------------------------------------------------- 1 | go:-calibrate. 2 | 3 | calibrate:- 4 | calibrate(T,Times), 5 | write(T=Times),nl. 6 | 7 | calibrate(T):-calibrate(T,_). 8 | 9 | calibrate(T,Details):-calibrate(30,T,Details). 10 | 11 | calibrate(Multiplier,T,times(lips(LIPS),nrev(TN),perm(TP),assert(TA))):- 12 | Base is 5, 13 | NTimes is Base*Multiplier, 14 | PTimes is Base*Multiplier, 15 | ATimes is Base*Multiplier, 16 | Len is 200, 17 | getctime(TB), 18 | fortest(NTimes), 19 | getctime(T0), 20 | nrevtest(Len,NTimes), 21 | getctime(T1), 22 | permtest(7,PTimes), 23 | getctime(T2), 24 | asserttest(5,ATimes), 25 | getctime(T3), 26 | TF is T0-TB, 27 | TN is T1-T0, 28 | TP is T2-T1, 29 | TA is T3-T2, 30 | T is TN+TP+TA, 31 | LI is (NTimes/1.0001)*(((Len+1)*(Len+2))//2), 32 | TS is (TN-TF)/1000.0001, 33 | LIPS is integer(LI/TS). 34 | 35 | fortest(N):-'$for'(_I,1,N),fail. 36 | fortest(_). 37 | 38 | nrevtest(N,Times):- 39 | findall(I,'$for'(I,1,N),Is), 40 | '$for'(I,1,Times), 41 | '$nrev'(Is,_), 42 | fail. 43 | nrevtest(_N,_Times). 44 | 45 | '$app'([],Ys,Ys). 46 | '$app'([A|Xs],Ys,[A|Zs]):- 47 | '$app'(Xs,Ys,Zs). 48 | 49 | '$nrev'([],[]). 50 | '$nrev'([X|Xs],Zs):- 51 | '$nrev'(Xs,Ys), 52 | '$app'(Ys,[X],Zs). 53 | 54 | permtest(N,Times):- 55 | '$for'(_I,1,Times), 56 | permtest(N), 57 | fail. 58 | permtest(_N,_Times). 59 | 60 | permtest(N):- 61 | findall(I,'$for'(I,1,N),Is), 62 | '$perm'(Is,_), 63 | fail. 64 | permtest(_). 65 | 66 | '$perm'([],[]). 67 | '$perm'([X|Xs],Zs):- 68 | '$perm'(Xs,Ys), 69 | '$insert'(X,Ys,Zs). 70 | 71 | '$insert'(X,Ys,[X|Ys]). 72 | '$insert'(X,[Y|Ys],[Y|Zs]):- 73 | '$insert'(X,Ys,Zs). 74 | 75 | asserttest(MX,MY):- 76 | initboard1(MX,MY), 77 | updateboard1(MX,MY), 78 | accessboard1(MX,MY), 79 | cleanboard1. 80 | 81 | initboard1(MaxX,MaxY):- 82 | '$for'(X,1,MaxX), 83 | '$for'(Y,1,MaxY), 84 | assert('$board'(X,Y,0)), 85 | fail. 86 | initboard1(_,_). 87 | 88 | updateboard1(MaxX,MaxY):- 89 | '$for'(X,1,MaxX), 90 | '$for'(Y,1,MaxY), 91 | update1(X,Y), 92 | fail. 93 | updateboard1(_,_). 94 | 95 | update1(X,Y):- 96 | retract('$board'(X,Y,_)), 97 | !, 98 | assert('$board'(X,Y,1)). 99 | 100 | accessboard1(MaxX,MaxY):- 101 | '$for'(X,1,MaxX), 102 | '$for'(Y,1,MaxY), 103 | '$board'(X,Y,_), 104 | fail. 105 | accessboard1(_,_). 106 | 107 | cleanboard1:- 108 | abolish('$board'/3). 109 | 110 | getctime(T):-statistics(runtime,[T,_]). 111 | 112 | '$for'(Min,Min,Max):-Min=>> '),fast_write(Mes),fast_write(': '), 41 | trim_term(Obj,T), 42 | fast_write(T),nl. 43 | portray_error(pretty,Mes,Obj):- 44 | write('*** '),write(Mes),write(': '),nl, 45 | trim_term(Obj,T), 46 | portray_clause(T). 47 | 48 | nth_member(X,Xs,N):-member_i(X,Xs,1,N). 49 | 50 | member_i(X,[X|_],N,N). 51 | member_i(X,[_|Xs],N1,N3):- 52 | N2 is N1+1, 53 | member_i(X,Xs,N2,N3). 54 | 55 | trim_detail('...'). 56 | 57 | trim_depth(N):-quiet(Q),trim_depth1(Q,N). 58 | 59 | trim_depth1(Q,N):-Q<3,!,N is 6-Q. 60 | trim_depth1(_,3). 61 | 62 | trim_term(T,NewT):-trim_depth(N),trim_term(N,T,NewT). 63 | 64 | trim_term(N,T,NewT):-trim_detail(D),trim_term(N,D,T,NewT). 65 | 66 | trim_term(_,_,T,NewT):-var(T),!,NewT=T. 67 | trim_term(_,_,T,NewT):-atomic(T),!,NewT=T. 68 | trim_term(_,_,T,NewT):-float(T),!,NewT=T. 69 | trim_term(0,NoMore,_,NoMore):-!. 70 | trim_term(N,D,T,NewT):-N1 is N-1, 71 | T=..[F|Xs], 72 | trim_args(Xs,Ys,N1,D), 73 | NewT=..[F|Ys]. 74 | 75 | trim_args([],[],_,_). 76 | trim_args([X|Xs],[Y|Ys],N,D):- 77 | trim_term(N,D,X,Y), 78 | trim_args(Xs,Ys,N,D). 79 | 80 | expand_call_body(Body, 81 | ( 82 | do_body(Body, AfterCut, HadCut), 83 | ( HadCut = yes, 84 | !, 85 | call_body(AfterCut) 86 | ; HadCut = no 87 | ) 88 | ) 89 | ). 90 | 91 | 92 | bp_val(bp_virtual,bu0(_,_,_,_),1). 93 | bp_val(bp_virtual,bu1(_,_),1). 94 | bp_val(bp_virtual,bu_ctr(_,_),1). 95 | 96 | bp_val(bp_virtual,portray_clause(_),2). 97 | bp_val(bp_virtual,portray(_),2). 98 | bp_val(bp_virtual,term_expansion(_,_),2). 99 | bp_val(bp_virtual,trim_detail(_),2). 100 | bp_val(bp_virtual,trim_depth(_),2). 101 | -------------------------------------------------------------------------------- /progs/lsum.pl: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | Hi Veronica and Jamie, 4 | 5 | Here are some thoughts following the linear logic paper and a 6 | previous message. 7 | 8 | Jamie writes: 9 | 10 | >I have been thinking also about some 11 | >possible source-to-source translation for clauses that would 12 | >allow for more efficient compilation. Lygon looks interesting, 13 | >I didn't realize it was based on BinProlog. 14 | 15 | An interesting way to enforce a resource-driven execution to 16 | Prolog programs is the following (# is BinProlog's Hidden Argument 17 | Grammar equivalent of DCGs 'C'/3): 18 | */ 19 | 20 | n(0) :- #t. 21 | n(s(N)):- #t, n(N). 22 | 23 | sum(0,N,N) :- #t. 24 | sum(s(N),M,s(K)):- #t, sum(N,M,K). 25 | 26 | prod(0,_,0) :- #t. 27 | prod(s(N),M,P):- #t, prod(N,M,P1), sum(P1,M,P). 28 | 29 | 30 | make_tokens(N,Ts):-findall(t,for(_,1,N),Ts). 31 | 32 | go(N,X*Y=Z):- 33 | make_tokens(N,Ts), 34 | dcg_def(Ts), 35 | prod(X,Y,Z), 36 | dcg_val([]). 37 | 38 | go:-go(10,R),write(R),nl,fail. 39 | 40 | /* 41 | ?- go. 42 | 43 | s(s(0))*s(s(s(s(s(0))))) = s(s(s(s(s(s(s(s(s(s(0)))))))))) 44 | s(s(s(0)))*s(0) = s(s(s(0))) 45 | 46 | If each use of a linear clause has it's `own' #t resource guard (say 47 | #t_n_1_1, #t_n_1_2, #t_sum_3_1, #t_sum_3_2, etc.) and the grammar is 48 | initialised with exactly 1 token for each of them, then a reasonably 49 | fast implementation is obtained at source level. (Heavy operations 50 | like clause selection and unification are still compiled. Using 51 | exactly once each clause in a proof is ensured by the fact that 52 | the grammar consumes the `usage' flag of the clause which will fail 53 | afterwards). 54 | 55 | In principle real DCGs can be used instead of HAGs so that this 56 | translates to a definite clause program. The effect of # tokens is 57 | simulated at WAM-level with a flag subject to value-trailing, so 58 | linearity of statically known predicates can be made a very cheap 59 | operation (probably within +-5% of ordinary Prolog execution time). 60 | 61 | The more general idea beyond the example is the use of grammars to 62 | specify/limit use of computational ressources. Linearity is an instance. 63 | Iterative deepening can also be emulated by giving progressively 64 | larger sets of tokens. 65 | 66 | More complex constraints like "using exactly one among a set of 67 | clauses" can be expressed by shared tokens. If a frequently occurring 68 | subset of the constructs supported by Lygon or Lolli fits in this scheme 69 | a speed-up of at least one order of magnitude can be expected. 70 | 71 | Cheers, 72 | 73 | Paul 74 | 75 | P.S. I am wondering if grammars with restrictions on the number of times 76 | a rule can be used have been investiagted. Maybe Veronica has some 77 | hints about this. Clearly counters in parametric grammars can be used 78 | to obtain this effect too. 79 | */ 80 | -------------------------------------------------------------------------------- /progs/natlog.pl: -------------------------------------------------------------------------------- 1 | % uses Assumption Grammars 2 | % implements a curried flat syntax for LP, as in: 3 | 4 | % append nil Xs Ys. 5 | % append AXs Ys AZs :- AXs = cons A Xs, AZs = cons A Zs, append Xs Ys Zs. 6 | % append AXs Ys AZs :- AXs = A|AZs, AZs = A|Zs, append Xs Ys Zs. 7 | % append AXs Ys AZs :- AXs = A|AZs, AZs = A|Zs, append Xs Ys Zs. 8 | 9 | 10 | go:- 11 | % f 12 Xs :- Xs =: cons X Ys, f 11 Ys, !, r 3.14 X. 12 | Ts=[atom(f),integer(box(12,[46,49,50])),var(_2641,'Xs'),atom((:-)), 13 | var(_2641,'Xs'),atom(=),atom(.),var(_2915,'X'),var(_2990,'Ys'),(','), 14 | atom(f),integer(box(11,[46,49,49])),var(_2990,'Ys'),(','), 15 | atom(!),(','), 16 | atom(r),atom(3.140000),var(_2915,'X')], 17 | Vs=[var('Xs',_2641,s(1)),var('X',_2915,s(1)),var('Ys',_2990,s(1))], 18 | parse_flat(Ts,Vs,C), 19 | write(C),nl, 20 | fail. 21 | 22 | test:-write('> '),read_flat(C,_),write(C),nl,fail. 23 | 24 | test(Cs):-read_tokens_from_chars(Cs,Ts,Vs),write(Ts-Vs),nl. 25 | 26 | read_block(XXs):-get0(X),read_block1(X,XXs). 27 | 28 | read_block1(-1,"end_of_file"):-!. 29 | read_block1(46,Xs):-get_code(X),!,read_block2(X,Xs). 30 | read_block1(X,[X|Xs]):-get_code(Y),read_block1(Y,Xs). 31 | 32 | read_block2(10,[]):-!. 33 | read_block2(32,[]):-!. 34 | read_block2(9,[]):-!. 35 | read_block2(13,[]):-!. 36 | read_block2(X,[X|Xs]):-read_block1(X,Xs). 37 | 38 | read_flat(Clause,Vs):- 39 | % read_tokens(Ts,Vs),!, 40 | read_block(Cs),read_tokens_from_chars(Cs,Ts,Vs),!, 41 | parse_flat(Ts,Vs,Clause). 42 | 43 | parse_flat(Ts,_Vs,(H:-Bs)):- 44 | split_rest(Ts,[Xs|Xss]), 45 | parse_head(Xs,H), 46 | parse_body_or_true(Xss,Bs). 47 | 48 | parse_head(Xs,H):-parse_atom(Xs,H). 49 | 50 | parse_body_or_true([],true). 51 | parse_body_or_true([sep((:-)),X|Xs],Bs):-parse_body(Xs,X,Bs). 52 | 53 | parse_body([],X,B):-!,parse_atom(X,B). 54 | parse_body([sep(','),Y|Xs],X,BBs):- 55 | parse_body_atom(X,Bs,BBs), 56 | parse_body(Xs,Y,Bs). 57 | 58 | parse_body_atom(X,Bs,BBs):- 59 | parse_atom(X,B), 60 | add_body_atom(B,Bs,BBs). 61 | 62 | add_body_atom(true,Bs,Bs):-!. 63 | add_body_atom(B,Bs,(B,Bs)). 64 | 65 | parse_atom([var(V,_),atom(Eq),atom(X)|Xs],true):-member(Eq,[=,:=,=:]),!, 66 | parse_args(Xs,As), 67 | T=..[X|As],V=T. 68 | parse_atom([atom(X)|Xs],A):- 69 | parse_args(Xs,As), 70 | A=..[X|As]. 71 | 72 | parse_args([],[]). 73 | parse_args([T|Ts],[X|Xs]):-parse_arg(T,X),parse_args(Ts,Xs). 74 | 75 | parse_arg(var(X,_),X):-!. 76 | parse_arg(atom(X),X):-!. 77 | parse_arg(integer(box(X,_)),X):-!. 78 | %parse_arg(X,X). 79 | 80 | split_rest(Xs,[Ys|Yss]):- 81 | dcg_val([]),dcg_def(Ys), 82 | split_flat(Xs,Yss), 83 | dcg_val([]). 84 | 85 | split_flat([],[]):-!. 86 | split_flat([X|Xs],[sep(S)|Xss]):-sep(X,S),!,split_rest(Xs,Xss). 87 | split_flat([X|Xs],Xss):-dcg_connect(X),split_flat(Xs,Xss). 88 | 89 | sep((','),(',')). 90 | sep(atom((:-)),(:-)). 91 | 92 | 93 | -------------------------------------------------------------------------------- /progs/netkill.pl: -------------------------------------------------------------------------------- 1 | % this is a killer networking test for various BinProlog 2 | % communication agents: master_servers, server, servants, chat, talk 3 | % listeners 4 | 5 | test:- 6 | spawn((for(I,1,100),write(I),nl,fail;sleep(5))). 7 | 8 | spanwait(Goal):-spawn(Goal,[netkill],'temp.pro'),sleep(10). 9 | 10 | password(none). 11 | 12 | go:- 13 | detect_ip_addr(H),P1=9100,P2=9200, 14 | spanwait(master_server(H,7000)=>>run_master_server), 15 | spanwait(master_server(H,7000)=>>port(P1)=>run_server), 16 | spanwait(master_server(H,7000)=>>port(P2)=>run_server), 17 | spanwait(port(P1)=>>run_servant), 18 | spanwait(port(P2)=>>run_servant), 19 | spanwait(port(P1)=>>do_in), 20 | spanwait(port(P2)=>>do_in), 21 | spanwait(port(P1)=>>do_out), 22 | spanwait(port(P2)=>>do_out), 23 | spanwait(master_server(H,7000)=>>do_yell), 24 | spanwait(port(P1)=>>do_out), 25 | spanwait(port(P2)=>>do_out) 26 | %,spanwait(mix(H)) 27 | . 28 | 29 | mix(H):- 30 | do(host(P1)=>>all(X,Xs1)),write(P1-Xs1),nl, 31 | do(host(P2)=>>all(X,Xs2)),write(P2-Xs2),nl, 32 | show_servers, 33 | show_servants, 34 | spanwait(master_server(H,7000)=>>do_yell), 35 | sleep(20), 36 | host(P1)=>>stop_server, 37 | sleep(20), 38 | host(P2)=>>stop_server, 39 | do(show_servers), 40 | do(show_servants), 41 | sleep(10), 42 | host(7000)=>>stop_server. 43 | 44 | do_yell:- 45 | sleep(5), 46 | for(I,1,100),symcat(a,I,M), 47 | do(yell(M)), 48 | fail 49 | ; halt(0). 50 | 51 | 52 | do_out:- 53 | sleep(5), 54 | for(I,1,100), 55 | do(out(a(s(I)))), 56 | fail 57 | ; halt(0). 58 | 59 | 60 | do_in:- 61 | sleep(5), 62 | for(_,1,200), 63 | do(in(a(_))), 64 | fail 65 | ; halt(0). 66 | 67 | do(G):-write('***==>'), 68 | ( G->write(G),nl 69 | ; errmes(unexpected_failure,G) 70 | ). 71 | 72 | /* run this on the server side */ 73 | light_server:- 74 | heap(500)=>trail(100)=>stack(100)=>trust. 75 | 76 | one_task(I,IdleTime):- 77 | println(task_for(I)), 78 | sleep(IdleTime). 79 | 80 | one_client(_,Times,IdleTime):- 81 | for(I,1,Times), 82 | remote_run(one_task(I,IdleTime)), 83 | fail. 84 | one_client(Id,_,_):- 85 | remote_run(println(finished(Id))), 86 | halt. 87 | 88 | /* run this, with vrious parameters on a W2000 or XP system */ 89 | rruns(Clients,Times,IdleTime):- 90 | for(I,1,Clients), 91 | swrite(one_client(I,Times,IdleTime),Goal), 92 | make_cmd(['START bp netkill ',Goal],Cmd), 93 | println(Cmd), 94 | system(Cmd), 95 | fail 96 | ; 97 | println(started(all)). 98 | 99 | /* example of small test which works fine */ 100 | rtest:- 101 | G=rruns(20,5,1), 102 | println(G), 103 | G. 104 | -------------------------------------------------------------------------------- /src/termStore.h: -------------------------------------------------------------------------------- 1 | /* 2 | see term.h for external Term representations 3 | and operations on them 4 | */ 5 | 6 | /* 7 | THESE OPERATIONS WILL BE PROVIDED 8 | BY THE EXTERNAL TERM STORE. 9 | */ 10 | 11 | /* adds a Term to the Term store as the FIRST term associated to a key 12 | - multiple values can be associated to a key 13 | as a key is a compound Term its toplevel subterms can be seen as independent 14 | subkeys to which the same reference to the value Term should be associated 15 | */ 16 | void pushTerm(Term key, Term value); 17 | /* adds a Term to the Term store as the LAST value assocuated to a key 18 | - multiple values can be associated to a key 19 | as a key is a compound Term its toplevel subterms can be ssen as independent 20 | subkeys to which the same reference to the value Term should be associated 21 | */ 22 | void putTerm(Term key, Term value); 23 | 24 | /* creates a new iterator returning Terms associated to a key*/ 25 | ulong newIterator(Term key); 26 | 27 | /* closes a given iterator and frees all the resources it uses */ 28 | void closeIterator(ulong iterator); 29 | 30 | /* checks if there's at least one Term associated to a key, without 31 | necessarily creating an iterator for that - should be a fast operation 32 | */ 33 | BYTE hasTerms(Term key); 34 | 35 | /* iterator that retrieves and possibly removes the next Term from the Term store 36 | it returns NULL when no more terms are found. If it detects that all terms 37 | associated to a key have been removed, it frees all the resource relate to 38 | the key on which the iterator operates. 39 | */ 40 | Term getNextTerm(ulong iterator); 41 | 42 | void removeCurrentTerm(ulong iterator); 43 | 44 | void updateCurrentTerm(ulong iterator,Term term); 45 | 46 | /* deletes all terms associated to a key and ensures 47 | that the memory used by them is ALL reclaimed 48 | */ 49 | void deleteAllTerms(Term key); 50 | 51 | /* 52 | returns the number of Terms currently 53 | associated to a key; 54 | */ 55 | bp_long countTerms(Term key); 56 | 57 | /* creates an iterator enumerating one key at a time */ 58 | ulong newKeyIterator(); 59 | 60 | /* allows Prolog to call various user defined 61 | Term->Term functions for each OpCode=0,1,... 62 | The functions will: 63 | - return NULL to indicate failure to Prolog 64 | - call freeTerm their input argument if it is not needed further 65 | The interface will free the returned Term after internalizing it. 66 | */ 67 | Term processTerm(bp_long OpCode,Term argument); 68 | 69 | /* returns a new (possibly UNIQUE!) string */ 70 | char *newTermString(char *s); 71 | 72 | /* frees a string created with newTermString - possibly implementing 73 | a reference counting mechanism such that a given UNIQUE string 74 | is only freed when no reference to it exists 75 | */ 76 | void freeTermString(char *s); 77 | --------------------------------------------------------------------------------