/*  Part of XPCE --- The SWI-Prolog GUI toolkit

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        jan@swi.psy.uva.nl
    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    Copyright (c)  1996-2013, University of Amsterdam
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

:- module(pce_toc, []).
:- use_module(library(pce)).
:- use_module(library(pce_unclip)).
:- require([ send_list/2,
	     default/3
	   ]).

:- pce_autoload(drag_and_drop_gesture, library(dragdrop)).

resource(file,          image, image('16x16/doc.xpm')).
resource(opendir,       image, image('opendir.xpm')).
resource(closedir,      image, image('closedir.xpm')).

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Status and aim
==============

This is the  first  version  of   an  XPCE/Prolog  library  for managing
hierarchies in a similar fashion as many Windows(tm) tools.

The current version is not well   prepared for modifyable structures. It
is designed for the contents browser of  the SWI-Prolog manual, but with
the intention to grow into a more widely usable library.

The objective is that the   application programmer subclasses toc_window
and (re)defines the virtual methods  there   to  tailor  this package to
his/her application. The other classes in   this package should normally
not be affected.

Typical usage
=============

        :- pce_autoload(toc_window, library(pce_toc)).

        :- pce_begin_class(directory_hierarchy, toc_window,
                           "Browser for a directory-hierarchy").

        initialise(FB, Root:directory) :->
                send_super(FB, initialise),
                get(Root, name, Name),
                send(FB, root, toc_folder(Name, Root)).

        expand_node(FB, D:directory) :->
                get(D, directories, SubDirsNames),
                get(SubDirsNames, map, ?(D, directory, @arg1), SubDirs),
                send(SubDirs, for_all,
                     message(FB, son, D,
                             create(toc_folder, @arg1?name, @arg1))).

        :- pce_end_class.


        ?- send(directory_hierarchy(~), open).

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

                 /*******************************
                 *          TOC-WINDOW          *
                 *******************************/

:- pce_begin_class(toc_window(name), window,
                   "Window for table-of-contents").

variable(drag_and_drop, bool := @off, get, "Allow drag-and-drop").

initialise(TW) :->
    "Create window and display empty toc_tree"::
    send_super(TW, initialise),
    send(TW, scrollbars, both),
    send(TW, hor_shrink, 0),
    send(TW, hor_stretch, 1),
    send(TW, display, new(toc_tree), point(10, 5)).

:- pce_group(parts).

tree(TW, Tree:toc_tree) :<-
    "Get the toc_tree"::
    get(TW, member, toc_tree, Tree).


root(TW, Root:node) :<-
    "Get the root-node of the tree"::
    get(TW, member, toc_tree, Tree),
    get(Tree, root, Root).


selection(TW, Nodes:chain) :<-
    "Return new chain holding selected nodes"::
    get(TW, member, toc_tree, Tree),
    get(Tree, selection, Nodes).

selection(TW, Nodes:'any|chain*') :->
    "Set selected nodes"::
    get(TW, member, toc_tree, Tree),
    send(Tree, selection, Nodes).

node(TW, Id:any, Node:toc_node) :<-
    "Find node from identifier"::
    get(TW, member, toc_tree, Tree),
    get(Tree, nodes, Table),
    (   get(Table, member, Id, Node)
    ->  true
    ;   send(Id, instance_of, toc_node),
        Node = Id
    ).

:- pce_group(virtual).

open_node(_TW, _Id:any) :->
    "Called on double-click"::
    true.

select_node(_TW, _Id:any) :->
    "Called on single-click"::
    true.

expand_node(TW, Id:any) :->
    "Define expansion of node 'id'"::
    get(TW, node, Id, Node),
    send(Node, slot, collapsed, @off).

collapse_node(TW, Id:any) :->
    "Define collapsing of node 'id'"::
    get(TW, node, Id, Node),
    send(Node, hide_sons).

popup(_TW, _Id:any, _Popup:popup) :<-
    "Return a menu for this node"::
    fail.

