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([ default/3
   39           , ignore/1
   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    send(TC, level_gap, 17).
  317
  318root(TC, Root:toc_node, Relink:[bool]) :->
  319    "Assign the root"::
  320    send_super(TC, root, Root, Relink),
  321    send(TC?nodes, append, Root?identifier, Root).
  322
  323selection(TC, SelectedNodes:chain) :<-
  324    "Find all toc_nodes that are selected"::
  325    get(TC?contains, find_all, @arg1?selected == @on, SelectedNodes).
  326
  327selection(TC, Selection:'any|graphical|chain*') :->
  328    "Select the given nodes"::
  329    send(TC, compute),
  330    (   send(Selection, instance_of, chain)
  331    ->  get(Selection, map, ?(TC, node_image, @arg1), Graphicals),
  332        send_super(TC, selection, Graphicals)
  333    ;   Selection == @nil
  334    ->  send_super(TC, selection, Selection)
  335    ;   get(TC, node_image, Selection, Gr)
  336    ->  send_super(TC, selection, Gr)
  337    ).
  338
  339node(TC, From:any, Node:toc_node) :<-
  340    "Get node from node or ID"::
  341    (   send(From, instance_of, toc_node)
  342    ->  Node = From
  343    ;   get(TC?nodes, member, From, Node)
  344    ).
  345
  346node_image(TC, From:any, Gr:graphical) :<-
  347    "Get node image from graphical, node or ID"::
  348    (   send(From, instance_of, graphical)
  349    ->  Gr = From
  350    ;   send(From, instance_of, toc_node)
  351    ->  get(From, image, Gr)
  352    ;   get(TC?nodes, member, From, Node),
  353        get(Node, image, Gr)
  354    ).
  355
  356:- pce_end_class(toc_tree).
  357
  358
  359:- pce_begin_class(toc_node, node,
  360                   "Node for the table-of-contents package").
  361
  362variable(identifier, [any],             none, "Identification handle").
  363
  364initialise(TN, Id:any, Image:toc_image) :->
  365    send(TN, slot, identifier, Id),
  366    send_super(TN, initialise, Image).
  367
  368
  369identifier(TN, Id:any) :<-
  370    "Get given identifier or <-self"::
  371    get(TN, slot, identifier, Id0),
  372    (   Id0 == @default
  373    ->  Id = TN
  374    ;   Id = Id0
  375    ).
  376
  377
  378son(TN, Son:toc_node) :->
  379    "Add a son below this node"::
  380    send_super(TN, son, Son),
  381    get(Son, identifier, Id),
  382    get(TN?tree, nodes, Nodes),
  383    send(Nodes, append, Id, Son).
  384
  385
  386unlink(TN) :->
  387    (   get(TN, tree, Tree),
  388        Tree \== @nil,
  389        get(Tree, nodes, Table),
  390        get(TN, identifier, Id),
  391        send(Table, delete, Id)
  392    ->  true
  393    ;   true
  394    ),
  395    send_super(TN, unlink).
  396
  397
  398collapsed(Node, Val:bool*) :->
  399    "Switch collapsed mode"::
  400    (   get(Node, collapsed, Val)
  401    ->  true
  402    ;   (   Val == @on
  403        ->  get(Node?tree, window, TocWindow),
  404            get(Node, identifier, Id),
  405            send(TocWindow, collapse_node, Id)
  406        ;   Val == @off
  407        ->  get(Node?tree, window, TocWindow),
  408            get(Node, identifier, Id),
  409            (   get(TocWindow, display, Display)
  410            ->  send(Display, busy_cursor),
  411                ignore(send(TocWindow, expand_node, Id)),
  412                send(Display, busy_cursor, @nil)
  413            ;   ignore(send(TocWindow, expand_node, Id))
  414            )
  415        ;   TocWindow = @nil
  416        ),
  417        (   object(Node)
  418        ->  send_super(Node, collapsed, Val),
  419            send(Node, update_image),
  420            (   Val == @off
  421            ->  send(TocWindow, normalise_tree, Node)
  422            ;   true
  423            )
  424        ;   true
  425        )
  426    ).
  427
  428hide_sons(Node) :->
  429    "Hide (delete) sons on a collapse"::
  430    send(Node?sons, for_all, message(@arg1, delete_tree)).
  431
  432can_expand(TF, Val:bool) :->
  433    "Whether or not the node can be expanded"::
  434    (   Val == @off
  435    ->  send_super(TF, collapsed, @nil)
  436    ;   send_super(TF, collapsed, @on)
  437    ).
  438
  439:- pce_group(appearance).
  440
  441image(TF, Img:image) :->
  442    "Modify image at the left"::
  443    get(TF, member, bitmap, BM),
  444    send(BM, image, Img).
  445
  446font(TF, Font:font) :->
  447    "Modify the font"::
  448    send(TF?image?graphicals, for_all,
  449         if(message(@arg1, has_send_method, font),
  450            message(@arg1, font, Font))).
  451
  452update_image(_) :->
  453    true.
  454
  455:- pce_group(action).
  456
  457select(Node, Modified:[bool]) :->
  458    (   Modified == @on
  459    ->  send(Node, toggle_selected)
  460    ;   get(Node, tree, Tree),
  461        send(Tree, selection, Node?image),
  462        send(Node, flush),
  463        send(Tree?window, select_node, Node?identifier)
  464    ).
  465
  466
  467open(Node) :->
  468    send(Node?window, open_node, Node?identifier).
  469
  470:- pce_end_class(toc_node).
  471
  472
  473                 /*******************************
  474                 *      FOLDERS AND FILES       *
  475                 *******************************/
  476
  477:- pce_global(@toc_node_format, make_toc_node_format).  478:- pce_global(@toc_node, new(@receiver?node)).
  479:- pce_global(@toc_node_recogniser,
  480              new(handler_group(click_gesture(left, '', single,
  481                                              message(@toc_node, select)),
  482                                click_gesture(left, c, single,
  483                                              message(@toc_node, select, @on)),
  484                                click_gesture(left, '', double,
  485                                              message(@toc_node, open)),
  486                                handler(ms_right_down,
  487                                        and(message(@toc_node, select),
  488                                            new(or))),
  489                                popup_gesture(?(@receiver?window, popup,
  490                                                @toc_node?identifier)),
  491                                handler(area_enter,
  492                                        message(@receiver, entered, @on)),
  493                                handler(area_exit,
  494                                        message(@receiver, entered, @off))))).
  495
  496
  497:- pce_global(@toc_drag_and_drop_recogniser,
  498              make_toc_drag_and_drop_recogniser).  499
  500make_toc_drag_and_drop_recogniser(G) :-
  501    new(G, drag_and_drop_gesture(left, '', @default,
  502                                 @arg1?drop_target)),
  503    send(G, condition, @event?window?drag_and_drop == @on).
  504
  505make_toc_node_format(F) :-
  506    new(F, format(vertical, 1, @on)),
  507    send(F, row_sep, 5).
  508
  509                 /*******************************
  510                 *           TOC-IMAGE          *
  511                 *******************************/
  512
  513:- pce_begin_class(toc_image, device, "TOC node object").
  514
  515initialise(TF, Label:'char_array|graphical', Img:image) :->
  516    send_super(TF, initialise),
  517    send(TF, format, @toc_node_format),
  518    send(TF, display, bitmap(Img)),
  519    (   send(Label, instance_of, char_array)
  520    ->  new(Gr, text(Label, left, normal))
  521    ;   Gr = Label
  522    ),
  523    send(Gr, name, label),
  524    send(TF, display, Gr).
  525
  526selected(TF, Sel:bool) :->
  527    get(TF, member, label, Text),
  528    send(Text, selected, Sel).
  529selected(TF, Sel:bool) :<-
  530    get(TF, member, label, Text),
  531    get(Text, selected, Sel).
  532
  533label_text(TF, Text:graphical) :<-
  534    "Get graphical rendering the <-label"::
  535    get(TF, member, label, Text).
  536
  537label(TF, Label:'char_array|graphical') :->
  538    "Modify the textual label"::
  539    get(TF, label_text, Text),
  540    (   send(Label, instance_of, char_array)
  541    ->  send(Text, string, Label)
  542    ;   free(Text),
  543        send(TF, display, Label),
  544        send(Label, name, label)
  545    ).
  546label(TF, Label:'char_array|graphical') :<-
  547    "Get the textual label"::
  548    get(TF, label_text, Text),
  549    (   send(Text, has_get_method, string)
  550    ->  get(Text, string, Label)
  551    ;   Label = Text
  552    ).
  553
  554image(TF, Image:image) :->
  555    "Modify the icon"::
  556    get(TF, member, bitmap, BM),
  557    send(BM, image, Image).
  558image(TF, Image:image) :<-
  559    "Get the icon"::
  560    get(TF, member, bitmap, BM),
  561    get(BM, image, Image).
  562
  563:- pce_group(event).
  564
  565event(TF, Ev:event) :->
  566    (   send_super(TF, event, Ev)
  567    ;   send(@toc_node_recogniser, event, Ev)
  568    ).
  569
  570:- pce_group(window).
  571
  572entered(TF, Val:bool) :->
  573    (   Val == @on,
  574        (   send(TF, clipped_by_window)
  575        ->  send(@unclip_window, attach, TF)
  576        ;   true
  577        )
  578    ;   true
  579    ).
  580
  581:- pce_group(drop).
  582
  583drop_target(TF, DTG:'chain|any') :<-
  584    (   get(TF, selected, @on)
  585    ->  get(TF?device, selection, Nodes),
  586        get(Nodes, map, @arg1?identifier, DTG)
  587    ;   get(TF?node, identifier, DTG)
  588    ).
  589
  590:- pce_end_class(toc_image).
  591
  592image(folder, @off, resource(opendir)) :- !.
  593image(folder, _,    resource(closedir)).
  594
  595
  596                 /*******************************
  597                 *          TOC-FOLDER          *
  598                 *******************************/
  599
  600:- pce_begin_class(toc_folder, toc_node, "TOC folder object").
  601
  602variable(collapsed_image,       [image], get, "Icon if collapsed [+]").
  603variable(expanded_image,        [image], get, "Icon if expanded [-]").
  604
  605initialise(TF,
  606           Label:label='char_array|graphical',
  607           Id:identifier=[any],
  608           CollapsedImg:collapsed_image=[image],
  609           ExpandedImg:expanded_image=[image],
  610           CanExpand:can_expand=[bool]) :->
  611    send(TF, slot, collapsed_image, CollapsedImg),
  612    default(ExpandedImg, CollapsedImg, TheExpandedImg),
  613    send(TF, slot, expanded_image, TheExpandedImg),
  614    (   CollapsedImg == @default
  615    ->  image(folder, closed, I)
  616    ;   I = CollapsedImg
  617    ),
  618    send_super(TF, initialise, Id, toc_image(Label, I)),
  619    (   CanExpand == @off
  620    ->  send_class(TF, node, collapsed(@nil))
  621    ;   send_class(TF, node, collapsed(@on))
  622    ).
  623
  624:- pce_group(appearance).
  625
  626collapsed_image(TF, Img:[image]) :->
  627    "Image in collapsed state"::
  628    send(TF, slot, collapsed_image, Img),
  629    send(TF, update_image).
  630
  631expanded_image(TF, Img:[image]) :->
  632    "Image in expanded state"::
  633    send(TF, slot, expanded_image, Img),
  634    send(TF, update_image).
  635
  636
  637:- pce_group(open).
  638
  639update_image(TF) :->
  640    "Update image after status change"::
  641    get(TF, collapsed, Val),
  642    (   Val == @off
  643    ->  get(TF, expanded_image, Img0)
  644    ;   get(TF, collapsed_image, Img0)
  645    ),
  646    (   Img0 == @default
  647    ->  image(folder, Val, Img)
  648    ;   Img = Img0
  649    ),
  650    send(TF, image, Img).
  651
  652:- pce_group(action).
  653
  654open(TF) :->
  655    get(TF, node, Node),
  656    get(Node, collapsed, Collapsed),
  657    (   Collapsed == @on
  658    ->  send(Node, collapsed, @off)
  659    ;   Collapsed == @off
  660    ->  send(Node, collapsed, @on)
  661    ;   send_super(Node, open)
  662    ).
  663
  664:- pce_end_class.
  665
  666                 /*******************************
  667                 *            TOC-FILE          *
  668                 *******************************/
  669
  670:- pce_begin_class(toc_file, toc_node, "TOC file object").
  671
  672initialise(TF, Label:'char_array|graphical', Id:[any], Img:[image]) :->
  673    default(Img, resource(file), I),
  674    send_super(TF, initialise, Id, toc_image(Label, I)),
  675    send(TF, collapsed, @nil).
  676
  677:- pce_group(build).
  678
  679son(TF, _Son:toc_node) :->
  680    send(TF, report, error, 'Cannot add sons to a file'),
  681    fail.
  682
  683expand_all(_TF) :->
  684    true.
  685
  686:- pce_end_class