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).