:- pce_group(build).

root(TW, Root:toc_folder, Relink:[bool]) :->
    "Assign the table a root"::
    get(TW, tree, Tree),
    send(Tree, root, Root, Relink).

son(TW, Parent:any, Son:toc_node) :->
    "Add a son to a node"::
    get(TW, node, Parent, Node),
    send(Node, son, Son).

delete(TW, Id:any) :->
    "Delete node (and subnodes)"::
    get(TW, node, Id, Node),
    send(Node?node, delete_tree).

expand_root(T) :->
    "Expand the root-node"::
    get(T?tree, root, Node),
    ignore(send(Node, collapsed, @off)).

clear(T) :->
    "Remove the nodes, not the tree"::
    get(T, tree, Tree),
    send(Tree, clear, destroy).

:- pce_group(state).


expanded_ids(T, Ids:chain) :<-
    "Chain holding the ids of all expanded nodes"::
    new(Ids, chain),
    (   get(T?tree, root, Root),
        Root \== @nil
    ->  send(Root, for_all,
             if(@arg1?collapsed == @off,
                message(Ids, append, @arg1?identifier)))
    ;   true
    ).

expand_ids(T, Ids:chain) :->
    "Expand the given ids"::
    send(Ids, for_all, message(T, expand_id, @arg1)).

expand_id(T, Id:any) :->
    "Expand node with given ID"::
    get(T, node, Id, Node),
    send(Node, collapsed, @off).

:- pce_group(scroll).

scroll_vertical(TW,
                Direction:{forwards,backwards,goto},
                Unit:{page,file,line},
                Amount:int) :->
    "Prevent scrolling too far"::
    get(TW, visible, VA),
    get(TW, bounding_box, BB),
    (   send(VA, inside, BB)
    ->  true
    ;   Direction == backwards,
        get(VA, y, Y),
        Y < 1
    ->  true
    ;   Direction == forwards,
        get(BB, bottom_side, BBBottom),
        get(VA, bottom_side, VABottom),
        VABottom > BBBottom
    ->  true
    ;   send_super(TW, scroll_vertical, Direction, Unit, Amount),
        get(TW, visible, area(_, AY, _, _)),
        (   AY < 0
        ->  send(TW, scroll_to, point(0,0))
        ;   true
        )
    ).

normalise_tree(TW, Id:any) :->
    "Make as much as possible of the subtree visible"::
    get(TW, node, Id, Node),
    (   get(Node, sons, Sons),
        Sons \== @nil
    ->  send(TW, compute),          % ensure proper layout
        get(Sons, map, @arg1?image, Grs),
        send(Grs, append, Node?image),
        send(TW, normalise, Grs, y) % class-variable?
    ;   true
    ).

:- pce_group(event).

:- pce_global(@toc_window_recogniser,
              make_toc_window_recogniser).

make_toc_window_recogniser(G) :-
    new(C, click_gesture(left, '', single,
                         message(@receiver, selection, @nil))),
    new(KB, key_binding(toc_window)),
    send_list(KB,
              [ function(page_up,
                         message(@receiver, scroll_vertical, backwards,
                                 page, 900)),
                function(page_down,
                         message(@receiver, scroll_vertical, forwards,
                                 page, 900)),
                function(cursor_home,
                         message(@receiver, scroll_vertical, goto,
                                 file, 0)),
                function(end,
                         message(@receiver, scroll_vertical, goto,
                                 file, 1000))
              ]),
    new(G, handler_group(C, KB)).

event(TW, Ev:event) :->
    "Handle key-bindings"::
    (   send_super(TW, event, Ev)
    ;   send(@toc_window_recogniser, event, Ev)
    ).


drag_and_drop(TW, Val:bool) :->
    "(dis)allow drag-and-drop"::
    send(TW, slot, drag_and_drop, Val),
    (   Val == @on
    ->  (   send(@toc_node_recogniser?members, member,
                 @toc_drag_and_drop_recogniser)
        ->  true
        ;   send(@toc_node_recogniser?members, append,
                 @toc_drag_and_drop_recogniser)
        )
    ).

