--- /dev/null
+;;; showterm.el --- Show Prolog terms as trees in Emacs
+
+
+;; To try it, you need the following programs installed:
+;;
+;; - Scryer Prolog
+;; - `dot' (from Graphviz)
+;; - `convert' (from ImageMagick)
+;;
+;; Copy showterm.el and showterm.pl to the same directory,
+;; say ~/scryer-prolog/tools/, and add to your .emacs:
+;;
+;; (load "~/scryer-prolog/tools/showterm.el")
+;;
+;; If necessary, set `scryer-prolog-path' to the Scryer Prolog
+;; executable by adding to your .emacs (adapting as appropriate):
+;;
+;; (setq scryer-prolog-path "/usr/local/bin/scryer-prolog")
+;;
+;; The function `showterm' draws the Prolog term in the region as a
+;; tree. You can invoke it with M-x showterm RET, or for example by
+;; binding it to a key in your .emacs, and then pressing that key:
+;;
+;; (global-set-key [f12] 'showterm)
+;;
+;; Enjoy!
+
+(defvar scryer-prolog-path
+ (or (executable-find "scryer-prolog")
+ "~/scryer-prolog/target/release/scryer-prolog")
+ "Path of the Scryer Prolog executable.")
+
+(defvar showterm-pl-file
+ (format "%s%s"
+ (if load-in-progress
+ (file-name-directory load-file-name)
+ default-directory)
+ "showterm.pl")
+ "Path to showterm.pl, used to produce a graph as input for `dot'.")
+
+(defvar showterm-pixel-width 500
+ "Width of the drawn term in pixels.")
+
+(defun showterm (arg)
+ (interactive "p")
+ (unless (use-region-p)
+ (error "no region"))
+ (let* ((from (region-beginning))
+ (to (region-end))
+ (str (buffer-substring-no-properties from to))
+ op-declarations)
+ (save-excursion
+ ;; rudimentary support for op/3 directives.
+ (goto-char (point-min))
+ (while (re-search-forward "^:-[ \t]*\\(op(.*,.*,.*)[ \t]*\\.\\).*$" nil t)
+ (push (match-string 1) op-declarations))
+ (setq op-declarations (reverse op-declarations)))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (let ((proc (start-process "scryer-showterm" (current-buffer)
+ scryer-prolog-path
+ showterm-pl-file)))
+ (showterm-wait-for-prompt)
+ (while op-declarations
+ (send-string proc (format "%s\n" (pop op-declarations)))
+ (showterm-wait-for-prompt))
+ (send-string proc (concat "dot, halt.\n" str " .\n"))
+ (showterm-wait-for-process proc t)
+ (setq str (buffer-string)))
+ (erase-buffer)
+ (let ((proc (start-process "dot" (current-buffer) "dot"
+ "-Gdpi=300"
+ "-T" "png")))
+ (send-string proc str)
+ (process-send-eof proc)
+ (showterm-wait-for-process proc)
+ (setq str (buffer-string))
+ (erase-buffer))
+ (let ((proc (let (process-connection-type)
+ (start-process "convert" (current-buffer)
+ "convert"
+ "png:-"
+ "-gravity" "center"
+ "-background" "white"
+ "-scale" (format "%dx%d"
+ showterm-pixel-width
+ showterm-pixel-width)
+ "-extent" (format "%dx" showterm-pixel-width)
+ "png:-"))))
+ (process-send-string proc str)
+ (process-send-eof proc)
+ (showterm-wait-for-process proc))
+ (let ((img (create-image (buffer-string) 'png t))
+ (fit-window-to-buffer-horizontally t)
+ (buf (get-buffer-create "term-tree")))
+ (with-current-buffer buf
+ (erase-buffer)
+ (setq mode-line-format ""
+ cursor-in-non-selected-windows nil)
+ (insert-image img)
+ (insert "\n"))
+ (fit-window-to-buffer (display-buffer-in-side-window buf '((side . right))))))))
+
+
+(defun showterm-wait-for-prompt ()
+ (let ((str (regexp-quote "?- "))
+ seen)
+ (while (not seen)
+ (accept-process-output nil 0.01)
+ (save-excursion
+ (move-beginning-of-line nil)
+ (setq seen (looking-at str))))
+ (erase-buffer)))
+
+(defun showterm-wait-for-process (proc &optional check-for-error)
+ (set-process-sentinel proc (lambda (proc event)))
+ (while (eq (process-status proc) 'run)
+ (accept-process-output nil 0.1)
+ (when check-for-error
+ (goto-char (point-min))
+ (when (looking-at "caught: error(syntax_error")
+ (delete-process proc)
+ (error "Syntax error, term cannot be displayed")))))
--- /dev/null
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ Describe a term in GraphViz DOT format.
+ Part of Scryer Prolog.
+
+ Example:
+
+ ?- dot(a+b).
+ %@ graph G {
+ %@ c [label = "(+)/2", fontname="courier bold"];
+ %@ c -- c1;
+ %@ c1 [label = "a", style=filled, fontname="courier bold", fillcolor=lightcyan];
+ %@ c -- c2;
+ %@ c2 [label = "b", style=filled, fontname="courier bold", fillcolor=lightcyan];
+ %@ }
+ %@ true
+ %@ ; ...
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+:- use_module(library(clpz)).
+:- use_module(library(dcgs)).
+:- use_module(library(lists)).
+:- use_module(library(format)).
+:- use_module(library(assoc)).
+:- use_module(library(pairs)).
+:- use_module(library(atts)).
+
+:- attribute named/0.
+
+dot :-
+ read_term(Term, [variables(Vs),variable_names(NVs0)]),
+ maplist(eq_pair, NVs0, NVPairs),
+ pairs_values(NVPairs, NamedVariables),
+ maplist(mark_var_as_named, NamedVariables),
+ list_to_assoc(NVPairs, UsedNames),
+ foldl(name_remaining_variables, Vs, NVs0-UsedNames, NVs-_),
+ dot(Term, NVs).
+
+eq_pair(A=B, A-B).
+
+mark_var_as_named(Var) :-
+ put_atts(Var, named).
+
+name_remaining_variables(Var, NVs0-UsedNames0, NVs-UsedNames) :-
+ ( get_atts(Var, named) ->
+ NVs-UsedNames = NVs0-UsedNames0
+ ; unused_name(UsedNames0, 0, Name),
+ NVs = [Name=Var|NVs0],
+ put_assoc(Name, UsedNames0, Var, UsedNames)
+ ).
+
+unused_name(UsedNames, N0, Name) :-
+ n_var_name(N0, Name0),
+ ( get_assoc(Name0, UsedNames, _) ->
+ N #= N0 + 1,
+ unused_name(UsedNames, N, Name)
+ ; Name = Name0
+ ).
+
+n_var_name(N, VarName) :-
+ char_code('A', AC),
+ LN #= N mod 26 + AC,
+ char_code(LC, LN),
+ NN #= N // 26,
+ zcompare(C, NN, 0),
+ varname_(C, NN, LC, VarName).
+
+varname_(=, _, LC, VarName) :-
+ atom_chars(VarName, ['_', LC]).
+varname_(>, NN, LC, VarName) :-
+ number_chars(NN, NNChars),
+ atom_chars(VarName, ['_', LC | NNChars]).
+
+
+dot(Term) :-
+ dot(Term, []).
+
+dot(Term, NVs) :-
+ phrase(term_labels(Term, NVs, 'c'), Ls),
+ phrase(("graph G {\n",
+ dots(Ls),
+ "}\n"), DOT),
+ format("~s", [DOT]).
+
+dots([]) --> [].
+dots([D|Ds]) --> dot_(D), dots(Ds).
+
+dot_(node_label(C, F, A)) -->
+ format_(" ~w [label = \"~q\", fontname=\"courier bold\"];\n", [C,F/A]).
+dot_(connection(A,B)) -->
+ format_(" ~w -- ~w;\n", [A,B]).
+dot_(atomic(C,L)) -->
+ format_(" ~w [label = \"~q\", style=filled, fontname=\"courier bold\", fillcolor=lightcyan];\n", [C,L]).
+dot_(variable(C,L)) -->
+ format_(" ~w [label = \"~w\", shape=box, fontname=\"courier bold\", style=filled, fillcolor=aquamarine];\n", [C,L]).
+
+term_labels(Term, NVs, C0) -->
+ ( { atomic(Term) } -> [atomic(C0, Term)]
+ ; { var(Term) } ->
+ ( { member(Name=Var, NVs), Var == Term } ->
+ [variable(C0,Name)]
+ ; [variable(C0,Term)]
+ )
+ ; { functor(Term, F, A),
+ Term =.. [F|Args] },
+ [node_label(C0, F, A)],
+ all_subterms(Args, NVs, C0, 1)
+ ).
+
+all_subterms([], _, _, _) --> [].
+all_subterms([L|Ls], NVs, C0, N0) -->
+ [connection(C0, C1)],
+ { phrase(format_("~w~w", [C0,N0]), Chars),
+ atom_chars(C1, Chars),
+ N #= N0 + 1 },
+ term_labels(L, NVs, C1),
+ all_subterms(Ls, NVs, C0, N).
projects / scryer-prolog.git / commitdiff
