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)  1996-2013, 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_toc, []).   36:- use_module(library(pce)).   37:- use_module(library(pce_unclip)).   38:- require([ send_list/2,
   39	     default/3
   40	   ]).   41
   42:- pce_autoload(drag_and_drop_gesture, library(dragdrop)).   43
   44resource(file,          image, image('16x16/doc.xpm')).
   45resource(opendir,       image, image('opendir.xpm')).
   46resource(closedir,      image, image('closedir.xpm')).
   47
   48/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   49Status and aim
   50==============
   51
   52This is the  first  version  of   an  XPCE/Prolog  library  for managing
   53hierarchies in a similar fashion as many Windows(tm) tools.
   54
   55The current version is not well   prepared for modifyable structures. It
   56is designed for the contents browser of  the SWI-Prolog manual, but with
   57the intention to grow into a more widely usable library.
   58
   59The objective is that the   application programmer subclasses toc_window
   60and (re)defines the virtual methods  there   to  tailor  this package to
   61his/her application. The other classes in   this package should normally
   62not be affected.
   63
   64Typical usage
   65=============
   66
   67        :- pce_autoload(toc_window, library(pce_toc)).
   68
   69        :- pce_begin_class(directory_hierarchy, toc_window,
   70                           "Browser for a directory-hierarchy").
   71
   72        initialise(FB, Root:directory) :->
   73                send_super(FB, initialise),
   74                get(Root, name, Name),
   75                send(FB, root, toc_folder(Name, Root)).
   76
   77        expand_node(FB, D:directory) :->
   78                get(D, directories, SubDirsNames),
   79                get(SubDirsNames, map, ?(D, directory, @arg1), SubDirs),
   80                send(SubDirs, for_all,
   81                     message(FB, son, D,
   82                             create(toc_folder, @arg1?name, @arg1))).
   83
   84        :- pce_end_class.
   85
   86
   87        ?- send(directory_hierarchy(~), open).
   88
   89- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   90
   91                 /*******************************
   92                 *          TOC-WINDOW          *
   93                 *******************************/
   94
   95:- pce_begin_class(toc_window(name), window,
   96                   "Window for table-of-contents").
   97
   98variable(drag_and_drop, bool := @off, get, "Allow drag-and-drop").
   99
  100initialise(TW) :->
  101    "Create window and display empty toc_tree"::
  102    send_super(TW, initialise),
  103    send(TW, scrollbars, both),
  104    send(TW, hor_shrink, 0),
  105    send(TW, hor_stretch, 1),
  106    send(TW, display, new(toc_tree), point(10, 5)).
  107
  108:- pce_group(parts).
  109
  110tree(TW, Tree:toc_tree) :<-
  111    "Get the toc_tree"::
  112    get(TW, member, toc_tree, Tree).
  113
  114
  115root(TW, Root:node) :<-
  116    "Get the root-node of the tree"::
  117    get(TW, member, toc_tree, Tree),
  118    get(Tree, root, Root).
  119
  120
  121selection(TW, Nodes:chain) :<-
  122    "Return new chain holding selected nodes"::
  123    get(TW, member, toc_tree, Tree),
  124    get(Tree, selection, Nodes).
  125
  126selection(TW, Nodes:'any|chain*') :->
  127    "Set selected nodes"::
  128    get(TW, member, toc_tree, Tree),
  129    send(Tree, selection, Nodes).
  130
  131node(TW, Id:any, Node:toc_node) :<-
  132    "Find node from identifier"::
  133    get(TW, member, toc_tree, Tree),
  134    get(Tree, nodes, Table),
  135    (   get(Table, member, Id, Node)
  136    ->  true
  137    ;   send(Id, instance_of, toc_node),
  138        Node = Id
  139    ).
  140
  141:- pce_group(virtual).
  142
  143open_node(_TW, _Id:any) :->
  144    "Called on double-click"::
  145    true.
  146
  147select_node(_TW, _Id:any) :->
  148    "Called on single-click"::
  149    true.
  150
  151expand_node(TW, Id:any) :->
  152    "Define expansion of node 'id'"::
  153    get(TW, node, Id, Node),
  154    send(Node, slot, collapsed, @off).
  155
  156collapse_node(TW, Id:any) :->
  157    "Define collapsing of node 'id'"::
  158    get(TW, node, Id, Node),
  159    send(Node, hide_sons).
  160
  161popup(_TW, _Id:any, _Popup:popup) :<-
  162    "Return a menu for this node"::
  163    fail.
  164
  165:- pce_group(build).
  166
  167root(TW, Root:toc_folder, Relink:[bool]) :->
  168    "Assign the table a root"::
  169    get(TW, tree, Tree),
  170    send(Tree, root, Root, Relink).
  171
  172son(TW, Parent:any, Son:toc_node) :->
  173    "Add a son to a node"::
  174    get(TW, node, Parent, Node),
  175    send(Node, son, Son).
  176
  177delete(TW, Id:any) :->
  178    "Delete node (and subnodes)"::
  179    get(TW, node, Id, Node),
  180    send(Node?node, delete_tree).
  181
  182expand_root(T) :->
  183    "Expand the root-node"::
  184    get(T?tree, root, Node),
  185    ignore(send(Node, collapsed, @off)).
  186
  187clear(T) :->
  188    "Remove the nodes, not the tree"::
  189    get(T, tree, Tree),
  190    send(Tree, clear, destroy).
  191
  192:- pce_group(state).
  193
  194
  195expanded_ids(T, Ids:chain) :<-
  196    "Chain holding the ids of all expanded nodes"::
  197    new(Ids, chain),
  198    (   get(T?tree, root, Root),
  199        Root \== @nil
  200    ->  send(Root, for_all,
  201             if(@arg1?collapsed == @off,
  202                message(Ids, append, @arg1?identifier)))
  203    ;   true
  204    ).
  205
  206expand_ids(T, Ids:chain) :->
  207    "Expand the given ids"::
  208    send(Ids, for_all, message(T, expand_id, @arg1)).
  209
  210expand_id(T, Id:any) :->
  211    "Expand node with given ID"::
  212    get(T, node, Id, Node),
  213    send(Node, collapsed, @off).
  214
  215:- pce_group(scroll).
  216
  217scroll_vertical(TW,
  218                Direction:{forwards,backwards,goto},
  219                Unit:{page,file,line},
  220                Amount:int) :->
  221    "Prevent scrolling too far"::
  222    get(TW, visible, VA),
  223    get(TW, bounding_box, BB),
  224    (   send(VA, inside, BB)
  225    ->  true
  226    ;   Direction == backwards,
  227        get(VA, y, Y),
  228        Y < 1
  229    ->  true
  230    ;   Direction == forwards,
  231        get(BB, bottom_side, BBBottom),
  232        get(VA, bottom_side, VABottom),
  233        VABottom > BBBottom
  234    ->  true
  235    ;   send_super(TW, scroll_vertical, Direction, Unit, Amount),
  236        get(TW, visible, area(_, AY, _, _)),
  237        (   AY < 0
  238        ->  send(TW, scroll_to, point(0,0))
  239        ;   true
  240        )
  241    ).
  242
  243normalise_tree(TW, Id:any) :->
  244    "Make as much as possible of the subtree visible"::
  245    get(TW, node, Id, Node),
  246    (   get(Node, sons, Sons),
  247        Sons \== @nil
  248    ->  send(TW, compute),          % ensure proper layout
  249        get(Sons, map, @arg1?image, Grs),
  250        send(Grs, append, Node?image),
  251        send(TW, normalise, Grs, y) % class-variable?
  252    ;   true
  253    ).
  254
  255:- pce_group(event).
  256
  257:- pce_global(@toc_window_recogniser,
  258              make_toc_window_recogniser).  259
  260make_toc_window_recogniser(G) :-
  261    new(C, click_gesture(left, '', single,
  262                         message(@receiver, selection, @nil))),
  263    new(KB, key_binding(toc_window)),
  264    send_list(KB,
  265              [ function(page_up,
  266                         message(@receiver, scroll_vertical, backwards,
  267                                 page, 900)),
  268                function(page_down,
  269                         message(@receiver, scroll_vertical, forwards,
  270                                 page, 900)),
  271                function(cursor_home,
  272                         message(@receiver, scroll_vertical, goto,
  273                                 file, 0)),
  274                function(end,
  275                         message(@receiver, scroll_vertical, goto,
  276                                 file, 1000))
  277              ]),
  278    new(G, handler_group(C, KB)).
  279
  280event(TW, Ev:event) :->
  281    "Handle key-bindings"::
  282    (   send_super(TW, event, Ev)
  283    ;   send(@toc_window_recogniser, event, Ev)
  284    ).
  285
  286
  287drag_and_drop(TW, Val:bool) :->
  288    "(dis)allow drag-and-drop"::
  289    send(TW, slot, drag_and_drop, Val),
  290    (   Val == @on
  291    ->  (   send(@toc_node_recogniser?members, member,
  292                 @toc_drag_and_drop_recogniser)
  293        ->  true
  294        ;   send(@toc_node_recogniser?members, append,
  295                 @toc_drag_and_drop_recogniser)
  296        )
  297    ).
  298
  299:- pce_end_class(toc_window).
  300
  301
  302                 /*******************************
  303                 *            TOC-TREE          *
  304                 *******************************/
  305
  306:- pce_begin_class(toc_tree, tree,
  307                   "Tree to display table-of-contents").
  308
  309variable(nodes, hash_table, get, "Id --> node mapping").
  310
  311initialise(TC) :->
  312    "Create the tree, setting style and geometry"::
  313    send(TC, slot, nodes, new(hash_table)),
  314    send_super(TC, initialise),
  315    send(TC, direction, list),
  316    new(FImg, image(resource(file))),
  317    get(FImg, size, size(W,_)),
  318    LevelGap is W+1,
  319    send(TC, level_gap, LevelGap).
  320
  321root(TC, Root:toc_node, Relink:[bool]) :->
  322    "Assign the root"::
  323    send_super(TC, root, Root, Relink),
  324    send(TC?nodes, append, Root?identifier, Root).
  325
  326selection(TC, SelectedNodes:chain) :<-
  327    "Find all toc_nodes that are selected"::
  328    get(TC?contains, find_all, @arg1?selected == @on, SelectedNodes).
  329
  330selection(TC, Selection:'any|graphical|chain*') :->
  331    "Select the given nodes"::
  332    send(TC, compute),
  333    (   send(Selection, instance_of, chain)
  334    ->  get(Selection, map, ?(TC, node_image, @arg1), Graphicals),
  335        send_super(TC, selection, Graphicals)
  336    ;   Selection == @nil
  337    ->  send_super(TC, selection, Selection)
  338    ;   get(TC, node_image, Selection, Gr)
  339    ->  send_super(TC, selection, Gr)
  340    ).
  341
  342node(TC, From:any, Node:toc_node) :<-
  343    "Get node from node or ID"::
  344    (   send(From, instance_of, toc_node)
  345    ->  Node = From
  346    ;   get(TC?nodes, member, From, Node)
  347    ).
  348
  349node_image(TC, From:any, Gr:graphical) :<-
  350    "Get node image from graphical, node or ID"::
  351    (   send(From, instance_of, graphical)
  352    ->  Gr = From
  353    ;   send(From, instance_of, toc_node)
  354    ->  get(From, image, Gr)
  355    ;   get(TC?nodes, member, From, Node),
  356        get(Node, image, Gr)
  357    ).
  358
  359:- pce_end_class(toc_tree).
  360
  361
  362:- pce_begin_class(toc_node, node,
  363                   "Node for the table-of-contents package").
  364
  365variable(identifier, [any],             none, "Identification handle").
  366
  367initialise(TN, Id:any, Image:toc_image) :->
  368    send(TN, slot, identifier, Id),
  369    send_super(TN, initialise, Image).
  370
  371
  372identifier(TN, Id:any) :<-
  373    "Get given identifier or <-self"::
  374    get(TN, slot, identifier, Id0),
  375    (   Id0 == @default
  376    ->  Id = TN
  377    ;   Id = Id0
  378    ).
  379
  380
  381son(TN, Son:toc_node) :->
  382    "Add a son below this node"::
  383    send_super(TN, son, Son),
  384    get(Son, identifier, Id),
  385    get(TN?tree, nodes, Nodes),
  386    send(Nodes, append, Id, Son).
  387
  388
  389unlink(TN) :->
  390    (   get(TN, tree, Tree),
  391        Tree \== @nil,
  392        get(Tree, nodes, Table),
  393        get(TN, identifier, Id),
  394        send(Table, delete, Id)
  395    ->  true
  396    ;   true
  397    ),
  398    send_super(TN, unlink).
  399
  400
  401collapsed(Node, Val:bool*) :->
  402    "Switch collapsed mode"::
  403    (   get(Node, collapsed, Val)
  404    ->  true
  405    ;   (   Val == @on
  406        ->  get(Node?tree, window, TocWindow),
  407            get(Node, identifier, Id),
  408            send(TocWindow, collapse_node, Id)
  409        ;   Val == @off
  410        ->  get(Node?tree, window, TocWindow),
  411            get(Node, identifier, Id),
  412            (   get(TocWindow, display, Display)
  413            ->  send(Display, busy_cursor),
  414                ignore(send(TocWindow, expand_node, Id)),
  415                send(Display, busy_cursor, @nil)
  416            ;   ignore(send(TocWindow, expand_node, Id))
  417            )
  418        ;   TocWindow = @nil
  419        ),
  420        (   object(Node)
  421        ->  send_super(Node, collapsed, Val),
  422            send(Node, update_image),
  423            (   Val == @off
  424            ->  send(TocWindow, normalise_tree, Node)
  425            ;   true
  426            )
  427        ;   true
  428        )
  429    ).
  430
  431hide_sons(Node) :->
  432    "Hide (delete) sons on a collapse"::
  433    send(Node?sons, for_all, message(@arg1, delete_tree)).
  434
  435can_expand(TF, Val:bool) :->
  436    "Whether or not the node can be expanded"::
  437    (   Val == @off
  438    ->  send_super(TF, collapsed, @nil)
  439    ;   send_super(TF, collapsed, @on)
  440    ).
  441
  442:- pce_group(appearance).
  443
  444image(TF, Img:image) :->
  445    "Modify image at the left"::
  446    get(TF, member, bitmap, BM),
  447    send(BM, image, Img).
  448
  449font(TF, Font:font) :->
  450    "Modify the font"::
  451    send(TF?image?graphicals, for_all,
  452         if(message(@arg1, has_send_method, font),
  453            message(@arg1, font, Font))).
  454
  455update_image(_) :->
  456    true.
  457
  458:- pce_group(action).
  459
  460select(Node, Modified:[bool]) :->
  461    (   Modified == @on
  462    ->  send(Node, toggle_selected)
  463    ;   get(Node, tree, Tree),
  464        send(Tree, selection, Node?image),
  465        send(Node, flush),
  466        send(Tree?window, select_node, Node?identifier)
  467    ).
  468
  469
  470open(Node) :->
  471    send(Node?window, open_node, Node?identifier).
  472
  473:- pce_end_class(toc_node).
  474
  475
  476                 /*******************************
  477                 *      FOLDERS AND FILES       *
  478                 *******************************/
  479
  480:- pce_global(@toc_node_format, make_toc_node_format).  481:- pce_global(@toc_node, new(@receiver?node)).
  482:- pce_global(@toc_node_recogniser,
  483              new(handler_group(click_gesture(left, '', single,
  484                                              message(@toc_node, select)),
  485                                click_gesture(left, c, single,
  486                                              message(@toc_node, select, @on)),
  487                                click_gesture(left, '', double,
  488                                              message(@toc_node, open)),
  489                                handler(ms_right_down,
  490                                        and(message(@toc_node, select),
  491                                            new(or))),
  492                                popup_gesture(?(@receiver?window, popup,
  493                                                @toc_node?identifier)),
  494                                handler(area_enter,
  495                                        message(@receiver, entered, @on)),
  496                                handler(area_exit,
  497                                        message(@receiver, entered, @off))))).
  498
  499
  500:- pce_global(@toc_drag_and_drop_recogniser,
  501              make_toc_drag_and_drop_recogniser).  502
  503make_toc_drag_and_drop_recogniser(G) :-
  504    new(G, drag_and_drop_gesture(left, '', @default,
  505                                 @arg1?drop_target)),
  506    send(G, condition, @event?window?drag_and_drop == @on).
  507
  508make_toc_node_format(F) :-
  509    new(F, format(vertical, 1, @on)),
  510    send(F, row_sep, 5).
  511
  512                 /*******************************
  513                 *           TOC-IMAGE          *
  514                 *******************************/
  515
  516:- pce_begin_class(toc_image, device, "TOC node object").
  517
  518initialise(TF, Label:'char_array|graphical', Img:image) :->
  519    send_super(TF, initialise),
  520    send(TF, format, @toc_node_format),
  521    send(TF, display, bitmap(Img)),
  522    (   send(Label, instance_of, char_array)
  523    ->  new(Gr, text(Label, left, normal))
  524    ;   Gr = Label
  525    ),
  526    send(Gr, name, label),
  527    send(TF, display, Gr).
  528
  529selected(TF, Sel:bool) :->
  530    get(TF, member, label, Text),
  531    send(Text, selected, Sel).
  532selected(TF, Sel:bool) :<-
  533    get(TF, member, label, Text),
  534    get(Text, selected, Sel).
  535
  536label_text(TF, Text:graphical) :<-
  537    "Get graphical rendering the <-label"::
  538    get(TF, member, label, Text).
  539
  540label(TF, Label:'char_array|graphical') :->
  541    "Modify the textual label"::
  542    get(TF, label_text, Text),
  543    (   send(Label, instance_of, char_array)
  544    ->  send(Text, string, Label)
  545    ;   free(Text),
  546        send(TF, display, Label),
  547        send(Label, name, label)
  548    ).
  549label(TF, Label:'char_array|graphical') :<-
  550    "Get the textual label"::
  551    get(TF, label_text, Text),
  552    (   send(Text, has_get_method, string)
  553    ->  get(Text, string, Label)
  554    ;   Label = Text
  555    ).
  556
  557image(TF, Image:image) :->
  558    "Modify the icon"::
  559    get(TF, member, bitmap, BM),
  560    send(BM, image, Image).
  561image(TF, Image:image) :<-
  562    "Get the icon"::
  563    get(TF, member, bitmap, BM),
  564    get(BM, image, Image).
  565
  566:- pce_group(event).
  567
  568event(TF, Ev:event) :->
  569    (   send_super(TF, event, Ev)
  570    ;   send(@toc_node_recogniser, event, Ev)
  571    ).
  572
  573:- pce_group(window).
  574
  575entered(TF, Val:bool) :->
  576    (   Val == @on,
  577        (   send(TF, clipped_by_window)
  578        ->  send(@unclip_window, attach, TF)
  579        ;   true
  580        )
  581    ;   true
  582    ).
  583
  584:- pce_group(drop).
  585
  586drop_target(TF, DTG:'chain|any') :<-
  587    (   get(TF, selected, @on)
  588    ->  get(TF?device, selection, Nodes),
  589        get(Nodes, map, @arg1?identifier, DTG)
  590    ;   get(TF?node, identifier, DTG)
  591    ).
  592
  593:- pce_end_class(toc_image).
  594
  595image(folder, @off, resource(opendir)) :- !.
  596image(folder, _,    resource(closedir)).
  597
  598
  599                 /*******************************
  600                 *          TOC-FOLDER          *
  601                 *******************************/
  602
  603:- pce_begin_class(toc_folder, toc_node, "TOC folder object").
  604
  605variable(collapsed_image,       [image], get, "Icon if collapsed [+]").
  606variable(expanded_image,        [image], get, "Icon if expanded [-]").
  607
  608initialise(TF,
  609           Label:label='char_array|graphical',
  610           Id:identifier=[any],
  611           CollapsedImg:collapsed_image=[image],
  612           ExpandedImg:expanded_image=[image],
  613           CanExpand:can_expand=[bool]) :->
  614    send(TF, slot, collapsed_image, CollapsedImg),
  615    default(ExpandedImg, CollapsedImg, TheExpandedImg),
  616    send(TF, slot, expanded_image, TheExpandedImg),
  617    (   CollapsedImg == @default
  618    ->  image(folder, closed, I)
  619    ;   I = CollapsedImg
  620    ),
  621    send_super(TF, initialise, Id, toc_image(Label, I)),
  622    (   CanExpand == @off
  623    ->  send_class(TF, node, collapsed(@nil))
  624    ;   send_class(TF, node, collapsed(@on))
  625    ).
  626
  627:- pce_group(appearance).
  628
  629collapsed_image(TF, Img:[image]) :->
  630    "Image in collapsed state"::
  631    send(TF, slot, collapsed_image, Img),
  632    send(TF, update_image).
  633
  634expanded_image(TF, Img:[image]) :->
  635    "Image in expanded state"::
  636    send(TF, slot, expanded_image, Img),
  637    send(TF, update_image).
  638
  639
  640:- pce_group(open).
  641
  642update_image(TF) :->
  643    "Update image after status change"::
  644    get(TF, collapsed, Val),
  645    (   Val == @off
  646    ->  get(TF, expanded_image, Img0)
  647    ;   get(TF, collapsed_image, Img0)
  648    ),
  649    (   Img0 == @default
  650    ->  image(folder, Val, Img)
  651    ;   Img = Img0
  652    ),
  653    send(TF, image, Img).
  654
  655:- pce_group(action).
  656
  657open(TF) :->
  658    get(TF, node, Node),
  659    get(Node, collapsed, Collapsed),
  660    (   Collapsed == @on
  661    ->  send(Node, collapsed, @off)
  662    ;   Collapsed == @off
  663    ->  send(Node, collapsed, @on)
  664    ;   send_super(Node, open)
  665    ).
  666
  667:- pce_end_class.
  668
  669                 /*******************************
  670                 *            TOC-FILE          *
  671                 *******************************/
  672
  673:- pce_begin_class(toc_file, toc_node, "TOC file object").
  674
  675initialise(TF, Label:'char_array|graphical', Id:[any], Img:[image]) :->
  676    default(Img, resource(file), I),
  677    send_super(TF, initialise, Id, toc_image(Label, I)),
  678    send(TF, collapsed, @nil).
  679
  680:- pce_group(build).
  681
  682son(TF, _Son:toc_node) :->
  683    send(TF, report, error, 'Cannot add sons to a file'),
  684    fail.
  685
  686expand_all(_TF) :->
  687    true.
  688
  689:- pce_end_class