/*  $Id$

    Part of XPCE --- The SWI-Prolog GUI toolkit

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        jan@swi.psy.uva.nl
    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    Copyright (C): 1985-2002, University of Amsterdam

    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

    As a special exception, if you link this library with other files,
    compiled with a Free Software compiler, to produce an executable, this
    library does not by itself cause the resulting executable to be covered
    by the GNU General Public License. This exception does not however
    invalidate any other reasons why the executable file might be covered by
    the GNU General Public License.
*/



:- module(man_manual, []).

:- use_module(library(pce)).
:- use_module(library(persistent_frame)).
:- use_module(library(pce_help_file)).
:- use_module(util).
:- require([ absolute_file_name/3
	   , auto_call/1
	   , default/3
	   , forall/2
	   , ignore/1
	   , send_list/3
	   ]).

resource(man_icon, image, image('32x32/books.xpm')).

:- pce_autoload(event_viewer, library('man/showevent')).

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
			    OVERALL ARCHITECTURE

The following diagram  provides an overall  view of the  design of the
manual tools.

			 ManualTool
			     |
			     | (select)
			     |
			     V		 | ClassBrowser
			   Tools         | ClassHierarchy
                             |		 | TopicBrowser
			     |		 | KeywordBrowser
			     |
			     | (find/browse)
			     V
		   [Type] Name [Summary]
		            /|\
       Examples----/-------- | -----------\
	          /          |             \
	         /           |	            \
             Sources      Textual          Relations
			Attributes    [Type] Name [Summary]


The communication between  the tools is arranged  via messages send to
and possible broadcasted by ManualTool.  These messages are:

    ->request_selection: man_frame, object*, [bool]
	Set the <-selection and <-selection_holder attribute of the
	ManualTool and broadcasts the following messages:

		* SelectionHolder ->release_selection
		* AllTools        ->selected: object*

	If bool == @on, the card viewer is started automatically

    ->tool_focus: object*
        Set the focus of all tools.  Broadcasted to all tools.

    ->relate: object
        Request manual to relate selection to object.

    ->edit_mode: bool
        Switch edit_mode on/off.  Broadcasted to all tools.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- pce_begin_class(man_manual, persistent_frame,
		   "PCE manual main object").

class_variable(geometry,	geometry,		'+0+0').
class_variable(user_scope,	chain,			chain(basic, user),
	 "Default scoping of manual material").
class_variable(edit,		bool,			@off).

variable(selection,		object*,	get,
	 "Currently selected object").
variable(selection_holder,	man_frame*,	get,
	 "Tool holding selection").
variable(tool_focus,		object*,	get,
	 "Arg of last ->tool_focus").
variable(tools,			sheet,		get,
	 "Tool-name --> tool mapping").
variable(edit_mode,		bool,		get,
	 "Can database be edited?").
variable(space,			man_space,	get,
	 "Manual module collection").
variable(focus_history,		chain,		get,
	 "Chain of focused cards").
variable(selection_history,	chain,		get,
	 "Chain of selected cards").
variable(maintainer,		bool,		get,
	 "Indicates the user is a maintainer").
variable(exit_message,		code*,		get,
	 "Message called on exit").
variable(user_scope,		chain,		get,
	 "Types in user's scope").
variable(search_patterns,	chain*,		both,
	 "Search patterns to be highlighted").


		/********************************
		*            CREATE		*
		********************************/

