Mercurial > hg > callgraph
changeset 0:b12b733d1dd0
Initial check-in.
| author | samer |
|---|---|
| date | Sun, 23 Mar 2014 16:05:36 +0000 |
| parents | |
| children | 2fa75f473a41 |
| files | Makefile README callgraph.pdf pack.pl prolog/callgraph.pl prolog/library/dcgu.pl prolog/library/dot.pl prolog/library/fileutils.pl release/callgraph-0.2.tgz |
| diffstat | 9 files changed, 1860 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,24 @@ +# ---------------- configuration ---------------------- + +# if you have multiple SWI Prolog installations or an installation +# in a non-standard place, set PLLD to the appropriate plld invokation, eg +# PLLD=/usr/local/bin/plld -p /usr/local/bin/swipl + +PACKNAME=callgraph +VER=0.2 +PACKFILE=release/$(PACKNAME)-$(VER).tgz +# ---------------- end of configuration --------------- + +main: + make -C c + +packfile: + mkdir -p $(PACKNAME) $(PACKNAME)/prolog + cp -p pack.pl $(PACKNAME) + cp -pR prolog $(PACKNAME) + cp -p README $(PACKNAME) + tar czf $(PACKFILE) $(PACKNAME) + rm -rf $(PACKNAME) + +install: packfile + swipl -g "pack_install('$(PACKFILE)')"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/README Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,66 @@ +---+ callgraph + +This package provides library(callgraph), a tool for compiling a graph of calls between predicates in a module. + +---++++ Prerequisites + +The graph layout programs from the GraphViz library (http://graphviz.org/) are +used to render the end result. Whilst you can produce a dot file with them, +you will need them for the final rendering. +On Mac OS X with MacPorts installed, do this at the bash prompt. +== +$ sudo port install graphviz +== +On Debian based systems, do this: +== +$ sudo apt-get install graphviz +== +And so on. +You will need a PDF viewer to see the results. + + + +---++++ Simple usage + +To produce a call graph as a PDF, make sure that both this module and the +module you wish to analyse are loaded, then do this: +== +?- module_dotpdf(<module_name>,[]). +== +This will produce a PDF file <module_name>.pdf in the current directory. +Often, the default layout program, dot, will produce a very wide graph. +This can sometimes be alleviated by using the unflatten program from the +Graphviz tools. In module_dotpdf/2, the default layout method does actually +use unflatten without any parameters, but if this is not enough, you can +provide values for the -f, -l and -c switches of unflatten (see the man +page for unflatten for more details). For example, to produce a graph of +callgraph itself, you can try the following: +== +$ swipl +?- use_module(library(callgraph)). +?- module_dotpdf(callgraph,[method(unflatten([fl(4),c(4)]))]). +== + +---++++ Output formats + +If you want the dot language source file, use module_dot/2 instead. The +method option is then inapplicable. + +The code can also produce rendered graphs in any format supported by +Graphviz, but this functionality is not currently exposed. + +---++++ Limitations + +The graph compilation relies on prolog_walk_code/1 to do the actual code +analysis. This does a good job in most cases, using meta-predicate declarations +or inferred meta-predicates to detect many high-order calling patterns. +Ironically enough, callgraph fails to analyse itself fully because +prolog_walk_code/1 does not detect that it itself calls a given predicate +for each call detected. Thus, in the example, there is no edge from +assert_module_graph/1 to assert_edge/4. + +---++++ Planned enhancements + +The main thing to add next is to render graphs for multiple modules using dot's +subgraph facility. Otherwise, the system for dealing with style attributes is +a bit messy and could be cleaned up.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/pack.pl Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,7 @@ +name(callgraph). +version('0.2'). +author('Samer Abdallah','s.abdallah@ucl.ac.uk'). +title('Predicate call graph visualisation'). +keywords([cross_referencing,graph,visualisation,dot]). +download('https://code.soundsoftware.ac.uk/projects/callgraph/repository/raw/release/callgraph-0.2.tgz'). +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/prolog/callgraph.pl Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,404 @@ +:- module(callgraph, + [ module_dotpdf/2 + , module_dot/2 + % , assert_module_graph/1 + % , current_ugraph/1 + % , current_dot/3 + % , module_graphml/1 + ]). + +/** <module> Visualisation of inter-predicate call graphs + + ---++ Usage + This module allows you to produce a call graph of a module, where + nodes (boxes) represent predicates in the module and an edge between + two predicates indicates that one (the source end) calls the other + (the pointy end). + + By default, node styles are used to indicate whether or not the predicate is + exported (bold outline), dynamic (italic label, filled), multifile (box with diagonals + in the corners). + For dynamic predicates, dashed edges are used to represent operations which + mutate (assert to or retract from) the predicate. + + Items in the recorded database are also represented, as they consitute mutable + state much like dynamic predicates. Recorded items are labelled as Key:Functor/Arity + and drawn in a filled octagonal box. Dashed edges represents writing to the + recorded database and ordinary solid edges represent reading. + + Basic method of usage is: + 1. Load the module you want to graph. + 2. Load this module. + 3. Generate and write the module call graph to a PDF document: + == + ?- module_dotpdf(ModuleName,[]). + == + + See module_dot/2 for options that affect graph content and style, and + module_dotpdf/2 for options that affect rendering. + + ---++ Implementation notes + + NB. This is very preliminary. The intereface is not necessarily stable. + The dot DCG implementation is a bit embarassing but it does the job for now. + + Three parts to this: + 1. Using prolog_walk_code/1 to compile a database of inter-predicate calls + into dynamic predicates calls/2, mutates/2, reads/2 and writes/2. + 2. Possible transformations of graph (eg pruning). + 3. Collect information about desired modules/predicates into a Dot graph + structure as defined by dotdct.pl +*/ + + +:- use_module('library/dcgu'). +:- use_module('library/dot'). +% :- use_module(library(graphml_ugraph)). + +% ------------ Building the call graph in the Prolog database ----------------------- + +:- dynamic calls/2. +:- dynamic mutates/2. +:- dynamic reads/2, writes/2. + +%% assert_module_graph(+ModuleName) is det. +% Analyses module ModuleName (using prolog_walk_code/1) asserting information about the +% call graph to a set of private dynamic predicates. +assert_module_graph(Mod) :- + retract_call_graph, + prolog_walk_code([ trace_reference(_), module(Mod), on_trace(assert_edge(Mod)), source(false) ]), + predicate_property(calls(_,_), number_of_clauses(N)), + format('Got ~D edges~n', [N]). + +retract_call_graph :- + retractall(calls(_,_)), + retractall(mutates(_,_)), + retractall(reads(_,_)), + retractall(writes(_,_)). + +% Irreflexive version of calls. +calls_ir(Caller,Callee) :- + calls(Caller,Callee), + Caller\=Callee. + +%% mutator(+Goal,-Pred) is semidet. +% True when Goal changes predicate Pred. +mutator(assert(H:-_),H) :- !. +mutator(assertz(H:-_),H) :- !. +mutator(asserta(H:-_),H) :- !. +mutator(assert(H),H) :- !. +mutator(assertz(H),H). +mutator(asserta(H),H). +mutator(retract(H),H). +mutator(retractall(H),H). +caller(retract(H), H). + +reader(recorded(Key,Term,_), Node) :- goal_pred(Key:Term,Node). +reader(recorded(Key,Term), Node) :- goal_pred(Key:Term,Node). +writer(recorda(Key,Term,_), Node) :- goal_pred(Key:Term,Node). +writer(recorda(Key,Term), Node) :- goal_pred(Key:Term,Node). +writer(recordz(Key,Term,_), Node) :- goal_pred(Key:Term,Node). +writer(recordz(Key,Term), Node) :- goal_pred(Key:Term,Node). +writer(record(Key,Term,_), Node) :- goal_pred(Key:Term,Node). +writer(record(Key,Term), Node) :- goal_pred(Key:Term,Node). + +assert_edge(M, M:Head, M:Caller, _Where) :- + writer(Head,Node), !, + goal_pred(M:Caller,CallerFA), + assert_fact(writes(CallerFA,Node)). + +assert_edge(M, M:Head, M:Caller, _Where) :- + reader(Head,Node), !, + goal_pred(M:Caller,CallerFA), + assert_fact(reads(CallerFA,Node)). + +assert_edge(M, M:Head, M:Modifier, _Where) :- + mutator(Head,Modified), !, + goal_pred(M:Modified,ModifiedFA), + goal_pred(M:Modifier,ModifierFA), + assert_fact(mutates(ModifierFA,ModifiedFA)), + ( caller(Head,Modified) + -> assert_fact(calls(ModifierFA,ModifiedFA)) + ). + +% matches calls within module M. +assert_edge(M, M:Callee, M:Caller, _Where) :- + \+predicate_property(M:Callee, built_in), + \+predicate_property(M:Callee, imported_from(_)), !, + goal_pred(M:Callee,CalleeFA), + goal_pred(M:Caller,CallerFA), + assert_fact(calls(CallerFA,CalleeFA)). + +% do nothing silently for other calls +assert_edge(_,_,_,_). + +% asserts fact if not already asserted. +assert_fact(Head) :- call(Head) -> true; assertz(Head). + +goal_pred(M:H,M:F/A) :- nonvar(M), (nonvar(H);ground(F/A)), functor(H,F,A). + + +% ----------------------- GraphML output ---------------------- +% Leaving this out for the time being. + +% module_graphml(Mod) :- +% assert_module_graph(Mod), +% current_ugraph(Graph), +% retract_call_graph, +% format(atom(File),'~w.graphml',[Mod]), +% graphml_write_ugraph(File, nomap, [], Graph). + +% nomap(id,node(N),A) :- term_to_atom(N,A), writeln(nomap(id,node(N),A)). +% % nomap(id,edge(_,_),''). +% % [key(node, color, string), key(edge,color,string)], +% % cmap(color, node(_), green). +% % cmap(color, edge(_), red). + + +% %% current_ugraph(-Graph:graphml) is det. +% % Returns the current call graph as a GraphML document structure. +% current_ugraph(Graph) :- +% findall(Pred, (calls_ir(Mod:Pred,_);calls_ir(_,Mod:Pred)), Preds), +% sort(Preds,Preds1), +% setof(Caller-Callees, (member(Caller,Preds1), callees(Mod,Caller,Callees)), Graph). + +% callees(Mod,Caller,Callees) :- setof(Callee, calls_ir(Mod:Caller,Mod:Callee),Callees), !. +% callees(_,[]). + + + +% ----------------------- Dot output ---------------------- + + +%% module_dot(+ModuleName,Opts) is det. +% Writes a call graph for named module as a dot file named "[ModuleName].dot". +% This predicate also accepts various options (some of the these types +% refer to the GraphViz attribute types): +% * prune(Prune:bool) / false +% If true, then graph subtrees are removed using prune_subtrees/0. +% * recursive(bool) / false +% If true, then looping edges are used to decorate predicates that call themselves +% directly. Otherwise, such direct recursion is hidden. +% * hide_list(list(pred_ind)) / [] +% A list of predicate (name/arity) to hide from the graph. +% * arrowhead(arrow_type) / vee +% Dot arrowhead name as an atom, for all call edges. +% * export_style(node_style) / bold +% Dot node style for exported predicates. +% * dynamic_shape(node_shape) / box +% Dot node shape for dynamic predicates. +% * dynamic_style(node_style) / filled +% Dot node style for dynamic predicates. +% * multifile_shape(node_shape) / box +% Dot node shape for multifile predicates. +% * multifile_style(node_style) / diagonals +% Dot node style for multifile predicates. +% * recorded_shape(node_shape) / octagon +% Dot node shape for recorded facts. +% * recorded_style(node_style) / filled +% Dot node style for recorded facts. +% * mutate_style(line_style) / dashed +% Dot line style for edges representing mutation of a dynamic predicate. +% * read_style(line_style) / solid +% Dot line style for edges representing readed of a recorded fact. +% * write_style(line_style) / dashed +% Dot line style for edges representing writing of a recored fact. +% * font(S:string) +% Font family (as a list of codes) for all labels. How these names are +% interpreted depends on your host operating system. On Mac OS X, I find +% I am able to use any font available in the "Font Book" application with +% the name written exactly (including spaces) as in the "Font" column. +% Default is "Times". +% +% Types for Dot attributes: +% see http://graphviz.org/Documentation.php for more details on +% * arrow_type: http://graphviz.org/content/attrs#karrowType +% * node_shape: http://graphviz.org/content/node-shapes +% * node_style: http://graphviz.org/content/attrs#kstyle +% +% == +% line_style ---> solid ; dashed ; dotted ; bold. +% arrow_type ---> normal ; vee ; empty ; box ; none ; dot ; ... . +% node_shape ---> box ; ellipse ; circle ; diamond ; trapezium ; parallelogram +% ; house ; square ; pentagon ; hexagon ; septagon ; octagon ; ... . +% node_style ---> solid ; dashed ; dotted ; bold ; rounded +% ; diagonals ; filled ; striped ; wedged. +% == +module_dot(Mod,Opts) :- + assert_module_graph(Mod), + (option(prune(true),Opts) -> prune_subtrees; true), + current_dot(Mod,Opts,Graph), + retract_call_graph, + format(atom(File),'~w.dot',[Mod]), + graph_dot(Graph,File). + +%% module_dotpdf(+Mod,Opts) is det. +% Writes a call graph for module Mod as a PDF file named "[Mod].pdf". +% As well as the options accepted by module_dot/2, this predicate also accepts: +% * method(Method:graphviz_method) / unflatten +% Determines which GraphViz programs are used to render the graph. The type +% graphviz_method is defined as: +% == +% graphviz_method ---> dot ; neato; fdp ; sfdp ; circo ; twopi +% ; unflatten(list(unflatten_opt)) +% ; unflatten. +% unflatten_opt ---> l(N:natural) % -l<N> +% ; fl(N:natural) % -f -l<N> +% ; c(natural). % -c<N> +% == +% The unflatten methods filter the graph through unflatten before passing +% on to dot. +module_dotpdf(Mod,Opts) :- + assert_module_graph(Mod), + option(method(Method),Opts,unflatten), + (option(prune(true),Opts) -> prune_subtrees; true), + current_dot(Mod,Opts,Graph), + retract_call_graph, + dotrun(Method,pdf,Graph,Mod). + + +%% current_dot(+Mod,+Opts,-DotGraph) is det. +% Returns the currently asserted graph as a dot graph structure, +% using the given options and restricting the graph to module Mod. +% The options are documented under module_dot/2. +current_dot(Mod,Opts,digraph(Mod,Graph)) :- + predopt(Opts,recorded,DBNodeAttr,[]), + setof(with_opts(node(Pred),Attrs), node_decl(Opts,Mod,Pred,Attrs), Decls), + esetof(with_opts(node(N),DBNodeAttr), db_node(N), DBNodes), + writeln(DBNodes), + module_graph(Mod,Opts,Decls,DBNodes,Graph,[]). + +node_decl(Opts,Mod,Pred,Attrs) :- + declarable_node(Opts,Mod,Pred), + pred_attr(Opts,Mod:Pred,Attrs). + +read_edge(Mod,_Opts,Pred,DBTerm) :- reads(Mod:Pred, DBTerm). +write_edge(Mod,_Opts,Pred,DBTerm) :- writes(Mod:Pred, DBTerm). + +declarable_node(Opts,M,Pred) :- + option(hide_list(HideList),Opts,[]), + ( predicate_property(M:Head, dynamic) + ; predicate_property(M:Head, exported) + ; predicate_property(M:Head, multifile) + ), + \+predicate_property(M:Head, built_in), + \+predicate_property(M:Head, imported_from(_)), + goal_pred(M:Head,M:Pred), + \+member(Pred, ['$mode'/2,'$pldoc'/4, '$pldoc_link'/2]), + \+member(Pred,HideList). + +visible_call(Mod,Opts,Caller,Callee) :- + option(hide_list(L),Opts,[]), + option(recursive(T),Opts,false), + calls(Mod:Caller,Mod:Callee), + (T=false -> Caller\=Callee; true), + \+member(Caller,L), + \+member(Callee,L). + +visible_mutation(Mod,Opts,P1,P2) :- + option(hide_list(L),Opts,[]), + mutates(Mod:P1,Mod:P2), + \+member(P1,L), + \+member(P2,L). + +module_graph(Mod,Opts,Decls,DBNodes) --> + { edgeopt(Opts,mutates,MAttr,[]), + edgeopt(Opts,reads,RAttr,[]), + edgeopt(Opts,writes,WAttr,[]) + }, + seqmap(global_opts(Opts),[graph,node,edge]), % global attributes + list(Decls), list(DBNodes), + findall(arrow(Caller,Callee), visible_call(Mod,Opts,Caller,Callee)), + findall(with_opts(arrow(Mutator,Mutatee),MAttr), visible_mutation(Mod,Opts,Mutator,Mutatee)), + findall(with_opts(arrow(Pred,DBTerm),RAttr), read_edge(Mod,Opts,Pred,DBTerm)), + findall(with_opts(arrow(Pred,DBTerm),WAttr), write_edge(Mod,Opts,Pred,DBTerm)). + +esetof(A,B,C) :- setof(A,B,C) *-> true; C=[]. + +list([]) --> []. +list([X|XS]) --> [X], list(XS). + +db_node(N) :- reads(_,N); writes(_,N). + +global_opts(_,graph) --> []. +global_opts(O,node) --> {font(normal,O,F)}, [node_opts([ shape=at(box), fontname=qq(F) ])]. +global_opts(O,edge) --> {option(arrowhead(AH),O,vee)}, [edge_opts([ arrowhead=at(AH) ])]. + +predopt(O,exported) --> + {option(export_style(S),O,bold)}, + {font(bold,O,F)}, + [ style = qq(at(S)), fontname=qq(F) ]. +predopt(O,dynamic) --> + {option(dynamic_shape(S),O,box)}, + {option(dynamic_style(St),O,filled)}, + {font(italic,O,F)}, + [ shape = at(S), fontname=qq(F), style = qq(at(St)) ]. +predopt(O,multifile) --> + {option(multifile_shape(S),O,box)}, + {option(multifile_style(St),O,diagonals)}, + [ shape = at(S), style = qq(at(St)) ]. +predopt(O,recorded) --> + {option(recorded_shape(S),O,octagon)}, + {option(recorded_style(St),O,filled)}, + [ shape = at(S), style = qq(at(St)) ]. + +edgeopt(O,mutates) --> {option(mutate_style(S),O,dashed)}, [ style = qq(at(S)) ]. +edgeopt(O,writes) --> {option(write_style(S),O,dashed)}, [ style = qq(at(S)) ]. +edgeopt(O,reads) --> {option(read_style(S),O,solid)}, [ style = qq(at(S)) ]. + +pred_attr(O,Pred,Attrs1) :- + goal_pred(Goal,Pred), + phrase( ( if( predicate_property(Goal,dynamic), predopt(O,dynamic)), + if( predicate_property(Goal,multifile), predopt(O,multifile)), + if( predicate_property(Goal,exported), predopt(O,exported))), + Attrs, []), + Attrs = [_|_], + compile_attrs(Attrs,[],Attrs1). + +compile_attrs([],A,A). +compile_attrs([style=S|AX],AttrsSoFar,FinalAttrs) :- !, + ( select(style=OS,AttrsSoFar,A1) + -> combine_styles(S,OS,NS), A2=[style=NS|A1] + ; A2=[style=S|AttrsSoFar] + ), + compile_attrs(AX,A2,FinalAttrs). +compile_attrs([A|AX],A0,A2) :- compile_attrs(AX,[A|A0],A2). + +combine_styles(qq(S1),qq(S2),qq((S1,",",S2))). + +% compile_attrs1([],A,[]). +% compile_attrs1([A|AX],A0,[A|A1]) :- compile_attrs1(AX,[A|A0],A1). + +font_family(O) --> {option(font(FF),O,"Times")}, seqmap(out,FF). +font(normal,O,F) :- phrase(font_family(O),F,[]). +font(italic,O,F) :- phrase((font_family(O)," Italic"),F,[]). +font(bold,O,F) :- phrase((font_family(O)," Bold"),F,[]). + +do_until(P) :- + call(P,Flag), + ( Flag=true -> true + ; do_until(P) + ). + +prunable(Node) :- + setof( Parent, calls(Parent,Node), [_]), % node has exactly one caller + \+calls(Node,_), % no children + \+mutates(Node,_), % doesn't affect dynamic preds + goal_pred(G,Node), + \+predicate_property(G,dynamic), + \+predicate_property(G,multifile), + \+predicate_property(G,exported). + +%% prune_subtrees is det. +% Operates on the currently asserted graph (see assert_module_graph/1). It searches +% for any part of the call graph which is a pure tree, and removes all the nodes below +% the root. Thus, any 'leaf' predicate which is only ever called by one 'parent' is +% removed. This is step is repeated until there are no more leaf predicates. The idea +% is that the child tree can be considered 'private' to its parent. +prune_subtrees :- do_until(prune_subtrees). + +prune_subtrees(false) :- + bagof(Node, prunable(Node), Nodes), !, + forall(member(N,Nodes), (writeln(pruning:N), retractall(calls(_,N)))). + +prune_subtrees(true).
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/prolog/library/dcgu.pl Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,1020 @@ +:- module(dcgu, [ + writedcg/1 + + , nop/2 + , out//1 + , (>>)//2 + , (\<)//1 + , (\>)//1 + , (\#)//2 + , run_left//3 + , run_right//3 + , trans//2 + + , maybe//1 + , opt//1 + , if//3, if//2 + , parmap//2, parmap//3, parmap//4, parmap//5, parmap//6 + , seqmap//2, seqmap//3, seqmap//4, seqmap//5, seqmap//6 + , seqmap_n//3, seqmap_n//4, seqmap_n//5 + , seqmap_with_sep//3 + , seqmap_with_sep//4 + , seqmap_with_sep//5 + , seqmap_with_progress//3 + , seqmap_with_progress//4 + , seqmap_ints//3 + , seqmap_args//4 + , seqmap_args//5 + , seqmap_args//6 + , iterate//3 + %, apply/4, apply/5 + , seq//1, seq//2, seq_n//3 + , smap//2 + , rep//2, rep_nocopy//2 + , at//1, wr//1, str//1, fmt//2 + , brace//1, paren//1, sqbr//1 + , q//1, qq//1 + , escape//2, escape_with//3 + , null//0, cr//0, sp//0, fs//0 + , fssp/2, tb/2, comma/2, commasp/2 + , padint/5 + + , do_then_call/5 + , do_then_call/6 + , do_then_call/7 + + , any/3, notany/3, arb/2, arbno/3, bal/2 + , span/3, break/3, len/3 + , exhaust/3 + , set/3, get/3, set_with/3 + , with/4, iso/3 + , once/3 + , repeat/2 + , (//)//2 + , until//2 + + , findall//3 + , setof//3 + + , op(900,fy,\<) + , op(900,fy,\>) + , op(900,xfy,\#) + + , lift//1 + , lift//2 + , lift//3 + + , stats/0 + , stats/1 + + , select_def_option//2 % like select_option/4 but for DCGs +]). + +/** <module> DCG utilities + +This module contains predicates for working with definite clause +grammars and the related stateful programming style where state +arguments are automatically threaded through sequences +of calls. Some useful DCG procedures are also included. + +When a predicate is declared with type =|foo(...)// is Det|=, +any requirements on the type of the DCG state are hidden, i.e. the +types of the two extra arguments are hidden. In these cases, +the documentation below will sometimes state that the predicate +'runs in the =|S|= DCG'. + +---+++ Types used in this module + +We use the following to denote types of terms that can +be interpreted as DCG phrases with or without further +arguments. + * phrase(S) + If P is a term of type =|phrase(S)|=, then P is a valid DCG phrase + when the DCG state is of type =|S|=, i.e. =|phrase(P,S1,S2)|= is + valid Prolog goal when S1 and S2 are of type =|S|=. N.B. the type + =|phrase(S)|= is almost but not quite equivalent to the binary + predicate type =|pred(S,S)|=. All such predicates are valid phrases, + but phrases involving braces (e.g. {Goal}), commas, semicolons, + and if-then constructs (->) are not equivalent to predicates + with two extra arguments. + * phrase(A,S) + If P is of type =|phrase(A,S)|= and X has type A, then =|call(P,X)|= + is a valid DCG phrase when the DCG is of type S. This type _|is|_ + equivalent to =|pred(A,S,S)|= because the only way to call it + is with call//1 inside a DCG or call/3 outside it. + * phrase(A,B,S) + If P is of type =|phrase(A,B)|= and =|X|= and =|Y|= are of types + =|A|= and =|B|= respectively, then =|call(P,X,Y)|= + is a valid DCG phrase. And so on. You get the idea. + +The type =|pair(A,B)|= will be used to denote the type of terms +with functor (,)/2 and arguments of types =|A|= and =|B|= respectively: +== +pair(A,B) ---> (A,B). +== +This type is used to support a set of general purpose predicates +for combining commands in two distinct DCGs into a single DCG +over a product space of states. +*/ + +:- module_transparent seq/3, seq/4, smap/4. + +:- meta_predicate + writedcg(2) + , if(0,//,//,?,?) + , if(0,//,?,?) + , maybe(//,?,?) + , opt(//,?,?) + , once(//,?,?) + , repeat(?,?) + , >>(//,//,?,?) + , //(//,?,?,?) + , \<(//,?,?) + , \>(//,?,?) + , \#(?,//,?,?) + , brace(//,?,?) + , paren(//,?,?) + , sqbr(//,?,?) + , qq(//,?,?) + , q(//,?,?) + , arbno(//,?,?) + , rep(?,//,?,?) + , rep_nocopy(+,//,?,?) + , exhaust(//,?,?) + , with(?,//,?,?) + , iso(//,?,?) + , set_with(1,?,?) + , run_left(//,?,?,?,?) + , run_right(//,?,?,?,?) + , iterate(4,?,?,?,?) + , parmap(3,?,?,?) + , parmap(4,?,?,?,?) + , parmap(5,?,?,?,?,?) + , parmap(6,?,?,?,?,?,?) + , parmap(7,?,?,?,?,?,?,?) + , seqmap(3,?,?,?) + , seqmap(4,?,?,?,?) + , seqmap(5,?,?,?,?,?) + , seqmap(6,?,?,?,?,?,?) + , seqmap(7,?,?,?,?,?,?,?) + , seqmap_n(+,3,?,?,?) + , seqmap_n(+,4,?,?,?,?) + , seqmap_n(+,5,?,?,?,?,?) + , seqmap_ints(3,+,+,?,?) + , seqmap_with_sep(//,3,?,?,?) + , seqmap_with_sep(//,4,?,?,?,?) + , seqmap_with_sep(//,5,?,?,?,?,?) + , seqmap_args(3,+,+,?,?,?) + , seqmap_args(4,+,+,?,?,?,?) + , seqmap_args(5,+,+,?,?,?,?,?) + , do_then_call(//,3,?,?,?) + , do_then_call(//,4,?,?,?,?) + , do_then_call(//,5,?,?,?,?,?) + , until(0,//,?,?) + . + +:- op(900,fy,\<). +:- op(900,fy,\>). +:- op(900,xfy,\#). +:- op(550,xfx,..). + + +%%% +%%% The first lot of stuff is completely general for any stateful system. +%%% + + +%% trans( ?Old:S, ?New:S, ?S1:int, ?S2:S) is det. +% +% Unifies Old and New with the states S1 and S2 respectively. +trans(X,Y,X,Y). + +% these will be useful for seq (they define a sort of generalised +% lazy mapping over sequences of DCG terms) +empty([]). +empty(_:[]). +empty(map(_,L)) :- empty(L). +empty(_:map(_,L)) :- empty(L). +empty(M..N) :- N<M. + +singleton([H|T],H) :- empty(T). +singleton(M:[H|T],M:H) :- empty(T). +singleton(map(F,L),call(F,H)) :- singleton(L,H). +singleton(M:map(F,L),call(M:F,H)) :- singleton(L,H). +singleton(M..M,M). + +properlist([H|T],H,T) :- \+empty(T). +properlist(M:[H|T],M:H,M:T) :- \+empty(T). +properlist(map(F,L),call(F,H),map(F,T)) :- properlist(L,H,T). +properlist(M:map(F,L),call(M:F,H),M:map(F,T)) :- properlist(L,H,T). +properlist(M..N,M,M1..N) :- N>M, succ(M,M1). + +%% nop// is det. +% +% Do nothing. (More neutral than []). +nop(X,X). + +%% set(S:A, S1:_, S2:A) is det. +% Set state to S. Implemented by goal expansion. +set(S,_,S). + +%% get(S:A, S1:A, S2:A) is det. +% Get state to S. Implemented by goal expansion. +get(S,S,S). + +%% with(S:A, P:phrase(A), S1:B, S2:B) is nondet. +% +% Run phrase P starting from state S and discarding +% the final state, meanwhile preserving the state +% of the current system, i.e. guarantees S1=S2. +with(S,G) --> {phrase(G,S,_)}. + +%% iso(P:phrase(A), S1:A, S2:A) is nondet. +% +% Run phrase P starting with current state but discarding +% its final state and preserving the current state, so +% that S1=S2. +iso(G) --> get(S), {phrase(G,S,_)}. + +%% set_with(+G:pred(A), S1:_, S2:A) is det. +% +% Set current state using a given callable goal G, which should accept one argument. +% should be of type pred( -S:A), ie it should set S to the new desired +% state, which is installed in the DCG state. +set_with(G,_,S) :- call(G,S). + +%% \<(P:phrase(A), ?S1:pair(A,B), ?S2:pair(A,B)) is nondet. +% +% Apply phrase P to left part of a paired state. +% Implemented by goal expansion so incurs only very small +% speed penalty. +\<(P,(A1,B),(A2,B)) :- phrase(P,A1,A2). + +%% \>(P:phrase(B), ?S1:pair(A,B), ?S2:pair(A,B)) is nondet. +% +% Apply phrase P which must be of type pred(B,B) to right +% part of a paired state. +% Implemented by goal expansion so incurs only very small +% speed penalty. +\>(P,(A,B1),(A,B2)) :- phrase(P,B1,B2). + +%% run_left(P:phrase(pair(A,B)), ?A1:A, ?A2:A, ?B1:B, ?B2:B) is multi. +% +% Applies DCG phrase P to state formed by pairing A1 and A2 with +% current DCG states B1 and B2. Phrase can use (\<) to access the +% A state and (\>) to access the underlying B state. +run_left(P,S1,S2,T1,T2) :- phrase(P,(S1,T1),(S2,T2)). + +%% run_right(P:phrase(pair(A,B)), ?B1:B, ?B2:B, ?A1:A, ?A2:A) is multi. +% +% Applies DCG phrase P to state formed by pairing A1 and A2 with +% current DCG states B1 and B2. Phrase can use (\<) to access the +% A state and (\>) to access the underlying B state. +run_right(P,S1,S2,T1,T2) :- phrase(P,(T1,S1),(T2,S2)). + +%% \#(N:natural, P:phrase(A), ?S1, ?S2) is nondet. +% +% Apply phrase P to the Nth argument of state which must +% be a compound term (with arbitrary functor), with the +% Nth argument of type A. +\#(N, P, S1, S2) :- with_nth_arg(N,P,S1,S2). + + +system:goal_expansion( run_left(P,S1,S2,T1,T2), phrase(P,(S1,T1),(S2,T2))). +system:goal_expansion( run_right(P,S1,S2,T1,T2), phrase(P,(T1,S1),(T2,S2))). +system:goal_expansion( \<(P,S1,S2), (S1=(L1,R),S2=(L2,R),phrase(P,L1,L2)) ). +system:goal_expansion( \>(P,S1,S2), (S1=(L,R1),S2=(L,R2),phrase(P,R1,R2)) ). +system:goal_expansion( nop(S1,S2), (S1=S2) ). +system:goal_expansion( out(X,S1,S2), (S1=[X|S2]) ). +system:goal_expansion( get(S,S1,S2), (S=S1,S1=S2) ). +system:goal_expansion( set(S,_,S2), (S=S2) ). +system:goal_expansion( A >> B, (A,B) ). +system:goal_expansion( set_with(C,_,S2), Call) :- mk_call(C,[S2],Call). +system:goal_expansion( trans(A1,A2,S1,S2), (S1=A1,S2=A2) ). +system:goal_expansion( //(P1,P2,S1,S2), (G1,G2)) :- + nonvar(P1), P1=..[F1|A1], append(A1,[S1,S2],B1), G1=..[F1|B1], + nonvar(P2), P2=..[F2|A2], append(A2,[S1,S2],B2), G2=..[F2|B2]. + +mk_call(C,XX,Call) :- var(C), !, mk_call(call(C),XX,Call). +mk_call(M:C,XX,M:Call) :- !, mk_call(C,XX,Call). +mk_call(C,XX,Call) :- C =.. CL, append(CL,XX,CL2), Call =.. CL2. + + +%% pushl(S:A,S1:B,S2:pair(A,B)) is det. +% Create a paired state by putting S on the left and the +% old state on the right. +pushl(S,S0,(S,S0)). + +%% pushr(S:A,S1:B,S2:pair(B,A)) is det. +% Create a paired state by putting S on the right and the +% old state on the left. +pushr(S,S0,(S0,S)). + +%% popl(S:A,S1:pair(A,B),S2:B) is det. +% Unpair state by removing left state and unifying it with S. +popl(S,(S,S0),S0). + +%% popr(S:A,S1:(B,A),S2:B) is det. +% Unpair state by removing right state and unifying it with S. +popr(S,(S0,S),S0). + +%% >>(G1:phrase(S), G2:phrase(S))// is nondet. +% Sequential conjuction of phrases G1 and G2, equivalent to (G1,G2), +% but sometimes more convenient in terms of operator priorities. +% Implemented by goal expansion. +A >> B --> A, B. + +%% once(G:phrase(_))// is semidet. +% Call DCG phrase G succeeding at most once. +once(G,A,B) :- once(phrase(G,A,B)). + +%% repeat// is nondet. +% Create an infinite number of choice points. +repeat(A,A) :- repeat. + +%% maybe(P:phrase(_))// is det. +% Try P, if it fails, then do nothing. If it succeeds, +% cut choicepoints and continue. +maybe(P) --> P -> nop; nop. + +%% opt(P:phrase(_))// is nondet. +% P or nothing. Like maybe but does not cut if P succeeds. +opt(P) --> P; nop. + +%% if(G:pred,P,Q)// is det. +%% if(G:pred,P)// is det. +% +% If Prolog goal =|call(G)|= succeeds, do P, otherwise, do Q. +% if(G,P) is equivalent to if(G,P,nop), i.e. does nothing +% if P fails. +if(A,B,C) --> {call(A)} -> B; C. % used to have nonvar(A) +if(A,B) --> {call(A)} -> B; nop. + + +%% exhaust( P:phrase(_))// is det. +% +% Run phrase sequentially as many times as possible until it fails. +% Any choice points left by G are cut. +exhaust(G) --> G -> exhaust(G); nop. + + +%% until( +Q:pred, +P:phrase(_))// is det. +% +% Repeatedly call phrase P and test ordinary Prolog goal +% Q until Q fails. P and Q are copied together before each +% iteration, so variables can be shared between them, but +% are not shared between iterations. +until( Pred, Op) --> + {copy_term(Pred/Op,Pred1/Op1)}, + call(Op1), + ( {call(Pred1)} + -> {Pred/Op=Pred1/Op1} + ; until(Pred, Op) + ). + +%% iterate( +P:phrase(A,A,S), +X:A, -Y:A)// is nondet. +% +% Sequentially call P zero or more times, passing in X on +% the first call and threading the result through subsequent calls, +% (as well as threading the DCG state in the normal way) +% ending in Y. + +iterate(_,A,A) --> []. +iterate(F,A1,A3) --> call(F,A1,A2), iterate(F,A2,A3). + + +%% rep( +N:natural, +P:phrase(_))// is nondet. +%% rep( -N:natural, +P:phrase(_))// is nondet. +% +% Equivalent to N sequential copies of phrase P. +% Free variables in P are *not* shared between copies. +% If N is unbound on entry, rep//2 is _cautious_: it tries +% gradually increasing N from 0 on backtracking. + +rep(N,G,S1,S2) :- + ( var(N) + -> rep_var(N,G,S1,S2) + ; rep_nonvar(N,G,S1,S2) + ). + +rep_var(0,_,S,S). +rep_var(N,G,S1,S3) :- + copy_term(G,G1), phrase(G1,S1,S2), + rep_var(M,G,S2,S3), succ(M,N). + +rep_nonvar(0,_,S,S) :- !. +rep_nonvar(N,G,S1,S3) :- + copy_term(G,G1), phrase(G1,S1,S2), + succ(M,N), rep_nonvar(M,G,S2,S3). + + +%% rep_nocopy( +N:natural, +P:phrase(_))// is nondet. +% +% Like rep//2 but does not copy P before calling, so +% any variables in P are shared between all calls. +% Also, N cannot be a variable in this implementation. +rep_nocopy(0,_) --> !. +rep_nocopy(N,P) --> call(P), {succ(M,N)}, rep_nocopy(M,P). + + +%% seq( +L:plist, +Sep)// is nondet. +%% seq( +L:plist)// is nondet. +% Sequence list of phrases with separator. L can be a sort of _generalised_ +% list of phrases, which can be: +% == +% plist ---> list(A) % ordinary list +% ; map(phrase(B),plist) % map phrase head P over list +% . +% == +% Sep is inserted strictly betweened elements of L. seq(L) is equivalent +% to seq(L,nop). + +seq(L,_) --> {dcgu:empty(L)}. +seq(L,_) --> {dcgu:singleton(L,H)}, H. +seq(L,S) --> {dcgu:properlist(L,H,T)}, H, S, seq(T,S). +seq(L) --> seq(L,nop). % if no separator specified, use nop. + + +%% seq_n( N:natural, +L:plist, +Sep)// is nondet. +% Sequence list of phrases with separator and counting. +% +% @see seq//2. + +seq_n(0,L,_) --> {dcgu:empty(L)}. +seq_n(1,L,_) --> {dcgu:singleton(L,H)}, H. +seq_n(N,L,S) --> {dcgu:properlist(L,H,T)}, H, S, seq_n(M,T,S), {succ(M,N)}. + +%% smap(+F,+L:list)// is nondet. +% Equivalent to seq(map(F,L),nop). +smap(F,L) --> seq(map(F,L),nop). + + + +%% seqmap( +P:phrase(A,S), X:list(A))// is nondet. +%% seqmap( +P:phrase(A,B,S), X:list(A), Y:list(B))// is nondet. +%% seqmap( +P:phrase(A,B,C,S), X:list(A), Y:list(B), Z:list(C))// is nondet. +%% seqmap( +P:phrase(A,B,C,D,S), X:list(A), Y:list(B), Z:list(C), W:list(D))// is nondet. +%% seqmap( +P:phrase(A,B,C,D,E,S), X:list(A), Y:list(B), Z:list(C), W:list(D), V:list(E))// is nondet. +% +% seqmap//N is like maplist/N except that P is an incomplete _phrase_ +% rather an ordinary goal, which is applied to the elements of the supplied +% lists _|in order|_, while threading the DCG state correctly through all +% the calls. +% +% seqmap//N is very powerful - it is like =foldl= and =mapaccum= in functional +% languages, but with the added flexibility of bidirectional Prolog variables. +% +% @see maplist/2. + +seqmap(_,[]) --> []. +seqmap(P,[A|AX]) --> call(P,A), seqmap(P,AX). +seqmap(_,[],[]) --> []. +seqmap(P,[A|AX],[B|BX]) --> call(P,A,B), seqmap(P,AX,BX). +seqmap(_,[],[],[]) --> []. +seqmap(P,[A|AX],[B|BX],[C|CX]) --> call(P,A,B,C), seqmap(P,AX,BX,CX). +seqmap(_,[],[],[],[]) --> []. +seqmap(P,[A|AX],[B|BX],[C|CX],[D|DX]) --> call(P,A,B,C,D), seqmap(P,AX,BX,CX,DX). +seqmap(_,[],[],[],[],[]) --> []. +seqmap(P,[A|AX],[B|BX],[C|CX],[D|DX],[E|EX]) --> call(P,A,B,C,D,E), seqmap(P,AX,BX,CX,DX,EX). + +true(_,_). +parmap(_,[]) --> true. +parmap(P,[A|AX]) --> call(P,A) // parmap(P,AX). +parmap(_,[],[]) --> true. +parmap(P,[A|AX],[B|BX]) --> call(P,A,B) // parmap(P,AX,BX). +parmap(_,[],[],[]) --> true. +parmap(P,[A|AX],[B|BX],[C|CX]) --> call(P,A,B,C) // parmap(P,AX,BX,CX). +parmap(_,[],[],[],[]) --> true. +parmap(P,[A|AX],[B|BX],[C|CX],[D|DX]) --> call(P,A,B,C,D) // parmap(P,AX,BX,CX,DX). +parmap(_,[],[],[],[],[]) --> true. +parmap(P,[A|AX],[B|BX],[C|CX],[D|DX],[E|EX]) --> call(P,A,B,C,D,E) // parmap(P,AX,BX,CX,DX,EX). + +%% seqmap_n( +N:natural, +P:phrase(A), X:list(A))// is nondet. +%% seqmap_n( +N:natural, +P:phrase(A,B), X:list(A), Y:list(B))// is nondet. +%% seqmap_n( +N:natural, +P:phrase(A,B,C), X:list(A), Y:list(B), Z:list(C))// is nondet. +% +% seqmap_n//.. is like seqmap/N except that the lists of arguments are of lenght N. + +seqmap_n(0,_,[]) --> []. +seqmap_n(N,P,[A|AX]) --> {succ(M,N)}, call(P,A), seqmap_n(M,P,AX). +seqmap_n(0,_,[],[]) --> []. +seqmap_n(N,P,[A|AX],[B|BX]) --> {succ(M,N)}, call(P,A,B), seqmap_n(M,P,AX,BX). +seqmap_n(0,_,[],[],[]) --> []. +seqmap_n(N,P,[A|AX],[B|BX],[C|CX]) --> {succ(M,N)}, call(P,A,B,C), seqmap_n(M,P,AX,BX,CX). + + +/* + * Goal expansions + */ + +cons(A,B,[A|B]). + +expand_seqmap_with_prefix(Sep0, Callable0, SeqmapArgs, Goal) :- + ( Callable0 = M:Callable + -> NextGoal = M:NextCall + ; Callable = Callable0, + NextGoal = NextCall + ), + + append(Lists, [St1,St2], SeqmapArgs), + + Callable =.. [Pred|Args], + length(Args, Argc), + length(Argv, Argc), + length(Lists, N), + length(Vars, N), + MapArity is N + 4, + format(atom(AuxName), '__aux_seqmap/~d_~w_~w+~d', [MapArity, Sep0, Pred, Argc]), + build_term(AuxName, Lists, Args, St1, St2, Goal), + + AuxArity is N+Argc+2, + prolog_load_context(module, Module), + ( current_predicate(Module:AuxName/AuxArity) + -> true + ; rep(N,[[]],BaseLists,[]), + length(Anon, Argc), + build_term(AuxName, BaseLists, Anon, S0, S0, BaseClause), + + length(Vars,N), + maplist(cons, Vars, Tails, NextArgs), + ( Sep0=_:Sep -> true; Sep=Sep0 ), + ( is_list(Sep) -> append(Sep,S2,S1), NextThing=NextGoal + ; build_term(phrase, [Sep0], [], S1, S2, NextSep), + NextThing = (NextSep,NextGoal) + ), + build_term(Pred, Argv, Vars, S2, S3, NextCall1), + build_term(AuxName, Tails, Argv, S3, S4, NextIterate), + build_term(AuxName, NextArgs, Argv, S1, S4, NextHead), + + ( goal_expansion(NextCall1,NextCall) -> true + ; NextCall1=NextCall), + + NextClause = (NextHead :- NextThing, NextIterate), + + ( predicate_property(Module:NextGoal, transparent) + -> compile_aux_clauses([ (:- module_transparent(Module:AuxName/AuxArity)), + BaseClause, + NextClause + ]) + ; compile_aux_clauses([BaseClause, NextClause]) + ) + ). + +expand_call_with_prefix(Sep0, Callable0, InArgs, (SepGoal,CallGoal)) :- + append(CallArgs, [S1,S3], InArgs), + + ( Sep0=_:Sep -> true; Sep=Sep0 ), + ( is_list(Sep) -> append(Sep,S2,SS), SepGoal=(S1=SS) + ; build_term(phrase, [Sep0], [], S1, S2, SepGoal) + ), + + ( var(Callable0) + -> build_term(call,[Callable0], CallArgs, S2, S3, CallGoal1) + ; ( Callable0 = M:Callable + -> CallGoal1 = M:NextCall + ; Callable = Callable0, + CallGoal1 = NextCall + ), + Callable =.. [Pred|Args], + build_term(Pred, Args, CallArgs, S2, S3, NextCall) + ), + ( goal_expansion(CallGoal1,CallGoal) -> true + ; CallGoal1=CallGoal + ). + +seqmap_with_sep_first_call(P,[A1|AX],AX) --> call(P,A1). +seqmap_with_sep_first_call(P,[A1|AX],[B1|BX],AX,BX) --> call(P,A1,B1). +seqmap_with_sep_first_call(P,[A1|AX],[B1|BX],[C1|CX],AX,BX,CX) --> call(P,A1,B1,C1). + +expand_seqmap_with_sep(Sep, Pred, SeqmapArgs, (dcgu:FirstCall,dcgu:SeqmapCall)) :- + prolog_load_context(module,Context), + (Sep=SMod:Sep1 -> true; SMod=Context, Sep1=Sep), + (Pred=CMod:Pred1 -> true; CMod=Context, Pred1=Pred), + append(Lists, [St1,St3], SeqmapArgs), + length(Lists, N), + length(Tails, N), + build_term(seqmap_with_sep_first_call, [CMod:Pred1|Lists], Tails, St1, St2, FirstCall), + build_term(seqmap_with_prefix, [SMod:Sep1,CMod:Pred1], Tails, St2, St3, SeqmapCall). + +build_term(H,L1,L2,S1,S2,Term) :- + append(L2,[S1,S2],L23), + append(L1,L23,L123), + Term =.. [H | L123]. + + +expand_dcgu(Term, Goal) :- + functor(Term, seqmap, N), N >= 4, + Term =.. [seqmap, Callable | Args], + callable(Callable), !, + expand_seqmap_with_prefix([],Callable, Args, Goal). + +expand_dcgu(Term, Goal) :- + functor(Term, seqmap_with_sep, N), N >= 5, + Term =.. [seqmap_with_sep, Sep, Callable | Args], + nonvar(Sep), callable(Callable), !, + expand_seqmap_with_sep(Sep, Callable, Args, Goal). + +expand_dcgu(Term, Goal) :- + functor(Term, seqmap_with_prefix, N), N >= 5, + Term =.. [seqmap_with_prefix, Sep, Callable | Args], + callable(Callable), nonvar(Sep), !, + expand_seqmap_with_prefix(Sep, Callable, Args, Goal). + +expand_dcgu(Term, Goal) :- + functor(Term, do_then_call, N), N >= 2, + Term =.. [do_then_call, Prefix, Callable | Args], + nonvar(Prefix), !, + expand_call_with_prefix(Prefix, Callable, Args, Goal). + +system:goal_expansion(GoalIn, GoalOut) :- + \+current_prolog_flag(xref, true), + expand_dcgu(GoalIn, GoalOut). +% prolog_load_context(module,Mod), +% writeln(expanded(Mod:GoalIn)). + + +%% seqmap_with_sep(+S:phrase, +P:phrase(A), X:list(A))// is nondet. +%% seqmap_with_sep(+S:phrase, +P:phrase(A,B), X:list(A), Y:list(B))// is nondet. +%% seqmap_with_sep(+S:phrase, +P:phrase(A,B,C), X:list(A), Y:list(B), Z:list(C))// is nondet. +% +% As seqmap//2.. but inserting the separator phrase S between each call to P. +% NB: *Fails* for empty lists. +% +% @see seqmap//2 +%seqmap_with_sep(S,P,[A|AX]) --> call(P,A), seqmap_with_prefix(S,P,AX). +%seqmap_with_sep(S,P,[A|AX],[B|BX]) --> call(P,A,B), seqmap_with_prefix(S,P,AX,BX). +%seqmap_with_sep(S,P,[A|AX],[B|BX],[C|CX]) --> call(P,A,B,C), seqmap_with_prefix(S,P,AX,BX,CX). +seqmap_with_sep(S,P,[A|AX]) --> call(P,A), seqmap(do_then_call(S,P),AX). +seqmap_with_sep(S,P,[A|AX],[B|BX]) --> call(P,A,B), seqmap(do_then_call(S,P),AX,BX). +seqmap_with_sep(S,P,[A|AX],[B|BX],[C|CX]) --> call(P,A,B,C), seqmap(do_then_call(S,P),AX,BX,CX). + +%seqmap_with_prefix(_,_,[]) --> []. +%seqmap_with_prefix(S,P,[A|AX]) --> S, call(P,A), seqmap_with_prefix(S,P,AX). +%seqmap_with_prefix(_,_,[],[]) --> []. +%seqmap_with_prefix(S,P,[A|AX],[B|BX]) --> S, call(P,A,B), seqmap_with_prefix(S,P,AX,BX). +%seqmap_with_prefix(_,_,[],[],[]) --> []. +%seqmap_with_prefix(S,P,[A|AX],[B|BX],[C|CX]) --> S, call(P,A,B,C), seqmap_with_prefix(S,P,AX,BX,CX). + + +% do_then_call( +S:phrase, +P:phrase(A), X:A)// is nondet. +% do_then_call( +S:phrase, +P:phrase(A,B), X:A, Y:B)// is nondet. +% do_then_call( +S:phrase, +P:phrase(A,B,C), X:A, Y:B, Z:C)// is nondet. +% +% Call phrase S, then call phrase P with arguments A, B, C etc. +do_then_call(S,P,A) --> S, call(P,A). +do_then_call(S,P,A,B) --> S, call(P,A,B). +do_then_call(S,P,A,B,C) --> S, call(P,A,B,C). + + +%% seqmap_ints( +P:phrase(integer), +I:integer, +J:integer)// is nondet. +% +% Equivalent to seqmap(P) applied to the list of integers from I to J inclusive. +% +% @see seqmap//2. +seqmap_ints(P,L,N) --> + ( {L>N} -> [] + ; {M is L+1}, call(P,L), seqmap_ints(P,M,N) + ). + + +%% seqmap_args( +P:phrase(integer), +I:integer, +J:integer, X:term)// is nondet. +%% seqmap_args( +P:phrase(integer), +I:integer, +J:integer, X:term, Y:term)// is nondet. +%% seqmap_args( +P:phrase(integer), +I:integer, +J:integer, X:term, Y:term, Z:term)// is nondet. +% +% Like seqmap//N, but applied to the arguments of term X, Y and Z, from the I th to the +% J th inclusive. +% +% @see seqmap//2. + +seqmap_args(P,L,N,A) --> + ( {L>N} -> [] + ; {succ(L,M), arg(L,A,AA)}, + call(P,AA), seqmap_args(P,M,N,A) + ). + +seqmap_args(P,L,N,A,B) --> + ( {L>N} -> [] + ; {succ(L,M), arg(L,A,AA), arg(L,B,BB)}, + call(P,AA,BB), seqmap_args(P,M,N,A,B) + ). + +seqmap_args(P,L,N,A,B,C) --> + ( {L>N} -> [] + ; {succ(L,M), arg(L,A,AA), arg(L,B,BB), arg(L,C,CC)}, + call(P,AA,BB,CC), seqmap_args(P,M,N,A,B,C) + ). + + + +%%% ------------------------------------------------------------------ +%%% These are for sequence building DCGs. +%%% ------------------------------------------------------------------ + + + +%% out(?X)// is det. +% +% Equivalent to [X]. prepends X to the difference list represented by +% the DCG state variables. +out(L,[L|L0],L0). + + +% SNOBOL4ish rules +% +% Others: +% maxarb +% pos rpos +% tab rtab +% rem + + +%% any(+L:list(_))// is nondet. +% Matches any element of L. +any(L) --> [X], {member(X,L)}. + +%% notany(+L:list(_))// is nondet. +% Matches anything not in L. +notany(L) --> [X], {maplist(dif(X),L)}. + +%% arb// is nondet. +% Matches an arbitrary sequence. Proceeds cautiously. +arb --> []; [_], arb. + +%% arbno(+P:phrase)// is nondet. +% Matches an arbitrary number of P. Proceeds cautiously. +% Any variables in P are shared across calls. +arbno(P) --> []; P, arbno(P). + +%% bal// is nondet. +% Matches any expression with balanced parentheses. +bal --> balexp, arbno(balexp). +balexp --> "(", bal, ")". +balexp --> notany("()"). + +%% span(+L:list(_))// is nondet. +% Matches the longest possible sequence of symbols from L. +span(L,A,[]) :- any(L,A,[]). +span(L) --> any(L), span(L). +span(L), [N] --> any(L), [N], { maplist( dif( N), L) }. + +%% break(+L:list(_))// is nondet. +% Matches the longest possible sequence of symbols not in L. +break(L,A,[]) :- notany(L,A,[]). +break(L) --> notany(L), break(L). +break(L), [N] --> notany(L), [N], { member(N,L) }. + +%% len(N:natural)// is nondet. +% Matches any N symbols. +len(0) --> []. +len(N) --> [_], ({var(N)} -> len(M), {succ(M,N)}; {succ(M,N)}, len(M)). + + +%% //(+P:phrase(A), ?C:list(A), ?S1:list(A), ?S2:list(A)) is nondet. +%% //(+P:phrase(A), +C:phrase(A), ?S1:list(A), ?S2:list(A)) is nondet. +% +% Sequence capture operator - captures the matching sequence C of any +% phrase P, eg. +% == +% ?- phrase(paren(arb)//C,"(hello)world",_) +% C = "(hello)". +% true +% == +% If nonvar(C) and C is a phrase, it is called after calling P. + +//(H,C,L,T) :- + ( var(C) + -> phrase(H,L,T), append(C,T,L) + ; phrase(H,L,T), phrase(C,L,T) + ). + +%%% ------------------------------------------------------------------ +%%% These are for character sequences DCGs. + +%% writedcg(+P:phrase) is nondet. +% +% Run the phrase P, which must be a standard list-of-codes DCG, +% and print the output. +writedcg(Phrase) :- + phrase(Phrase,Codes), + format('~s',[Codes]). + +%% null// is det. +% Empty string. +null --> "". + +%% cr// is det. +% Carriage return "\n". +cr --> "\n". + +%% sp// is det. +% Space " ". +sp --> " ". + +%% fs// is det. +% Full stop (period) ".". +fs --> ".". + +%% fssp// is det. +% Full stop (period) followed by space. +fssp --> ". ". + +%% tb// is det. +% Tab "\t". +tb --> "\t". + +%% comma// is det. +% Comma ",". +comma --> ",". + +%% commasp// is det. +% Comma and space ", ". +commasp --> ", ". + +%% at(X:atom)// is det. +% Generate code list for textual representation of atom X. +at(A,C,T) :- atomic(A), with_output_to(codes(C,T),write(A)). + +%% wr(X:term)// is det. +% Generate the list of codes for term X, as produced by write/1. +wr(X,C,T) :- ground(X), with_output_to(codes(C,T),write(X)). + +%% wq(X:term)// is det. +% Generate the list of codes for term X, as produced by writeq/1. +wq(X,C,T) :- ground(X), with_output_to(codes(C,T),writeq(X)). + +%% str(X:term)// is det. +% Generate the list of codes for string X, as produced by writeq/1. +str(X,C,T):- string(X), with_output_to(codes(C,T),write(X)). + +%% fmt(+F:atom,+Args:list)// is det +% Generate list of codes using format/3. +fmt(F,A,C,T) :- format(codes(C,T),F,A). + +%% brace(P:phrase)// is nondet. +% Generate "{" before and "}" after the phrase P. +brace(A) --> "{", A, "}". + +%% paren(P:phrase)// is nondet. +% Generate "(" before and ")" after the phrase P. +paren(A) --> "(", A, ")". + +%% sqbr(P:phrase)// is nondet. +% Generate "[" before and "]" after the phrase P. +sqbr(A) --> "[", A, "]". + +%% q(P:phrase(list(code)))// is nondet. +% Generate list of codes from phrase P, surrounds it with single quotes, +% and escapes (by doubling up) any internal quotes so that the +% generated string is a valid quoted string. Must be list of codes DCG. +q(X,[39|C],T) :- T1=[39|T], escape_with(39,39,X,C,T1). % 39 is ' + +%% qq(P:phrase(list(code)))// is nondet. +% Generate list of codes from phrase P, surrounds it with double quotes, +% and escapes (by doubling up) any double quotes so that the +% generated string is a valid double quoted string. +qq(X,[34|C],T) :- T1=[34|T], escape_with(34,34,X,C,T1). % 34 is " + +% escape difference list of codes with given escape character +escape_codes(_,_,A,A,A). +escape_codes(E,Q,[Q|X],[E,Q|Y],T) :-escape_codes(E,Q,X,Y,T). +escape_codes(E,Q,[A|X],[A|Y],T) :- Q\=A, escape_codes(E,Q,X,Y,T). + +%% escape_with(E:C, Q:C, P:phrase(list(C)))// is nondet. +% +% Runs phrase P to generate a list of elements of type C and +% then escapes any occurrences of Q by prefixing them with E, e.g., +% =|escape_with(92,39,"some 'text' here")|= escapes the single quotes +% with backslashes, yielding =|"some \'text\' here"|=. +escape_with(E,Q,Phrase,L1,L2) :- + phrase(Phrase,L0,L2), + escape_codes(E,Q,L0,L1,L2). + +%% escape(Q:C, P:phrase(list(C)))// is nondet. +% +% Runs phrase P to generate a list of elements of type C and +% then escapes any occurrences of Q by doubling them up, e.g., +% =|escape(39,"some 'text' here")|= doubles up the single quotes +% yielding =|"some ''text'' here"|=. +escape(Q,A) --> escape_with(Q,Q,A). + +%% padint( +N:integer, +Range, +X:integer)// is nondet. +% +% Write integer X padded with zeros ("0") to width N. +padint(N,L..H,X,C,T) :- + between(L,H,X), + format(atom(Format),'~~`0t~~d~~~d|',[N]), + format(codes(C,T),Format,[X]). + +difflength(A-B,N) :- unify_with_occurs_check(A,B) -> N=0; A=[_|T], difflength(T-B,M), succ(M,N). + +% tail recursive version +difflength_x(A-B,M) :- difflength_x(A-B,0,M). +difflength_x(A-B,M,M) :- unify_with_occurs_check(A,B). +difflength_x([_|T]-A,M,N) :- succ(M,L), difflength_x(T-A,L,N). + + +%term_codes(T,C) :- with_output_to(codes(C),write(T)). + + + + +% try these? +%setof(X,Q,XS,S1,S2) :- setof(X,phrase(Q,S1,S2),XS). +%findall(X,Q,XS,S1,S2) :- findall(X,phrase(Q,S1,S2),XS). + +with_nth_arg(K,P,T1,T2) :- + functor(T1,F,N), + functor(T2,F,N), + with_nth_arg(N,K,P,T1,T2). + +with_nth_arg(K,K,P,T1,T2) :- + arg(K,T1,C1), phrase(P,C1,C2), + arg(K,T2,C2), succ(N,K), + copy_args(N,T1,T2). + +with_nth_arg(N,K,P,T1,T2) :- + arg(N,T1,C), + arg(N,T2,C), + succ(M,N), + with_nth_arg(M,K,P,T1,T2). + +copy_args(0,_,_) :- !. +copy_args(N,T1,T2) :- + succ(M,N), arg(N,T1,X), arg(N,T2,X), + copy_args(M,T1,T2). + + +%% setof( Template:X, Phrase:phrase(S), Results:list(X), S1:S, S2:S) is nondet. +setof(X,Q,XS,S1,S2) :- setof(X,phrase(Q,S1,S2),XS). + +%% findall( Template:X, Phrase:phrase(S), Results:list(X), S1:S, S2:S) is nondet. +findall(X,Q,XS,S1,S2) :- findall(X,phrase(Q,S1,S2),XS). + + +:- meta_predicate lift(0,?,?), lift(1,?,?), lift(2,?,?). + +lift(P) --> { call(P) }. +lift(P,X) --> { call(P,X) }. +lift(P,X,Y) --> { call(P,X,Y) }. + + + +%% seqmap_with_progress( +Period:natural, +Pred:pred(A,S,S), +X:list(A))// is nondet. +%% seqmap_with_progress( +Period:natural, +Pred:pred(A,B,S,S), +X:list(A), ?Y:list(B))// is nondet. +% +% Just like seqmap//2 and seqmap//3 but prints progress and memory usage statistics while running. +% Information is printed every Period iterations. The first input list must be +% valid list skeleton with a definite length, so that a percentage progress indicator +% can be printed. +seqmap_with_progress(E,P,X) --> {progress_init(E,X,Pr0)}, smp(X,P,Pr0). +seqmap_with_progress(E,P,X,Y) --> {progress_init(E,X,Pr0)}, smp(X,Y,P,Pr0). + +smp([],_,Pr) --> !, {progress_finish(Pr)}. +smp([X|XX],P,Pr1) --> {progress_next(Pr1,Pr2)}, call(P,X), !, smp(XX,P,Pr2). + +smp([],_,_,Pr) --> !, {progress_finish(Pr)}. +smp([X|XX],[Y|YY],P,Pr1) --> {progress_next(Pr1,Pr2)}, call(P,X,Y), !, smp(XX,YY,P,Pr2). + + +progress_init(E,X,pr(T0,T,E,0,0)) :- length(X,T), get_time(T0). +progress_finish(Pr) :- + progress_next(Pr,_), + get_time(T1), Pr=pr(T0,N,_,_,_), + format('\nFinished ~w items in ~3g minutes.\n',[N,(T1-T0)/60]). + +progress_next(pr(T0,Total,E,N,E),pr(T0,Total,E,M,1)) :- !, + succ(N,M), + stats(Codes), + get_time(T1), + format('~s | done ~0f% in ~3g s \r', [Codes,100*N/Total,T1-T0]), + flush_output. + +progress_next(pr(T0,T,E,N,C),pr(T0,T,E,M,D)) :- succ(C,D), succ(N,M). + + +%% stats is det. +%% stats( -Codes:list(code)) is det. +% +% Print or return memory usage statistics. +stats :- !, + stats(Codes), + format('~s\r',[Codes]), + flush_output. + +stats(Codes) :- !, + statistics(heapused,Heap), + statistics(localused,Local), + statistics(globalused,Global), + statistics(trailused,Trail), + format(codes(Codes), 'heap: ~t~D ~18| local: ~t~D ~36| global: ~t~D ~57| trail: ~t~D ~77|', + [Heap,Local,Global,Trail]). + + +%% select_def_option(+Option,+Default,+OptsIn,-OptsOut) is det. +% +% Exactly the same as select_option/4 but with a different argument order: +% =|option(Opt,Def,Opts1,Opts2)|= is equivalent to =|select_option(Opt,Opt1,Opts2,Def)|=. +% Changed argument order allows multiple option selection to be written in +% DCG notation with the options list as the state. + +select_def_option(Opt,Def,Opts1,Opts2) :- select_option(Opt,Opts1,Opts2,Def).
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/prolog/library/dot.pl Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,140 @@ +:- module(dot,[ + dotrun/4 + , graph_dot/2 + ]). + +/** <module> Graphviz language + + Produces .dot language graphs from relational and functional schemata. + + Graph strucure is as follows: + == + digraph ---> digraph(Name:term, G:list(element)). + subgraph ---> subgraph(Name:term, G:list(element)). + element ---> subgraph + ; option + ; node_opts(list(option)) + ; edge_opts(list(option)) + ; with_opts(element, list(option)) + ; arrow(term,term) % directed edge + ; line(term,term) % undirected edge + ; node(term). + option ---> opt_name=opt_value. + opt_name == atom + opt_value == phrase + == + Graph, node and edge labels can be terms and are written using write/1 for + writing in the dot file. + + --- + Samer Abdallah + Centre for Digital Music, Queen Mary, University of London, 2007 + Department of Computer Science, UCL, 2014 + */ + +:- use_module(fileutils). +:- use_module(dcgu). + + +digraph(Name,G) --> + "digraph ", wr(Name), cr, + dotblock([ overlap=at(false) + , spline=at(true) + , contentrate=at(true) + | G]). + +subgraph(Name,G) --> "subgraph ", wr(Name), cr, dotblock(G). + +dotblock(L) --> brace(( cr, dotlist(L), cr)), cr. +dotline(L) --> "\t", L, ";\n". +dotlist([]) --> "". +dotlist([L|LS]) --> + if(L=dotblock(B), + dotblock(B), + dotline(L)), + dotlist(LS). + + +with_opts(A,Opts) --> phrase(A), sp, sqbr(optlist(Opts)). +optlist(L) --> seq(L,","). + +node_opts(Opts) --> with_opts(at(node), Opts). +edge_opts(Opts) --> with_opts(at(edge), Opts). +nq(A) --> wr(A). +node(A) --> qq(wr(A)). +arrow(A,B) --> node(A), " -> ", node(B). +line(A,B) --> node(A), " -- ", node(B). +(A=B) --> at(A), "=", B. + + +dot_method(M,M) :- member(M,[dot,neato,sfdp,fdp,circo,twopi]). +dot_method(unflatten,M) :- dot_method(unflatten([]),M). +dot_method(unflatten(Opts),M) :- + phrase(("unflatten",seqmap(uopt,Opts)," | dot"),Codes,[]), + atom_codes(M,Codes). + +uopt(l(N)) --> " -l", wr(N). +uopt(fl(N)) --> " -f -l", wr(N). +uopt(c(N)) --> " -c", wr(N). + +%% dotrun( +Method:graphviz_method, +Fmt:atom, G:digraph, +File:atom) is det. +% +% Method determines which GraphViz programs are used to render the graph: +% == +% graphviz_method ---> dot ; neato; fdp ; sfdp ; circo ; twopi +% ; unflatten +% ; unflatten(list(unflatten_opt)). +% unflatten_opt ---> l(N:natural) % -l<N> +% ; fl(N:natural) % -f -l<N> +% ; c(natural). % -c<N> +% == +% The unflatten method attempts to alleviate the problem of very wide graphs, +% and implies that dot is used to render the graph. The default option list is empty. +% See man page for unflatten for more information. +% TODO: Could add more options for dot. +dotrun(Meth1,Fmt,Graph,File) :- + dot_method(Meth1,Meth), + member(Fmt,[ps,eps,pdf]), + format(atom(Cmd),'~w -T~w > "~w.~w"',[Meth,Fmt,File,Fmt]), + format('Running: ~w ...\n',Cmd), + with_output_to_file(pipe(Cmd),writedcg(Graph)). + +%% graph_dot( +G:digraph, +File:atom) is det. +graph_dot(Graph,File) :- + with_output_to_file(File,writedcg(Graph)). + +%%% Options + +% Graph options +dotopt(graph,[size,page,ratio,margin,nodesep,ranksep,ordering,rankdir, + pagedir,rank,rotate,center,nslimit,mclimit,layers,color,href,splines, + start,epsilon,root,overlap, mindist,'K',maxiter]). + + +% Node options +dotopt(node, [label,fontsize,fontname,shape,color,fillcolor,fontcolor,style, + layer,regular,peripheries,sides,orientation,distortion,skew,href,target, + tooltip,root,pin]). + +% Edge options +dotopt(edge, [minlen,weight,label,fontsize,fontname,fontcolor,style,color, + dir,tailclip,headclip,href,target,tooltip,arrowhead,arrowtail, + headlabel,taillabel,labeldistance,port_label_distance,decorate, + samehead,sametail,constraint,layer,w,len]). + + +% Node options values +dotopt(node, label, A) :- ground(A). +dotopt(node, fontsize, N) :- between(1,256,N). % arbitrary maximum! +dotopt(node, fontname, A) :- ground(A). +dotopt(node, shape, + [ plaintext,ellipse,box,circle,egg,triangle,diamond, + trapezium,parallelogram,house,hexagon,octagon]). +dotopt(node, style, [filled,solid,dashed,dotted,bold,invis]). + + +% Edge options values +dotopt(edge, fontsize, N) :- between(1,256,N). % arbitrary maximum! +dotopt(edge, label, A) :- ground(A). +dotopt(node, fontname, A) :- ground(A). +dotopt(node, style, [solid,dashed,dotted,bold,invis]).
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/prolog/library/fileutils.pl Sun Mar 23 16:05:36 2014 +0000 @@ -0,0 +1,199 @@ +:- module(fileutils, [ + with_file/2, + with_stream/3, + read_lines/2, + with_output_to_file/2, + with_output_to_file/3, + with_input_from_file/2, + with_input_from_file/3, + write_file_with/3, + write_file_with/4, + with_input_from/2, + find_file/3, + match_file/2, + file_under/4 + ]). + +:- meta_predicate + with_output_to_file(?,0), + with_output_to_file(?,0,+), + with_input_from_file(?,0), + with_input_from_file(?,0,+), + write_file_with(?,?,0), + write_file_with(?,?,0,?), + with_input_from(+,0), + with_stream(0,?,0), + with_file(?,0). + + +%% with_stream( :Opener, -Stream, :Goal) is semidet. +% +% Base predicate for doing things with stream. Opener is a goal which must +% prepare the stream, Stream is the variable which will hold the valid +% stream handle, and Goal is called with the stream open. The stream is +% guaranteed to be closed on exit. Stream will remain unbound on exit. +% NB: the idea is that Opener and Goal share the Stream variable, eg: +% == +% with_stream( open('out.txt',write,S), S, writeln(S,'Hello!')). +% with_stream( open('in.txt',read,S), S, read(S,T)). +% == +with_stream(Opener,Stream,Goal) :- + copy_term(t(Opener,Stream,Goal),t(O,S,G)), + setup_call_cleanup(O,G,close(S)). + + +%% with_file( :Opener, :Goal) is semidet. +% +% Call Goal with an open file as specified by Opener, which can be +% * open( +Filename, +Mode, @Stream) +% * open( +Filename, +Mode, +Options, @Stream) +% Opener is used to call open/3 or open/4. +% +% @deprecated Use with_stream/3 instead. +with_file(open(File,Mode,Stream),Goal) :- + with_stream(open(File,Mode,Stream),Stream,Goal). + +with_file(open(File,Mode,Stream,Options),Goal) :- + with_stream(open(File,Mode,Stream,Options), Stream, Goal). + +%% with_output_to_file( +File, :Goal) is semidet. +%% with_output_to_file( +File, :Goal, +Opts) is semidet. +% +% Call Goal redirecting output to the file File, which is opened as with +% open(File,write,Str) or open(File,write,Opts,Str). +% However, if the option mode(Mode) is present, it is removed from the +% list (leaving Opts1) and the file is opened as with open(File,Mode,Opts1,Str). +% The default mode is write. +with_output_to_file(File,Goal) :- with_output_to_file(File,Goal,[]). +with_output_to_file(File,Goal,Opts) :- write_file_with(File,S,with_output_to(S,Goal),Opts). + + +%% with_input_from_file( +File, :Goal) is semidet. +%% with_input_from_file( +File, :Goal, +Opts) is semidet. +% +% Call Goal redirecting output to the file File, which is opened as with +% open(File,write,Str) or open(File,write,Opts,Str). +with_input_from_file(File,Goal) :- with_input_from_file(File,Goal,[]). +with_input_from_file(File,Goal,Opts) :- + with_stream( open(File,read,S,Opts), S, with_input_from(S,Goal)). + +%% with_input_from( +Source, :Goal) is semidet. +% +% Temporarily switch current input to object specified by Source while calling Goal as in once/1. +% Source is a term like that supplied to with_output_to/2 and can be any of: +% * A stream handle or alias. +% * atom(+Atom) +% * codes(+Codes) +% * chars(+Chars) +% * string(+String) + +with_input_from(atom(A),G) :- !, + setup_call_cleanup( + atom_to_memory_file(A,MF), + setup_call_cleanup( + open_memory_file( MF, read, S), + with_input_from(S,G), + close(S) + ), + free_memory_file(MF) + ). + +with_input_from(codes(Codes),G) :- !, atom_codes(Atom,Codes), with_input_from(atom(Atom),G). +with_input_from(chars(Chars),G) :- !, atom_chars(Atom,Chars), with_input_from(atom(Atom),G). +with_input_from(string(Str),G) :- !, string_to_atom(Str,Atom), with_input_from(atom(Atom),G). + +with_input_from(S,G) :- is_stream(S), !, + current_input(S0), + setup_call_cleanup(set_input(S),once(G),set_input(S0)). + + +%% write_file_with( +File, @Stream, :Goal, +Options:list) is semidet. +%% write_file_with( +File, @Stream, :Goal) is semidet. +% +% Call Goal after opening the named file and unifying Stream with a +% valid stream. The file is guaranteed to be closed and Stream unbound +% on exit. Any options are pased to open/4, except for mode(Mode), +% which defaults to write and determines whether the file is opened +% in write or append mode. + +write_file_with(File,Stream,Goal) :- write_file_with(File,Stream,Goal,[]). +write_file_with(File,Stream,Goal,Options) :- + select_option(mode(Mode),Options,Options1,write), + must_be(oneof([write,append]),Mode), + with_stream( + open(File,Mode,Stream,Options1), + Stream, + Goal + ). + + +%% read_lines( +Stream, -Lines:list(list(integer))) is semidet. +% +% Read all lines from Stream and return a list of lists of character codes. +read_lines(Stream,Lines) :- + read_line_to_codes(Stream,Line), + ( Line=end_of_file + -> Lines=[] + ; Lines=[Line|Lines1], + read_lines(Stream,Lines1)). + + +%% match_file(+Spec,-File) is nondet. +% +% Unify File with a filename that matches given spec. Yields +% alternative matches on backtracking. Can give relative as +% well as absolute paths. +match_file(Spec,File) :- + expand_file_search_path(Spec,Path), + expand_file_name(Path,Files), + member(File,Files). + + +%% file_under( +Root, +Pattern, -File, -Path) is nondet. +% +% Enumerate all files under directory root whose names match Pattern. +% Root can be a unary term as understood by expand_file_search_path/2. +% On exit, File is the fully qualified path to the file and path is +% a list of directory names represented as atoms. +% Returns absolute file paths only. + +file_under(RootSpec,Pattern,File,Path) :- + expand_file_search_path(RootSpec,Root), + file_under(Root,Pattern,File,Path,[]). + +file_under(Root,Pattern,File) --> {file_in(Root,Pattern,File)}. +file_under(Root,Pattern,File) --> + { directory_in(Root,Full,Rel) }, [Rel], + file_under(Full,Pattern,File). + +file_in(Root,Pattern,File) :- + atomic_list_concat([Root,Pattern],'/',Spec), + absolute_file_name(Spec,[expand(true),solutions(all)],File). + +directory_in(Root,Dir,DirName) :- + atom_concat(Root,'/*',Spec), + absolute_file_name(Spec,[file_type(directory),expand(true),solutions(all)],Dir), + file_base_name(Dir,DirName). + + +%% find_file( +FileSpec, +Extensions:list(atom), -File:atom) is nondet. +% +% Looks for files matching FileSpec ending with one of the given extensions. +% FileSpec is initially passed to expand_file_search_path/2 and so can be a unary term. +% The resulting atom can include wildcards ('*', '?', '{..}'), environment +% variables ('$var') and an optional leading '~' which is equivalent to '$HOME'. +% (See expand_file_name/2). This predicate succeeds once for +% each readable file matching FileSpec and ending with one of the extensions +% in Extensions. NB. no dot is prepended to extensions: if you need '*.blah' then +% put '.blah' in Extensions. +% Returns ABSOLUTE file paths. + +find_file(Spec,Exts,File) :- + match_file(Spec,Path), + match_extension(Path,Exts), + absolute_file_name(Path,[access(read)],File). + +match_extension(Path,Exts) :- + downcase_atom(Path,PathLower), member(Ext,Exts), + atom_concat(_,Ext,PathLower). +