:- pce_end_class(toc_window).


                 /*******************************
                 *            TOC-TREE          *
                 *******************************/

:- pce_begin_class(toc_tree, tree,
                   "Tree to display table-of-contents").

variable(nodes, hash_table, get, "Id --> node mapping").

initialise(TC) :->
    "Create the tree, setting style and geometry"::
    send(TC, slot, nodes, new(hash_table)),
    send_super(TC, initialise),
    send(TC, direction, list),
    send(TC, level_gap, 17).

root(TC, Root:toc_node, Relink:[bool]) :->
    "Assign the root"::
    send_super(TC, root, Root, Relink),
    send(TC?nodes, append, Root?identifier, Root).

selection(TC, SelectedNodes:chain) :<-
    "Find all toc_nodes that are selected"::
    get(TC?contains, find_all, @arg1?selected == @on, SelectedNodes).

selection(TC, Selection:'any|graphical|chain*') :->
    "Select the given nodes"::
    send(TC, compute),
    (   send(Selection, instance_of, chain)
    ->  get(Selection, map, ?(TC, node_image, @arg1), Graphicals),
        send_super(TC, selection, Graphicals)
    ;   Selection == @nil
    ->  send_super(TC, selection, Selection)
    ;   get(TC, node_image, Selection, Gr)
    ->  send_super(TC, selection, Gr)
    ).

node(TC, From:any, Node:toc_node) :<-
    "Get node from node or ID"::
    (   send(From, instance_of, toc_node)
    ->  Node = From
    ;   get(TC?nodes, member, From, Node)
    ).

node_image(TC, From:any, Gr:graphical) :<-
    "Get node image from graphical, node or ID"::
    (   send(From, instance_of, graphical)
    ->  Gr = From
    ;   send(From, instance_of, toc_node)
    ->  get(From, image, Gr)
    ;   get(TC?nodes, member, From, Node),
        get(Node, image, Gr)
    ).

:- pce_end_class(toc_tree).


:- pce_begin_class(toc_node, node,
                   "Node for the table-of-contents package").

variable(identifier, [any],             none, "Identification handle").

initialise(TN, Id:any, Image:toc_image) :->
    send(TN, slot, identifier, Id),
    send_super(TN, initialise, Image).


identifier(TN, Id:any) :<-
    "Get given identifier or <-self"::
    get(TN, slot, identifier, Id0),
    (   Id0 == @default
    ->  Id = TN
    ;   Id = Id0
    ).


son(TN, Son:toc_node) :->
    "Add a son below this node"::
    send_super(TN, son, Son),
    get(Son, identifier, Id),
    get(TN?tree, nodes, Nodes),
    send(Nodes, append, Id, Son).


unlink(TN) :->
    (   get(TN, tree, Tree),
        Tree \== @nil,
        get(Tree, nodes, Table),
        get(TN, identifier, Id),
        send(Table, delete, Id)
    ->  true
    ;   true
    ),
    send_super(TN, unlink).


collapsed(Node, Val:bool*) :->
    "Switch collapsed mode"::
    (   get(Node, collapsed, Val)
    ->  true
    ;   (   Val == @on
        ->  get(Node?tree, window, TocWindow),
            get(Node, identifier, Id),
            send(TocWindow, collapse_node, Id)
        ;   Val == @off
        ->  get(Node?tree, window, TocWindow),
            get(Node, identifier, Id),
            (   get(TocWindow, display, Display)
            ->  send(Display, busy_cursor),
                ignore(send(TocWindow, expand_node, Id)),
                send(Display, busy_cursor, @nil)
            ;   ignore(send(TocWindow, expand_node, Id))
            )
        ;   TocWindow = @nil
        ),
        (   object(Node)
        ->  send_super(Node, collapsed, Val),
            send(Node, update_image),
            (   Val == @off
            ->  send(TocWindow, normalise_tree, Node)
            ;   true
            )
        ;   true
        )
    ).