initialise(M, Dir:[directory]) :->
	"Create the manual main object"::
	send(M, send_super, initialise, 'XPCE Manual'),
	send(M, icon, resource(man_icon)),
	send(M, can_resize, @off),
	send(M, done_message, message(M, quit)),
	get(M, class_variable_value, user_scope, Scope),
	get(M, class_variable_value, edit, Edit),
	send(M, slot, maintainer, Edit),
	default(Dir, directory('$PCEHOME/man/reference'), Directory),
	send(M, check_directory, Directory),
	send(M, slot, space, new(Space, man_space(reference, Directory))),
	send(M, slot, tools, new(sheet)),
	send(M, slot, edit_mode, @off),
	send(M, slot, focus_history, new(chain)),
	send(M, slot, selection_history, new(chain)),
	send(M, slot, user_scope, Scope),

	send(Space, attribute, attribute(report_to, M)),
	send(M, append, new(D, dialog)),
	send(M, fill_dialog, D),

	ifmaintainer((
	  send(@pce, exit_message, new(Msg, message(M, save_if_modified))),
          send(M, slot, exit_message, Msg))),

	send(M, check_runtime),
	send(M, report, status, 'For help, see `File'' menu').


unlink(M) :->
	"Manual is destroyed"::
	get(M, space, Space),
	send(Space, delete_attribute, report_to),
	get(M, exit_message, Msg),
	ignore(send(@pce?exit_messages, delete, Msg)),
	send(M, send_super, unlink).


check_directory(M, Dir:directory) :->
	"Check the manual directory"::
	(   send(Dir, exists)
	->  true
	;   send(M, report, error, 'Cannot find manual directory %s', Dir?path)
	).


check_runtime(_M) :->
	"Check for runtime system"::
	(   get(@pce, is_runtime_system, @on)
	->  send(@display, inform,
		 '%s.  %s\n%s %s',
		 'This is a runtime version of XPCE',
		 'Most of the manual will not work.',
		 'Contact xpce-request@swi.psy.uva.nl',
		 'for a information on the development version')
	;   true
	).


fill_dialog(M, D) :->
	send(D, gap, size(5, 5)),
	send(D, append, new(MB, menu_bar)),
	send(MB, append, new(F, popup(file))),
	send(MB, append, new(V, popup(browsers,
				      message(M, start_tool, @arg1)))),
	send(MB, append, new(T, popup(tools,
				      message(M, start_tool, @arg1)))),
	send(MB, append, new(H, popup(history))),

	/* FILE menu */

	send_list(F, append,
		  [ menu_item(about,
			      message(M, about)),
		    menu_item(help,
			      message(M, help)),
		    menu_item(demo_programs,
			      message(M, start_demo),
			      @default, @on),
		    menu_item('ChangeLog',
			      message(M, changelog)),
		    menu_item('FAQ',
			      message(M, faq),
			      @default, @on),
		    new(Prefs, popup(edit_preferences))
	     ]),
	send(Prefs, end_group, @on),
	send_list(Prefs, append,
		  [ menu_item('XPCE User Defaults',
			      message(M, edit_preferences, xpce_user)),
		    menu_item('XPCE System Defaults',
			      message(M, edit_preferences, xpce),
			      end_group := @on),
		    menu_item('Prolog Defaults',
			      message(M, edit_preferences, prolog))
		  ]),
	(   get(@pce, window_system, windows)
	->  send(Prefs, append,
		 menu_item('Prolog Stack Limits',
			   message(M, edit_prolog_registry)))
	;   true
	),
	(   get(M, maintainer, @on)
	->  send_list(F, append,
		      [ menu_item(edit_mode,
				  message(M, toggle_edit_mode))
		      , menu_item(list_modules,
				  message(M, list_modules))
		      , menu_item(list_all_modules,
				  message(M, list_all_modules))
		      , menu_item(save_manual,
				  message(M, save_if_modified, @off),
				  @default, @on,
				  M?modified == @on)
		      ])
	;   true
	),
	send_list(F, append,
		  [ menu_item(quit,
			      message(M, quit)),
		    menu_item(quit_pce,
			      message(M, quit_pce))
		  ]),


	/* BROWSERS menu */

	send_list(V, append,
	     [ menu_item(manual_tools,
			 end_group := @on),
	       menu_item(class_hierarchy),
	       menu_item(class_browser),
	       menu_item(global_objects),
	       menu_item(errors,
			 end_group := @on),
	       menu_item(xpce_predicates,
			 @default,
			 'XPCE/Prolog predicates'),
	       menu_item(prolog_manual,
			 message(M, help_on_prolog),
			 end_group := @on),
	       menu_item(search),
	       menu_item(group_overview),
	       menu_item(examples,	    end_group := @on)
	     ]),
	(    get(M, maintainer, @on)
	->   send_list(V, append,
	     [ menu_item(class_finder,	    end_group := @off)
	     ])
	;    true
	),

	/* TOOLS menu */

	send_list(T, append,
	     [ statistics,
	       visual_hierarchy,
	       inspector,
	       gap,
	       menu_item(event_viewer,
			 message(M, event_viewer)),
	       gap,
	       menu_item(prolog_graphical_tracer,
			 message(M, guitracer)),
	       menu_item(prolog_navigator,
			 message(M, prolog_navigator)),
	       menu_item(prolog_thread_monitor,
			 message(M, thread_monitor),
			 condition :=
			 ?(@prolog, current_prolog_flag, threads) == true),
	       menu_item(emacs,
			 message(M, start_emacs)),
	       gap,
	       menu_item(dialog_editor,
			 message(M, dialog_editor)),
	       menu_item(check_object_base,
			 message(M, check_object_base))
	     ]),

	/* HISTORY menu */

	new(SI, menu_item(selection, @nil, @default, @off,
			  not(message(M?selection_history, empty)))),
	new(FI, menu_item(focus, @nil, @default, @off,
			  not(message(M?focus_history, empty)))),
	send(SI, popup,
	     new(SH, popup(selection, message(M, select_history_menu,
					      selection_history, @arg1)))),
	send(FI, popup,
	     new(FH, popup(focus, message(M, select_history_menu,
					  focus_history, @arg1)))),

	send(SH, update_message, message(M, update_history_menu,
					 selection_history, @receiver)),
	send(FH, update_message, message(M, update_history_menu,
					 focus_history, @receiver)),
	send(H, append, SI),
	send(H, append, FI),

	send(D, append, new(label)).


		/********************************
		*         STARTING TOOLS	*
		********************************/

