1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
   2
   3    Author:        Jan Wielemaker and Anjo Anjewierden
   4    E-mail:        wielemak@science.uva.nl
   5    WWW:           http://www.swi-prolog.org/packages/xpce/
   6    Copyright (c)  2006-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_arm, []).
  36:- use_module(pce).
  37:- use_module(pce_template).
  38:- use_module(library(debug)).
  39
  40/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  41Library  pce_arm.pl  provides  a  mechanism    for  feedback  on  active
  42graphicals while to mouse is moving  over   them.  It guaranteed that at
  43most one graphical is `armed' at any time.
  44
  45Graphical objects that wishes to play a role in this must
  46
  47        * Ensure to ->event activates @arm_recogniser
  48        * define the method ->arm: Bool, where @on is send to arm
  49          the object and @off to unarm it.  Objects that accepted
  50          @on are guaranteed to receive ->arm: @off.
  51
  52The currently armed object can be requested using
  53
  54        ?- get(@display, armed, Graphical).
  55
  56The arm library was initially developed for  Triple20. It has been moved
  57to  the  XPCE  core  library  in   version    5.6.9   for   use  in  the
  58cross-referencing GUI (See pce_xref.pl).
  59- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  60
  61:- pce_begin_class(arm, template,
  62                   "(Un)arm objects in a window").
  63
  64:- pce_group(event).
  65
  66define_event(Name, Parent) :-
  67    (   get(@event_tree, node, Name, Node)
  68    ->  (   get(Node?parent, value, Parent)
  69        ->  true
  70        ;   print_message(error, format('Redefined event ~w', [Name]))
  71        )
  72    ;   new(_, event_node(Name, Parent))
  73    ).
  74
  75:- pce_global(@arm_recogniser,
  76              new(handler(arm,
  77                          message(@event?display, try_arm,
  78                                  @event?receiver)))).
  79:- initialization
  80   define_event(arm, user).
  81
  82event(W, Ev:event) :->
  83    (   send(Ev, is_a, loc_move),
  84        get(W, arm, _Target)
  85    ->  true
  86    ;   send(Ev, is_a, area_exit)
  87    ->  send(@display, arm_object, @nil)
  88    ;   true
  89    ),
  90    send_super(W, event, Ev).
  91
  92:- pce_group(arm).
  93
  94arm(W, For:[name|code], Target:graphical) :<-
  95    (   get(@event, position, W, point(X, Y)),
  96        get(W, slot, scroll_offset, point(OX, OY)),
  97        AX is X + OX, AY is Y+OY,
  98        new(Ev, event(arm, W, AX, AY)),
  99        (   For == @default
 100        ->  true
 101        ;   send(Ev, attribute, arm_for, For)
 102        ),
 103        debug(arm, 'Posting arm to ~p at ~d,~d', [W, AX, AY]),
 104        send(Ev, post, W)
 105    ->  get(@display, hypered, arm, Target)
 106    ;   send(@display, arm_object, @nil),
 107        fail
 108    ).
 109
 110:- pce_end_class(arm).
 111
 112
 113:- pce_extend_class(display).
 114
 115try_arm(W, Gr:graphical) :->
 116    (   get(@event, attribute, arm_for, For)
 117    ->  (   atom(For)
 118        ->  send(Gr, has_send_method, For)
 119        ;   send(For, forward_receiver, Gr)
 120        )
 121    ;   true
 122    ),
 123    send(W, arm_object, Gr).
 124
 125arm_object(W, Gr:graphical*) :->
 126    (   get(W, hypered, arm, Old)
 127    ->  (   Old == Gr
 128        ->  true                    % no change
 129        ;   send(W, delete_hypers, arm),
 130            send(Old, arm, @off),
 131            (   Gr \== @nil
 132            ->  send(Gr, arm, @on),
 133                new(_, hyper(W, Gr, arm, arm_window))
 134            ;   true
 135            )
 136        )
 137    ;   (   Gr \== @nil
 138        ->  send(Gr, arm, @on),
 139            new(_, hyper(W, Gr, arm, arm_window))
 140        ;   true
 141        )
 142    ).
 143
 144armed(W, Gr:graphical) :<-
 145    "Find currently armed graphical"::
 146    get(W, hypered, arm, Gr).
 147
 148:- pce_end_class(display).