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)  1999-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_tool_button, []).   36:- use_module(library(pce)).   37:- use_module(library(help_message)).   38:- use_module(library(imageops)).   39:- require([ default/3
   40           ]).   41
   42/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   43This library module defines  three   classes:  tool_bar, tool_button and
   44tool_status_button. It is intended for defining   rows  of buttons, also
   45called tool-bars. Each button represents an   action  on the `client' of
   46the tool_bar.
   47
   48Below is a typical example:
   49
   50resource(printer,       image,  image('16x16/print.xpm')).
   51resource(floppy,        image,  image('16x16/save.xpm')).
   52
   53:- pce_begin_class(myapp, frame).
   54
   55initialise(MyApp) :->
   56        send_super(MyApp, initialise, 'My application'),
   57        send(F, append, new(D, tool_dialog(MyApp))),
   58        send_list(TB, append,
   59                  [ tool_button(load,
   60                                resource(floppy),
   61                                load),
   62                    gap,                % skip a little
   63                    tool_button(print,
   64                                resource(printer),
   65                                print)
   66                  ]),
   67        ...
   68
   69print(MyApp) :->
   70        <Print the current document>
   71
   72- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   73
   74:- pce_begin_class(tool_bar, dialog_group,
   75                   "Row of buttons").
   76
   77variable(orientation,   {horizontal,vertical},  get,  "Stacking direction").
   78variable(client,        object*,                both, "Receiving object").
   79
   80initialise(BG, Client:[object]*, Orientation:[{horizontal,vertical}]) :->
   81    default(Client, @nil, C),
   82    default(Orientation, horizontal, O),
   83    send(BG, send_super, initialise, @default, group),
   84    send(BG, slot, client, C),
   85    send(BG, slot, orientation, O),
   86    send(BG, gap, size(0,0)).
   87
   88append(BG, B:'tool_button|{gap}') :->
   89    "Append button or gap"::
   90    (   get(BG, orientation, horizontal)
   91    ->  Where = right
   92    ;   Where = next_row
   93    ),
   94    (   B == gap
   95    ->  What = graphical(0, 0, 5, 5)
   96    ;   What = B
   97    ),
   98    send(BG, send_super, append, What, Where).
   99
  100activate(BG) :->
  101    "Update activation of member buttons"::
  102    send(BG?graphicals, for_some,
  103         if(message(@arg1, has_send_method, activate),
  104            message(@arg1, activate))).
  105
  106reference(BG, Ref:point) :<-
  107    "Reference is at the baseline"::
  108    get(BG, height, H),
  109    new(Ref, point(0, H)).
  110
  111compute(BG) :->
  112    "Make all buttons the same size"::
  113    (   get(BG, request_compute, @nil)
  114    ->  true
  115    ;   new(S, size(0,0)),
  116        send(BG?graphicals, for_all,
  117             if(message(@arg1, instance_of, button),
  118                message(S, union, @arg1?size))),
  119        send(BG?graphicals, for_all,
  120             if(message(@arg1, instance_of, button),
  121                message(@arg1, size, S))),
  122        send_super(BG, compute)
  123    ).
  124
  125:- pce_end_class.
  126
  127:- pce_begin_class(tool_button(client, name), button,
  128                   "Button for a tool_bar").
  129
  130variable(condition,     code*,       get, "Condition for activation").
  131
  132initialise(TB,
  133           Action:action='name|code',
  134           Label:label='name|image',
  135           Balloon:balloon=[name|string],
  136           Condition:condition=[code]*,
  137           Name:name=[name]) :->
  138    default(Condition, @nil, Cond),
  139    make_label(Label, Lbl),
  140    make_name(Action, Name, ButtonName),
  141    make_message(Action, Msg),
  142    send(TB, send_super, initialise, ButtonName, Msg),
  143    send(TB, label, Lbl),
  144    send(TB, slot, condition, Cond),
  145    (   Balloon == @default
  146    ->  true
  147    ;   atom(Balloon)
  148    ->  get(Balloon, label_name, Text),
  149        send(TB, help_message, tag, Text)
  150    ;   send(TB, help_message, tag, Balloon)
  151    ).
  152
  153client(TB, Client:object) :<-
  154    get(TB, device, Dev),
  155    get(Dev, client, Client).
  156
  157make_message(Name, @default) :-
  158    atomic(Name),
  159    !.
  160make_message(Code, Code).
  161
  162
  163make_name(Action, @default, Name) :-
  164    !,
  165    make_name(Action, Name).
  166make_name(_, Name, Name).
  167
  168make_name(Name, Name) :-
  169    atomic(Name),
  170    !.
  171make_name(Code, Name) :-
  172    send(Code, instance_of, message),
  173    get(Code, selector, Name),
  174    atom(Name),
  175    !.
  176make_name(_, 'tool_button').
  177
  178
  179make_label(Image, Image) :-
  180    send(Image, instance_of, image),
  181    !.
  182make_label(Name, Image) :-
  183    pce_catch_error(cannot_find_file, new(Image, image(Name))),
  184    !.
  185make_label(Name, Image) :-
  186    new(T, text(Name, left, small)),
  187    get(T, size, size(W, H)),
  188    new(I0, image(@nil, W, H)),
  189    send(I0, draw_in, T),
  190    get(I0, scale, size(16,16), Image),
  191    free(T),
  192    free(I0).
  193
  194
  195forward(TB) :->
  196    "Send action to <-client"::
  197    get(TB, message, Msg),
  198    (   Msg == @default
  199    ->  get(TB, name, Selector),
  200        get(TB, client, Client),
  201        send(Client, Selector)
  202    ;   send(Msg, execute)
  203    ).
  204
  205
  206activate(TB) :->
  207    "Update the activation using <-condition"::
  208    (   get(TB, condition, Cond),
  209        Cond \== @nil
  210    ->  (   get(TB, client, Client),
  211            send(Cond, forward, Client)
  212        ->  send(TB, active, @on)
  213        ;   send(TB, active, @off)
  214        )
  215    ).
  216
  217active(TB, Val:bool) :->
  218    "(de)activate the menu-item"::
  219    send(TB, send_super, active, Val),
  220    (   get(TB, label, Image),
  221        send(Image, instance_of, image)
  222    ->  get(Image, active, Val, Activated),
  223        send(TB, label, Activated)
  224    ;   true
  225    ).
  226
  227:- pce_end_class.
  228
  229:- pce_begin_class(tool_status_button, tool_button,
  230                   "A tool button representing two states").
  231
  232variable(value,         bool := @off,   get, "Current value").
  233
  234execute(TB) :->
  235    "Switch status and send message"::
  236    get(TB, value, Value),
  237    get(Value, negate, NewValue),
  238    send(TB, value, NewValue),
  239    send(TB, flush),
  240    get(TB, message, Message),
  241    (   Message == @default
  242    ->  get(TB, client, Client),
  243        get(TB, name, Selector),
  244        send(Client, Selector, NewValue)
  245    ;   Message == @nil
  246    ->  true
  247    ;   send(Message, forward, NewValue)
  248    ).
  249
  250
  251value(TB, Value:bool) :->
  252    (   get(TB, value, Value)
  253    ->  true
  254    ;   send(TB, slot, value, Value),
  255        (   Value == @on
  256        ->  send(TB, status, execute)
  257        ;   send(TB, status, inactive)
  258        )
  259    ).
  260
  261
  262reset(TB) :->
  263    "Smooth handling of abort"::
  264    (   get(TB, value, @off)
  265    ->  send(TB, status, inactive)
  266    ;   send(TB, status, execute)
  267    ).
  268
  269:- pce_end_class(tool_status_button).
  270
  271
  272                 /*******************************
  273                 *            DIALOG            *
  274                 *******************************/
  275
  276:- pce_begin_class(tool_dialog, dialog,
  277                   "Dialog for menu-bar and toolbar").
  278
  279variable(client,        [object],       get, "The client").
  280
  281initialise(TD, Client:[object]) :->
  282    "Refine layout"::
  283    send_super(TD, initialise),
  284    send(TD, slot, client, Client),
  285    send(TD, pen, 0),
  286    send(TD, border, size(0, 2)).
  287
  288
  289menu_bar(TD, Create:[bool], MB:menu_bar) :<-
  290    "Get (or create) the menu_bar"::
  291    (   get(TD, member, menu_bar, MB)
  292    ->  true
  293    ;   Create == @on
  294    ->  (   get(TD, tool_bar, TB)
  295        ->  send(new(MB, menu_bar), above, TB)
  296        ;   send(TD, append, new(MB, menu_bar))
  297        )
  298    ).
  299
  300tool_bar(TD, Create:[bool], TB:tool_bar) :<-
  301    "Get (or create) the tool_bar"::
  302    (   get(TD, member, tool_bar, TB)
  303    ->  true
  304    ;   Create == @on
  305    ->  (   get(TD, client, Client),
  306            Client \== @default
  307        ->  true
  308        ;   get(TD, frame, Client)
  309        ),
  310        (   get(TD, menu_bar, MB)
  311        ->  send(new(TB, tool_bar(Client)), below, MB)
  312        ;   send(TD, append, new(TB, tool_bar(Client)))
  313        )
  314    ).
  315
  316
  317popup(TD, Name:name, Create:[bool], Popup:popup) :<-
  318    "Find named popup or create it"::
  319    get(TD, menu_bar, Create, MB),
  320    (   get(MB, member, Name, Popup)
  321    ->  true
  322    ;   Create == @on
  323    ->  send(MB, append, new(Popup, popup(Name))),
  324        send(Popup, message, message(TD, action, @arg1))
  325    ).
  326
  327
  328append(TD,
  329       B:'popup|menu_item|tool_button|graphical|{gap}',
  330       Where:where=[name], Before:before=[any]) :->
  331    "Append buttons or popup for manu-bar"::
  332    (   send(B, instance_of, popup)
  333    ->  get(TD, menu_bar, @on, MB),
  334        send(MB, append, B),
  335        (   get(B, message, @default)
  336        ->  send(B, message, message(TD, action, @arg1))
  337        ;   true
  338        )
  339    ;   send(B, instance_of, menu_item)
  340    ->  get(TD, popup, Where, @on, Popup),
  341        send(Popup, insert_before, B, Before)
  342    ;   (   send(B, instance_of, tool_button)
  343        ;   B == gap
  344        )
  345    ->  get(TD, tool_bar, @on, TB),
  346        send(TB, append, B)
  347    ;   send_super(TD, append, B, Where)
  348    ).
  349
  350action(TD, Action:name) :->
  351    "Forward popup-action to <-client"::
  352    (   get(TD, client, Client),
  353        Client \== @default
  354    ->  send(Client, Action)
  355    ;   send(TD, report, error, 'No client for posting action')
  356    ).
  357
  358:- pce_end_class(tool_dialog)