start_tool(M, ToolName:name, Tool:frame) :<-
	"Start named tool"::
	(   get(M?tools, value, ToolName, Tool)
	->  send(Tool, expose)
	;   create_tool(M, ToolName, Tool),
	    send(Tool, open)
	->  send(M, register_tool, ToolName, Tool)
	;   send(@display, inform, 'Failed to start %s', ToolName)
	).

start_tool(M, ToolName:name) :->
	"Start named tool"::
	get(M, start_tool, ToolName, _).

register_tool(M, Name:name, Tool:man_frame) :->
	"Register frame as a menual tool"::
	send(Tool, slot, tool_name, Name),
	send(M?tools, append, attribute(Name, Tool)).


expose_tool(M, ToolName:name) :->
	"Expose named tool"::
	get(M?tools, value, ToolName, Tool),
	send(Tool, expose).


create_tool(M, Name, Tool) :-
	tool_class(Name, M, Term),
	new(Tool, Term).

tool_class(class_browser,	M, man_class_browser(M)).
tool_class(class_finder,	M, man_class_browser(M)).
tool_class(class_hierarchy,	M, man_class_hierarchy(M)).
tool_class(search,		M, man_search_tool(M)).
tool_class(topics,		M, man_topic_browser(M)).
tool_class(card_viewer,		M, man_card_editor(M)).
tool_class(statistics,		M, man_statistics(M)).
tool_class(inspector,		M, isp_frame(M)).
tool_class(visual_hierarchy,	M, vis_frame(M)).
tool_class(global_objects,	M, man_object_browser(M)).
tool_class(errors,		M, man_error_browser(M)).
tool_class(manual_tools,	M,
	   man_module_browser(M, tools, man_browser_card, 'Manual Tools')).
tool_class(xpce_predicates,     M,
	   man_module_browser(M, predicates,
			      man_predicate_card, 'XPCE/Prolog Predicates')).
tool_class(examples,		M,
	   man_module_browser(M, examples, man_example_card, 'XPCE Examples')).
