1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        jan@swi.psy.uva.nl
    5    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    6    Copyright (c)  1997-2011, University of Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(pce_help_messages, []).   36:- use_module(library(pce)).   37
   38:- pce_global(@help_message_window, new(help_message_window)).
   39
   40:- pce_begin_class(help_message_window, dialog,
   41                   "Window to display <-help_message").
   42
   43class_variable(background, colour,
   44               when(@pce?window_system == windows,
   45                    win_infobk,
   46                    burlywood1),
   47               "Ballon background").
   48class_variable(foreground, colour,
   49               when(@pce?window_system == windows,
   50                    win_infotext,
   51                    black)).
   52
   53variable(handler,       handler,        get, "Handler for intercept").
   54variable(message,       string*,        get, "Currently displayed message").
   55
   56initialise(W) :->
   57    send(W, slot, handler,
   58         handler(mouse, message(W, try_hide, @event))),
   59    send_super(W, initialise),
   60    get(W, frame, Frame),
   61    send(Frame, kind, popup),
   62    send(Frame, sensitive, @off),
   63    send(Frame, border, 0),
   64    send(Frame?tile, border, 0),
   65    send(W, gap, size(5, 2)),
   66    (   get(@pce, window_system, windows) % Hack
   67    ->  send(W, pen, 1)
   68    ;   send(W, pen, 0)
   69    ),
   70    send(W, append, new(L, label(feedback, '', normal))),
   71    send(L, length, 0),
   72    send(Frame, create).
   73
   74owner(W, Owner:[any]*) :->
   75    "Maintain hyperlink to the owner"::
   76    (   Owner == @nil
   77    ->  send(W, delete_hypers, owner)
   78    ;   Owner == @default
   79    ->  true                        % no change
   80    ;   new(_, help_hyper(Owner, W, help_baloon, owner))
   81    ).
   82owner(W, Owner:any) :<-
   83    get(W, hypered, owner, Owner).
   84
   85
   86try_hide(W, Ev:event) :->
   87    get(W, owner, Owner),
   88    (   send(Ev, inside, Owner),
   89        (   send(Ev, is_a, loc_move)
   90        ;   send(Ev, is_a, loc_still)
   91        )
   92    ->  %send(@pce, format, '%O: Move/still event\n', Owner),
   93        get(W, message, OldMsg),
   94        (   get(Owner, help_message, tag, Ev, Msg)
   95        ->  %send(@pce, format, '%O: yielding %s\n', Owner, Msg),
   96            (   OldMsg \== @nil,
   97                send(Msg, equal, OldMsg)
   98            ->  (   send(Ev, is_a, loc_still)
   99                ->  send(W, adjust_position, Ev)
  100                ;   true
  101                )
  102            ;   send(W, feedback, Msg, Ev)
  103            )
  104        ;   (   get(W, message, @nil)
  105            ->  true
  106            ;   send(W, feedback, @nil, Ev)
  107            )
  108        )
  109    ;   send(W, owner, @nil),
  110        send(W, hide),
  111        fail                        % normal event-processing
  112    ).
  113
  114
  115hide(W) :->
  116    "Remove from the display"::
  117    send(W, show, @off),
  118    get(W, handler, H),
  119    send(W?display?inspect_handlers, delete, H).
  120
  121
  122feedback(W, S:string*, Ev:event, For:[any]*) :->
  123    "Display window holding string and grab pointer"::
  124    send(W, owner, For),
  125    send(W, slot, message, S),
  126    (   S == @nil
  127    ->  send(W, show, @off)
  128    ;   get(W, member, feedback, L),
  129        send(L, selection, S),
  130        send(W, layout),
  131        send(W?frame, fit),
  132        send(W, adjust_position, Ev),
  133        send(W?display, inspect_handler, W?handler)
  134    ).
  135
  136
  137adjust_position(W, Ev:event) :->
  138    "Fix the position of the feedback window"::
  139    get(Ev, position, W?display, P),
  140    get(P, plus, point(5,5), point(FX, FY)),
  141    send(W?frame, set, FX, FY),
  142    send(W?frame, expose).
  143
  144:- pce_end_class.
  145
  146
  147attribute_name(tag,     help_tag).
  148attribute_name(summary, help_summary).
  149
  150:- pce_extend_class(visual).
  151
  152help_message(Gr, What:{tag,summary}, Msg:string*) :->
  153    "Associate a help message"::
  154    attribute_name(What, AttName),
  155    (   Msg == @nil
  156    ->  send(Gr, delete_attribute, AttName)
  157    ;   send(Gr, attribute, AttName, Msg)
  158    ).
  159help_message(V, What:{tag,summary}, _Ev:[event], Msg:string) :<-
  160    attribute_name(What, AttName),
  161    get(V, attribute, AttName, Msg).
  162
  163:- pce_end_class.
  164
  165
  166:- pce_extend_class(graphical).
  167
  168show_help_message(Gr, What:name, Ev:event) :->
  169    find_help_message(Gr, What, Ev, Owner, Msg),
  170    send(@help_message_window, feedback, Msg, Ev, Owner).
  171
  172
  173find_help_message(Gr, What, Ev, Gr, Msg) :-
  174    get(Gr, help_message, What, Ev, Msg),
  175    !.
  176find_help_message(Gr, What, Ev, Owner, Msg) :-
  177    get(Gr, contained_in, Container),
  178    find_help_message(Container, What, Ev, Owner, Msg).
  179
  180:- pce_end_class.
  181
  182
  183:- pce_extend_class(menu).
  184
  185help_message(Gr, What:{tag,summary}, Ev:[event], Msg:string) :<-
  186    "Fetch associated help message"::
  187    (   get(Gr, item_from_event, Ev, Item),
  188        get(Item, help_message, What, Msg)
  189    ->  true
  190    ;   get(Gr, get_super, help_message, What, Ev, Msg)
  191    ).
  192
  193:- pce_end_class.
  194
  195
  196:- pce_begin_class(help_hyper, hyper,
  197                   "Hyper between help-balloon and owner").
  198
  199unlink_from(H) :->
  200    "->hide the <-to part"::
  201    get(H, to, Part),
  202    (   object(Part)
  203    ->  send(Part, hide)
  204    ;   free(Part)
  205    ),
  206    free(H).
  207
  208:- pce_end_class.
  209
  210                 /*******************************
  211                 *           REGISTER           *
  212                 *******************************/
  213
  214register_help_message_window :-
  215    send(@display, inspect_handler,
  216         handler(loc_still,
  217                 message(@receiver, show_help_message, tag, @event))),
  218    send(@display, inspect_handler,
  219         handler(help,
  220                 message(@receiver, show_help_message, summary, @event))).
  221
  222:- initialization
  223   register_help_message_window.