hide_sons(Node) :->
    "Hide (delete) sons on a collapse"::
    send(Node?sons, for_all, message(@arg1, delete_tree)).

can_expand(TF, Val:bool) :->
    "Whether or not the node can be expanded"::
    (   Val == @off
    ->  send_super(TF, collapsed, @nil)
    ;   send_super(TF, collapsed, @on)
    ).

:- pce_group(appearance).

image(TF, Img:image) :->
    "Modify image at the left"::
    get(TF, member, bitmap, BM),
    send(BM, image, Img).

font(TF, Font:font) :->
    "Modify the font"::
    send(TF?image?graphicals, for_all,
         if(message(@arg1, has_send_method, font),
            message(@arg1, font, Font))).

update_image(_) :->
    true.

:- pce_group(action).

select(Node, Modified:[bool]) :->
    (   Modified == @on
    ->  send(Node, toggle_selected)
    ;   get(Node, tree, Tree),
        send(Tree, selection, Node?image),
        send(Node, flush),
        send(Tree?window, select_node, Node?identifier)
    ).


open(Node) :->
    send(Node?window, open_node, Node?identifier).

:- pce_end_class(toc_node).


                 /*******************************
                 *      FOLDERS AND FILES       *
                 *******************************/

:- pce_global(@toc_node_format, make_toc_node_format).
:- pce_global(@toc_node, new(@receiver?node)).
:- pce_global(@toc_node_recogniser,
              new(handler_group(click_gesture(left, '', single,
                                              message(@toc_node, select)),
                                click_gesture(left, c, single,
                                              message(@toc_node, select, @on)),
                                click_gesture(left, '', double,
                                              message(@toc_node, open)),
                                handler(ms_right_down,
                                        and(message(@toc_node, select),
                                            new(or))),
                                popup_gesture(?(@receiver?window, popup,
                                                @toc_node?identifier)),
                                handler(area_enter,
                                        message(@receiver, entered, @on)),
                                handler(area_exit,
                                        message(@receiver, entered, @off))))).


:- pce_global(@toc_drag_and_drop_recogniser,
              make_toc_drag_and_drop_recogniser).

make_toc_drag_and_drop_recogniser(G) :-
    new(G, drag_and_drop_gesture(left, '', @default,
                                 @arg1?drop_target)),
    send(G, condition, @event?window?drag_and_drop == @on).

make_toc_node_format(F) :-
    new(F, format(vertical, 1, @on)),
    send(F, row_sep, 5).

                 /*******************************
                 *           TOC-IMAGE          *
                 *******************************/

:- pce_begin_class(toc_image, device, "TOC node object").

initialise(TF, Label:'char_array|graphical', Img:image) :->
    send_super(TF, initialise),
    send(TF, format, @toc_node_format),
    send(TF, display, bitmap(Img)),
    (   send(Label, instance_of, char_array)
    ->  new(Gr, text(Label, left, normal))
    ;   Gr = Label
    ),
    send(Gr, name, label),
    send(TF, display, Gr).

selected(TF, Sel:bool) :->
    get(TF, member, label, Text),
    send(Text, selected, Sel).
selected(TF, Sel:bool) :<-
    get(TF, member, label, Text),
    get(Text, selected, Sel).

label_text(TF, Text:graphical) :<-
    "Get graphical rendering the <-label"::
    get(TF, member, label, Text).

label(TF, Label:'char_array|graphical') :->
    "Modify the textual label"::
    get(TF, label_text, Text),
    (   send(Label, instance_of, char_array)
    ->  send(Text, string, Label)
    ;   free(Text),
        send(TF, display, Label),
        send(Label, name, label)
    ).
label(TF, Label:'char_array|graphical') :<-
    "Get the textual label"::
    get(TF, label_text, Text),
    (   send(Text, has_get_method, string)
    ->  get(Text, string, Label)
    ;   Label = Text
    ).