tool_class(changes,		M,
	   man_module_browser(M, changes, man_change_card, 'XPCE Changes')).
tool_class(group_overview,	M,
	   man_group_browser(M, groups, 'Group Browser')).


		/********************************
		*          DESTROYING		*
		********************************/

destroy_tool(M, Tool:man_frame) :->
	"Destroy a tool"::
	(   get(M, selection_holder, Tool)
	->  ignore(send(Tool, release_selection)),	% TBD: forward
	    send(M, slot, selection_holder, @nil)
	;   true
	),
	send(M?tools, for_all,
	     if(@arg1?value == Tool,
		message(M?tools, delete, @arg1?name))),
	send(Tool, destroy).


quit(M) :->
	"Quit Manual Tool"::
	send(M, save_if_modified),
%	send(@display, confirm, 'Quit all manual tools?'),
	send(M?tools, for_all, message(@arg1?value, quit)),
	send(M, destroy).


quit_pce(M) :->
	"Exit from PCE process"::
	send(M, save_if_modified),
	send(@display, confirm, 'Really exit PCE?'),
	send(@pce, die).


		 /*******************************
		 *	   SAVE/MODIFIED	*
		 *******************************/

modified(M, Modified:bool) :<-
	"See if manual database has been modified"::
	(   (   get(M?space, modified, @on)
	    ;   object(@man_classification),
		get(@man_classification, modified, @on)
	    )
	->  Modified = @on
	;   Modified = @off
	).


save_if_modified(M, Ask:[bool]) :->
	"Save if some part has been modified"::
	(   get(M, modified, @on)
	->  (   Ask \== @on
	    ;   send(@display, confirm, 'Manual Database is modified. Save?')
	    ), !,
	    send(M?space, save_some),
	    ClassifyTab = @man_classification,
	    (	object(ClassifyTab),
		get(ClassifyTab, modified, @on)
	    ->	send(M, report, progress,
		     'Saving %s ...', ClassifyTab?file?base_name),
		send(ClassifyTab?file, backup),
	        send(ClassifyTab, save_in_file, ClassifyTab?file),
		send(ClassifyTab, modified, @off),
		send(M, report, done)
	    ;	true
	    )
	;   true
	).

		 /*******************************
		 *	    PREFERENCES		*
		 *******************************/

edit_preferences(_, What:name) :->
	"Edit preferences file"::
	auto_call(prolog_edit_preferences(What)).

edit_prolog_registry(_M) :->
	"Edit SWI-Prolog registry settings"::
	auto_call(prolog_edit_preferences(stack_sizes)).


		/********************************
		*           MANUAL DATA		*
		********************************/

module(M, Name:name, Create:[bool], Module) :<-
	"Find/create manual module"::
	get(M, space, Space),
	(   send(Space, ensure_loaded, Name)
	->  get(Space, module, Name, Module)
	;   Create == @on
	->  new(Module, man_module(Space, Name))
	;   fail
	).


list_modules(M) :->
	"List associated modules"::
	new(V, view('Loaded Modules')),
	new(D, dialog),
	send(D, append, button(quit, message(D?frame, free))),
	send(D, below, V),
	send(V, tab_stops, vector(200)),
	send(V, font, font(helvetica, roman, 12)),
	send(V, format, '%s\t%s\n\n', 'Module Name', 'Number of Cards'),
	new(NM, number(0)),
	new(NC, number(0)),
	send(M?space?modules, for_all,
	     block(message(NM, plus, 1),
		   message(NC, plus, @arg2?id_table?size),
		   message(V, format, '%s\t%s\n',
			   @arg2?name, @arg2?id_table?size))),
	send(V, caret, 0),
	send(V, format, '%d cards in %d modules\n\n', NC, NM),
	send(V, caret, 0),
	send(V, open).

list_all_modules(M) :->
	"Load and list all modules from the directory"::
	send(M?space, load_all_modules),
	send(M, list_modules).


		 /*******************************
		 *	    VIEW FILES		*
		 *******************************/

