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)  1985-2002, 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(drag_and_drop, []).   36:- use_module(library(pce)).   37:- require([ default/3
   38           , ignore/1
   39           ]).   40
   41/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   42Define a gesture that allows to  `drag-and-drop' objects.  The target on
   43which to drop should understand the method  ->drop, which will be called
   44with the dropped graphical  as  an   argument.   If  may  also implement
   45->preview_drop, which will be called to   provide visual feedback of the
   46drop that will take place when the button is released here.
   47- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   48
   49:- pce_begin_class(drag_and_drop_gesture, gesture,
   50                   "Drag and drop command-gesture").
   51
   52variable(target,        visual*,        get,  "Drop target").
   53variable(warp,          bool,           both, "Pointer in center?").
   54variable(offset,        point,          get,  "Offset X-y <->caret pointer").
   55variable(get_source,    function*,      both, "Function to map the source").
   56variable(source,        any,            get,  "Current source").
   57variable(active_cursor, cursor*,        get,  "@nil: activated").
   58variable(select_popup,  popup*,         get,  "Popup for selecting command").
   59
   60class_variable(warp,   bool,        @on,
   61               "Pointer in center?").
   62class_variable(button, button_name, left,
   63               "Button on which gesture operates").
   64class_variable(cursor, [cursor],    cross_reverse,
   65               "Cursor to display.  @default: use graphical").
   66
   67active_distance(_G, D) :-
   68    D > 5.
   69
   70initialise(G, But:button=[button_name],
   71           M:modifier=[modifier], W:warp=[bool],
   72           S:get_source=[function]*) :->
   73    "Create from button, modifiers and warp"::
   74    send_super(G, initialise, But, M),
   75    default(W, class_variable(G, warp), Warp),
   76    default(S, @nil, GS),
   77    send(G, warp, Warp),
   78    send(G, get_source, GS),
   79    send(G, slot, offset, new(point)),
   80    get(G, class_variable_value, cursor, Cursor),
   81    send(G, cursor, Cursor).
   82
   83
   84event(G, Ev:event) :->
   85    "Pass events to <-select_popup"::
   86    (   get(G, select_popup, P),
   87        P \== @nil
   88    ->  send(P, event, Ev)
   89    ;   send_super(G, event, Ev)
   90    ).
   91
   92
   93verify(_G, Ev:event) :->
   94    "Only accept as single-click"::
   95    get(Ev, multiclick, single).
   96
   97
   98initiate(G, Ev:event) :->
   99    "Change the cursor"::
  100    get(Ev, receiver, Gr),
  101    get(Ev, position, Gr, Offset),
  102    send(G?offset, copy, Offset),
  103    send(G, set_source, Ev),
  104    get(G, cursor, Gr, Cursor),
  105    send(G, slot, active_cursor, Cursor).
  106
  107
  108set_source(G, Ev:event) :->
  109    "Find source from event"::
  110    get(Ev, receiver, Gr),
  111    get(G, get_source, Function),
  112    (   Function == @nil
  113    ->  send(G, slot, source, Gr)
  114    ;   get(Function, '_forward', Gr, Source),
  115        send(G, slot, source, Source)
  116    ).
  117
  118
  119cursor(G, Gr:graphical, Cursor:cursor) :<-
  120    "Create cursor from the graphical"::
  121    (   get_super(G, cursor, Cursor),
  122        send(Cursor, instance_of, cursor)
  123    ->  true
  124    ;   get(Gr?area, size, size(W, H)),
  125        (   get(G, warp, @on)
  126        ->  new(HotSpot, point(W/2, H/2)),
  127            send(Gr, pointer, HotSpot),
  128            send(G?offset, copy, HotSpot)
  129        ;   get(G, offset, HotSpot)
  130        ),
  131        new(BM, image(@nil, W, H)),
  132        send(BM, draw_in, Gr, point(0,0)),
  133        send(BM, or, image('cross.bm'), point(HotSpot?x-8, HotSpot?y-8)),
  134        new(Cursor, cursor(@nil, BM, @default, HotSpot))
  135    ).
  136
  137
  138activate(G, Ev:event) :->
  139    "Activate if dragged far enough"::
  140    (   get(G, active_cursor, Cursor),
  141        Cursor \== @nil             % still not activated
  142    ->  (   get(Ev, click_displacement, D),
  143            active_distance(G, D)   % far enough: activate
  144        ->  send(Ev?window, focus_cursor, Cursor),
  145            send(G, slot, active_cursor, @nil)
  146        )
  147    ;   true
  148    ).
  149
  150
  151drag(G, Ev:event) :->
  152    "Find possible ->drop target"::
  153    (   send(G, activate)
  154    ->  get(G, source, Source),
  155        (   get(Ev, inside_sub_window, Frame),
  156            get(Ev, inside_sub_window, Frame, Window),
  157            get(Window, find, Ev,
  158                and(@arg1 \== Source,
  159                    or(and(G?target == @arg1,
  160                           message(G, move_target, Ev)),
  161                       message(G, target, Source, Ev, @arg1))),
  162                _Gr)
  163        ->  true
  164        ;   send(G, target, Source, @nil, @nil)
  165        )
  166    ;   true
  167    ).
  168
  169
  170:- pce_global(@dd_dummy_point, new(point)).
  171
  172move_target(G, Ev:event) :->
  173    "The user is dragging the object over a drop-zone"::
  174    get(G, target, Target),
  175    get(G, source, Source),
  176    (   get(Target, send_method, preview_drop, tuple(_, Method)),
  177        get(Method, argument_type, 1, Type),
  178        get(Type, check, Source, Src),
  179        get(Method, argument_type, 2, PosType),
  180        send(PosType, validate, @dd_dummy_point)
  181    ->  get(Ev, position, Target, Pos),
  182        get(Pos, copy, P2),
  183        send(P2, minus, G?offset),
  184        send(Target, preview_drop, Src, P2)
  185    ;   true
  186    ).
  187
  188
  189target(G, Source:any, Ev:event*, Gr:graphical*) :->
  190    "Make the given object the target"::
  191    (   Gr == @nil
  192    ->  Target = Gr
  193    ;   get(Gr, is_displayed, @on),
  194        container_with_send_method(Gr, drop, Target)
  195    ->  true
  196    ),
  197    ignore((get(G, target, Old),
  198            send(Old, has_send_method, preview_drop),
  199            send(Old, preview_drop, @nil))),
  200    (   get(Target, send_method, preview_drop, tuple(_, Method)),
  201        get(Method, argument_type, 1, Type),
  202        get(Type, check, Source, Src)
  203    ->  (   get(Method, argument_type, 2, PosType),
  204            send(PosType, validate, @dd_dummy_point)
  205        ->  get(Ev, position, Target, Pos),
  206            get(Pos, copy, P2),
  207            send(P2, minus, G?offset),
  208            send(Target, preview_drop, Src, P2)
  209        ;   send(Target, preview_drop, Src)
  210        )
  211    ;   true
  212    ),
  213    send(G, slot, target, Target).
  214
  215container_with_send_method(Obj, Method, Obj) :-
  216    send(Obj, has_send_method, Method).
  217container_with_send_method(Obj, Method, Container) :-
  218    get(Obj, contained_in, C0),
  219    container_with_send_method(C0, Method, Container).
  220
  221
  222terminate(G, Ev:event) :->
  223    "->drop to <-target"::
  224    (   get(G, active_cursor, Cursor),
  225        Cursor \== @nil
  226    ->  send(G, slot, active_cursor, @nil),
  227        send(G, cancel)
  228    ;   get(G, slot, target, Target),
  229        send(Ev?window, focus_cursor, @nil),
  230%       send(G, cursor, @default),
  231        get(G, source, Source),
  232        (   Target == @nil
  233        ->  true
  234        ;   send(G, target, Source, @nil, @nil),
  235            get(Target, send_method, drop, tuple(_, Method)),
  236            get(Method, argument_type, 1, T1),
  237            get(T1, check, Source, Src),
  238            get(Target, display, Display),
  239            (   get(Method, argument_type, 2, Type),
  240                send(Type, validate, @dd_dummy_point)
  241            ->  get(Ev, position, Target, Pos),
  242                get(Pos, copy, P2),
  243                send(P2, minus, G?offset),
  244                send(Display, busy_cursor),
  245                forward(G, Target, Src, P2),
  246                send(Display, busy_cursor, @nil)
  247            ;   send(Display, busy_cursor, @default),
  248                forward(G, Target, Src),
  249                send(Display, busy_cursor, @nil)
  250            )
  251        ),
  252        send(G, slot, source, @nil)
  253    ).

 forward(+G, +Target, +Src, +Pos)

  257forward(G, Target, Src, Pos) :-
  258    (   catch(send(message(@arg1, drop, @arg2, @arg3),
  259                   forward_receiver, G, Target, Src, Pos), E, true)
  260    ->  (   nonvar(E)
  261        ->  print_message(error, E)
  262        ;   true
  263        )
  264    ;   true
  265    ).
  266
  267forward(G, Target, Src) :-
  268    (   catch(send(message(@arg1, drop, @arg2),
  269                   forward_receiver, G, Target, Src), E, true)
  270    ->  (   nonvar(E)
  271        ->  print_message(error, E)
  272        ;   true
  273        )
  274    ;   true
  275    ).
  276
  277
  278:- pce_group(command).
  279
  280
  281%       <-select_command: Commands:chain --> Cmd:name
  282%
  283%       This method is to support menu selection of a command often
  284%       associated with right-dragging instead of left-dragging. It
  285%       is called from the ->drop at the receiving graphical:
  286%
  287%%              drop(Me, Obj:any) :->
  288%                       (   send(@event, is_a, ms_right_up)
  289%                       ->  get(@receiver, select_command,
  290%%                              chain(move, copy), Command),
  291%                           <move or copy Obj>
  292%                       ;   <Perform default action>
  293%                       ).
  294
  295select_command(G, Commands:chain, Cmd:name) :<-
  296    "Select a command (normally right-button drag)"::
  297    send(@display, busy_cursor, @nil),
  298    new(P, popup(command)),
  299    send(P, members, Commands),
  300    send_list(P, append,
  301              [ gap,
  302                cancel
  303              ]),
  304    get(@event, receiver, Gr),
  305    get(@event, position, Gr, Pos),
  306    send(P, open, Gr, Pos),
  307    send(G, slot, select_popup, P),
  308%   get(P, window, Window),
  309%   send(Window, grab_pointer, @on),
  310    repeat,
  311        send(@display, dispatch),
  312        get(P, displayed, @off),
  313        !,
  314%       send(Window, grab_pointer, @off),
  315    (   get(P, selected_item, SI),
  316        SI \== @nil
  317    ->  get(SI, value, Cmd)
  318    ;   Cmd = @nil
  319    ),
  320    send(G, slot, select_popup, @nil),
  321    Cmd \== @nil,
  322    Cmd \== cancel.
  323
  324:- pce_end_class