image(TF, Image:image) :->
    "Modify the icon"::
    get(TF, member, bitmap, BM),
    send(BM, image, Image).
image(TF, Image:image) :<-
    "Get the icon"::
    get(TF, member, bitmap, BM),
    get(BM, image, Image).

:- pce_group(event).

event(TF, Ev:event) :->
    (   send_super(TF, event, Ev)
    ;   send(@toc_node_recogniser, event, Ev)
    ).

:- pce_group(window).

entered(TF, Val:bool) :->
    (   Val == @on,
        (   send(TF, clipped_by_window)
        ->  send(@unclip_window, attach, TF)
        ;   true
        )
    ;   true
    ).

:- pce_group(drop).

drop_target(TF, DTG:'chain|any') :<-
    (   get(TF, selected, @on)
    ->  get(TF?device, selection, Nodes),
        get(Nodes, map, @arg1?identifier, DTG)
    ;   get(TF?node, identifier, DTG)
    ).

:- pce_end_class(toc_image).

image(folder, @off, resource(opendir)) :- !.
image(folder, _,    resource(closedir)).


                 /*******************************
                 *          TOC-FOLDER          *
                 *******************************/

:- pce_begin_class(toc_folder, toc_node, "TOC folder object").

variable(collapsed_image,       [image], get, "Icon if collapsed [+]").
variable(expanded_image,        [image], get, "Icon if expanded [-]").

initialise(TF,
           Label:label='char_array|graphical',
           Id:identifier=[any],
           CollapsedImg:collapsed_image=[image],
           ExpandedImg:expanded_image=[image],
           CanExpand:can_expand=[bool]) :->
    send(TF, slot, collapsed_image, CollapsedImg),
    default(ExpandedImg, CollapsedImg, TheExpandedImg),
    send(TF, slot, expanded_image, TheExpandedImg),
    (   CollapsedImg == @default
    ->  image(folder, closed, I)
    ;   I = CollapsedImg
    ),
    send_super(TF, initialise, Id, toc_image(Label, I)),
    (   CanExpand == @off
    ->  send_class(TF, node, collapsed(@nil))
    ;   send_class(TF, node, collapsed(@on))
    ).

:- pce_group(appearance).

collapsed_image(TF, Img:[image]) :->
    "Image in collapsed state"::
    send(TF, slot, collapsed_image, Img),
    send(TF, update_image).

expanded_image(TF, Img:[image]) :->
    "Image in expanded state"::
    send(TF, slot, expanded_image, Img),
    send(TF, update_image).


:- pce_group(open).

update_image(TF) :->
    "Update image after status change"::
    get(TF, collapsed, Val),
    (   Val == @off
    ->  get(TF, expanded_image, Img0)
    ;   get(TF, collapsed_image, Img0)
    ),
    (   Img0 == @default
    ->  image(folder, Val, Img)
    ;   Img = Img0
    ),
    send(TF, image, Img).

:- pce_group(action).

open(TF) :->
    get(TF, node, Node),
    get(Node, collapsed, Collapsed),
    (   Collapsed == @on
    ->  send(Node, collapsed, @off)
    ;   Collapsed == @off
    ->  send(Node, collapsed, @on)
    ;   send_super(Node, open)
    ).

:- pce_end_class.

                 /*******************************
                 *            TOC-FILE          *
                 *******************************/

:- pce_begin_class(toc_file, toc_node, "TOC file object").

initialise(TF, Label:'char_array|graphical', Id:[any], Img:[image]) :->
    default(Img, resource(file), I),
    send_super(TF, initialise, Id, toc_image(Label, I)),
    send(TF, collapsed, @nil).

:- pce_group(build).

son(TF, _Son:toc_node) :->
    send(TF, report, error, 'Cannot add sons to a file'),
    fail.

expand_all(_TF) :->
    true.

:- pce_end_class.