changelog(_M) :->
	"View ChangeLog"::
	get(@pce, home, Home),
	get(string('%s/ChangeLog', Home), value, Path),
	auto_call(start_emacs),
	send(@emacs, goto_source_location, Path).

:- pce_help_file(pce_faq,     pce_help('pcefaq.hlp')).

faq(_M) :->
	"Start @helper on faq-database"::
	send(@helper, give_help, pce_faq, main).

help_on_prolog(_M) :->
	"Start Prolog help-system"::
	auto_call(user:help).


		/********************************
		*	   ABOUT/LICENCE	*
		********************************/

about([ 'XPCE version %s'+[@pce?version]-boldhuge,
	'Copyright 1992-2007, University of Amsterdam',
	'XPCE comes with ABSOLUTELY NO WARRANTY.',
	'This is free software (LGPL), and you are welcome to',
	'redistribute it under certain conditions.',
	url('http://www.swi-prolog.org/packages/xpce/'),
	'Jan Wielemaker\nAnjo Anjewierden'-italic,
	'HCS\nUniversity of Amsterdam\nKruislaan 419\n1098 VA  Amsterdam\nThe Netherlands'
      ]).


about(M) :->
	"Print about and licence info"::
	new(D, dialog('About XPCE')),
	send(D, transient_for, M),
	about(List),
	maplist(add_about(D), List),
	send(D, append, button(ok, message(D, destroy))),
	send(D, open_centered).

add_about(D, X-Font) :- !,
	add_about(X, Font, D).
add_about(D, X) :-
	add_about(X, normal, D).

add_about(url(Url), Font, D) :- !,
	send(D, append, new(T, text(Url, center, Font))),
	send(T, underline, @on),
	send(T, colour, blue),
	send(T, recogniser,
	     click_gesture(left, '', single,
			   message(@prolog, goto_url, T?string?value))),
	send(T, cursor, hand2),
	send(T, alignment, center).
add_about(Fmt+Args, Font, D) :- !,
	Term =.. [string, Fmt | Args],
	send(D, append, new(T, text(Term, center, Font))),
	send(T, alignment, center).
add_about(Text, Font, D) :-
	send(D, append, new(T, text(Text, center, Font))),
	send(T, alignment, center).

goto_url(Url) :-
	send(@display, busy_cursor),
	(   catch(www_open_url(Url), _, fail)
	->  true
	;   send(@display, inform, 'Failed to open URL')
	),
	send(@display, busy_cursor, @nil).

		 /*******************************
		 *	       HELP		*
		 *******************************/

help(M) :->
	"Give help on the overall manual"::
	give_help(M, @nil, manual).


		/********************************
		*              DEMO		*
		********************************/

:- multifile
	pce_demo:pcedemo/0.

start_demo(M) :->
	send(M, report, progress, 'Starting demo tool ...'),
	use_module(demo(pce_demo), []),
	pce_demo:pcedemo,
	send(M, report, done).


		/********************************
		*            CHECKING		*
		********************************/

check_object_base(_M) :->
	(   auto_call(checkpce)
	->  send(@display, inform, 'Object base is consistent')
	;   send(@display, inform, '%s\n%s',
		 'Object base is corrupted',
		 'See Prolog window for details')
	).


		 /*******************************
		 *     START EXTERNAL TOOLS	*
		 *******************************/

dialog_editor(_M) :->
	"Start the dialog editor"::
	auto_call(dialog).

event_viewer(_) :->
	"Start event-viewer"::
	send(new(event_viewer), open).

guitracer(M) :->
	"Start the GUI tracer for Prolog"::
	(   catch(guitracer, _, fail)
	->  true
	;   send(M, report, error, 'Failed to load GUI tracer')
	).

prolog_navigator(_M) :->
	"Start the source-code navigator"::
	prolog_ide(open_navigator).

thread_monitor(_M) :->
	"Start the thread monitor"::
	prolog_ide(thread_monitor).

start_emacs(_M) :->
	"Start PceEmacs (*scratch* buffer)"::
	auto_call(emacs).


		/********************************
		*            INSPECTOR		*
		********************************/

inspect(M, V:object) :->
	"Start inspector on object"::
	send(M, start_tool, inspector),
	send(M?tools?inspector, inspect, V).


		 /*******************************
		 *	 EXTERNAL INVOKES	*
		 *******************************/

manual(M, Object:'class|behaviour|object') :->
	"Open manual on object"::
	send(M, open),
	(   send(Object, instance_of, class)
	->  send(M, start_tool, class_browser),
	    send(M, request_tool_focus, Object)
	;   (   send(Object, instance_of, behaviour)
	    ;	send(Object, instance_of, man_global)
	    )
	->  send(M, request_selection, @nil, Object, @on)
	;   Object = @Ref,
	    atom(Ref)
	->  send(M, request_selection, @nil, man_global(Ref), @on)
	;   send(M, report, error, 'Cannot start manual from %O', Object),
	    fail
	).


		 /*******************************
		 *	    USER-SCOPING	*
		 *******************************/

:- pce_global(@man_classification, load_man_classification).

load_man_classification(C) :-
	absolute_file_name(library('man/classification.dat'),
			   [access(read)], FileName),
	new(F, file(FileName)),
	get(F, object, C),
	send(C, attribute, file, file(F?absolute_path)),
	send(C, attribute, modified, @off).


in_scope(M, Obj:object) :->
	"Test if object is in current scope"::
	get(M, user_scope, Scope),
	get(Obj, man_id, Id),
	(   (   get(@man_classification, member, Id, Type)
	    ->	send(Scope, member, Type)
	    ;	send(Scope, member, obscure)
	    )
	;   get(Obj, man_creator, Creator),
	    Creator \== built_in,
	    send(Scope, member, user)
	).


user_scope(M, Scope:chain) :->
	"Modify scope and inform tools"::
	(   send(M?user_scope, equal, Scope)
	->  true
	;   send(M, slot, user_scope, Scope),
	    send(M?tools, for_some,
		 message(@arg1?value, user_scope, Scope))
	).


		/********************************
		*         COMMUNICATION		*
		********************************/


request_selection(M, Frame:man_frame*, Obj:any*, Open:[bool]) :->
	"Request to become selection holder"::
	get(M, selection_holder, OldHolder),
	(   OldHolder \== @nil
	->  (   send(OldHolder, release_selection)
	    ->  true
	    ;   send(@display, inform,
		     '%s does not release selection', OldHolder)
	    )
	;   true
	),
	send(M, slot, selection_holder, Frame),
	send(M, slot, selection, Obj),
	send(M, update_history, selection_history, Obj),
	send(M?tools, for_some, message(@arg1?value, selected, Obj)),
	(   \+ get(M?tools, value, card_viewer, _)
	->  (   Open == @on
	    ->  send(M, report, progress, 'Starting Card Viewer ...'),
		send(M, start_tool, card_viewer),
		send(M, report, done)
	    ;   true
	    )
	;   send(M, expose_tool, card_viewer)  % exposes it?
	).


request_tool_focus(M, Obj:object*, ForceClass:[bool]) :->
	"Change the tool focus"::
	send(M, slot, tool_focus, Obj),
	send(M, update_history, focus_history, Obj),
	send(M?tools, for_some, message(@arg1?value, tool_focus, Obj)),
	(   (	ForceClass == @on
	    ;   send(Obj, instance_of, class)
	    ),
	    \+ get(M?tools, value, class_browser, _)
	->  send(M, report, progress, 'Starting Class Browser'),
	    send(M, start_tool, class_browser),
	    send(M, report, done)
	;   send(M, expose_tool, class_browser)	  % exposes it!
	).


maintainer(M, Val:bool) :->
	"Switch maintainer-mode on/off"::
	send(M, slot, maintainer, Val),
	send(M?tools, for_some, message(@arg1?value, maintainer, Val)).


		/********************************
		*             HISTORY		*
		********************************/

update_history(M, History:name, Obj:object*) :->
	"Add object to the requested history"::
	get(M, History, Chain),
	(   get(Chain, head, Obj)
	->  true
	;   ignore(send(Chain, delete, Obj)),
	    send(Chain, prepend, Obj),
	    (   get(Chain, size, S),
	        S > 10
	    ->  send(Chain, delete_tail)
	    ;   true
	    )
	).


update_history_menu(M, History, Menu) :->
	"Update the contents of the history popup"::
	get(M, History, Chain),
	send(Menu, clear),
	send(Chain, for_some,
	     message(Menu, append,
		     create(menu_item,
			    @arg1, @default,
			    when(message(@arg1, instance_of, chain),
				 ?(@pce, instance, string, 'G %s:%s',
				   when(message(@arg1?head, instance_of,
						class),
					@arg1?head?name,
					@arg1?head?context?name),
				   @arg1?head?group),
				 progn(assign(new(X, var),
					      create(string, '%s',
						     @arg1?man_name)),
				       message(X, translate, '\t', ' '),
				       X))))).


select_history_menu(M, History:name, Obj) :->
	"Trap selected history item"::
	(   History == selection_history
	->  send(M, request_selection, @nil, Obj, @on)
	;   send(M, request_tool_focus, Obj)
	).


		/********************************
		*           (UN)RELATE		*
		********************************/

request_relate(M, Obj:object) :->
	"Relate selection to object"::
	request_relate(M, relate, Obj).

request_unrelate(M, Obj:object) :->
	"Destroy relation to selection"::
	request_relate(M, unrelate, Obj).

request_relate(M, CD, Obj) :-
	(   get(M, edit_mode, @on)
	->  (   get(M, selection, Selection),
		Selection \== @nil
	    ->  get(Selection, class_name, SClass),
	        get(Obj, class_name, OClass),
		relate(M, SClass-OClass, CD, Selection, Obj)
	    ;   send(@display, inform, 'First make a selection')
	    )
	;   send(@display, inform, 'Manual is in read-only mode')
	).

relate(_, _-_, create, Obj, Obj) :- !,
	send(@display, inform, 'Can''t relate %s to itself', Obj?man_name).
relate(M, _-_, CD, Selection, Obj) :-
	send(@display, confirm,
	     '%s %s <-> %s', CD, Selection?man_name, Obj?man_name),
	send(M, create_relation, CD, Selection, see_also, Obj),
	send(M, create_relation, CD, Obj, see_also, Selection).


create_relation(M, CD, From, Rel, To) :->
	(   CD == relate
	->  send(From, man_relate, Rel, To),
	    send(M?tools, for_some,
		 message(@arg1?value, related, From, Rel, To))
	;   CD == unrelate
	->  send(From, man_unrelate, Rel, To),
	    send(M?tools, for_some,
		 message(@arg1?value, unrelated, From, Rel, To))
	).


		 /*******************************
		 *	    (UN)INHERIT		*
		 *******************************/

request_inherit(M, Obj:object) :->
	"Relate selection to object"::
	request_inherit(M, relate, Obj).

request_uninherit(M, Obj:object) :->
	"Destroy relation to selection"::
	request_inherit(M, unrelate, Obj).

request_inherit(M, CD, Obj) :-
	(   get(M, edit_mode, @on)
	->  (   get(M, selection, Selection),
		Selection \== @nil
	    ->  inherit(M, CD, Selection, Obj)
	    ;   send(@display, inform, 'First make a selection')
	    )
	;   send(@display, inform, 'Manual is in read-only mode')
	).

inherit(_, create, Obj, Obj) :- !,
	send(@display, inform, 'Can''t inherit %s from myself', Obj?man_name).
inherit(M, CD, Selection, Obj) :-
	send(@display, confirm,
	     '%s description of %s from %s',
	     when(CD == relate, 'Inherit', 'UnInherit'),
	     Obj?man_name, Selection?man_name),
	send(M, create_relation, CD, Obj, inherit, Selection),
	send(@man_description_cache, clear),
	send(@man_source_cache, clear).


		/********************************
		*            SOURCES		*
		********************************/

request_source(_M, Obj:object) :->
	"Display source of object"::
	(   get(Obj, source, Location)
	->  auto_call(start_emacs),
	    send(@emacs, goto_source_location, Location)
	;   send(@display, inform, 'Can''t find source')
	).


		/********************************
		*          EDIT MODE		*
		********************************/

edit_mode(M, Val) :->
	"Set overall edit_mode"::
	send(M, slot, edit_mode, Val),
	send(M?tools, for_some, message(@arg1?value, edit_mode, Val)).


toggle_edit_mode(M) :->
	"Toggle current setting of edit_mode"::
	(   get(M, edit_mode, @off)
	->  send(M, edit_mode, @on)
	;   send(M, edit_mode, @off)
	),
	get(M, edit_mode, @Val),
	send(M, report, status, 'Edit mode is now %s', Val).

:- pce_end_class.


		/********************************
		*          TOOL FRAMES		*
		********************************/

:- pce_begin_class(man_frame(label), persistent_frame).

variable(manual,	man_manual,	get,
	 "Manual we are related to").
variable(tool_name,	name,		get,
	 "Name of the tool in this frame").


initialise(F, Manual:man_manual, Label:[name]) :->
	"Create from label"::
	send(F, send_super, initialise, Label),
	send(F, slot, manual, Manual),
	send(F, done_message, message(F, quit)).


user_scope(_F, _Scope:chain) :->
	"Generic operation: fail"::
	fail.


tool_focus(_F, _Focus:object*) :->
	"Generic operation: fail"::
	fail.


selected(_F, _Obj:object*) :->
	"Generic operation: fail"::
	fail.


release_selection(_F) :->
	"Generic operation: true"::
	true.


edit_mode(_F, _Val:bool) :->
	"Generic operation: fail"::
	fail.


related(_F, _From:object, _Rel:name, _To:object) :->
	"Generic operation: fail"::
	fail.


unrelated(_F, _From:object, _Rel:name, _To:object) :->
	"Generic operation: fail"::
	fail.


quit(F) :->
	"Destroy a tool"::
	send(F?manual, destroy_tool, F).


		/********************************
		*      GENERIC USER ACTIONS	*
		********************************/

request_selection(F, Obj:any*, Open:[bool]) :->
	send(F?manual, request_selection, F, Obj, Open).

request_tool_focus(F, Obj:object, Force:[bool]) :->
	send(F?manual, request_tool_focus, Obj, Force).

request_source(F, Obj:object) :->
	send(F?manual, request_source, Obj).

request_relate(F, Obj:object) :->
	send(F?manual, request_relate, Obj).

request_unrelate(F, Obj:object) :->
	send(F?manual, request_unrelate, Obj).

request_inherit(F, Obj:object) :->
	send(F?manual, request_inherit, Obj).

request_uninherit(F, Obj:object) :->
	send(F?manual, request_uninherit, Obj).

help(F) :->
	"Give help on a manual tool"::
	get(F, manual, Manual),
	get(F, tool_name, ToolName),
	give_help(Manual, F, ToolName).

:- pce_end_class.

		/********************************
		*              HELP		*
		********************************/

give_help(Manual, Frame, ToolName) :-
	get(Manual, module, tools, @on, Tools),
	(   get(Tools?id_table, find_value, @arg2?tool_name == ToolName, Card)
	->  send(Manual, request_selection, Frame, Card, @on)
	;   get(Manual, edit_mode, @on),
	    get(Manual, selection, ToolCard),
	    ToolCard \== @nil,
	    send(ToolCard, instance_of, man_browser_card),
	    send(@display, confirm, 'Assign %s to browser %s',
		 ToolCard?man_name, ToolName)
	->  send(ToolCard, store, tool_name, ToolName)
	;   send(@display, inform, 'Sorry, Can''t find help card ...')
	).

