library/ui/gadgets/outliner.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-outliner
   4 USING: arrays gadgets gadgets-borders gadgets-buttons
   5 gadgets-frames gadgets-grids gadgets-labels gadgets-panes
   6 gadgets-theme generic io kernel math opengl sequences styles ;
   7
   8 ! Vertical line.
   9 TUPLE: guide color ;
  10
  11 M: guide draw-interior
  12     guide-color gl-color
  13     rect-dim dup { 0.5 0 0 } v* swap { 0.5 1 0 } v* gl-line ;
  14
  15 : <guide-gadget> ( -- gadget )
  16     <gadget>
  17     T{ guide f { 0.5 0.5 0.5 1.0 } } over set-gadget-interior ;
  18
  19 ! Outliner gadget.
  20 TUPLE: outliner quot ;
  21
  22 : outliner-expanded? ( outliner -- ? )
  23     #! If the outliner is expanded, it has a center gadget.
  24     @center grid-child >boolean ;
  25
  26 : find-outliner ( gadget -- outliner )
  27     [ outliner? ] find-parent ;
  28
  29 : <expand-arrow> ( ? -- gadget )
  30     arrow-right arrow-down ? { 0.5 0.5 0.5 1.0 } swap
  31     <polygon-gadget> <default-border> ;
  32
  33 DEFER: set-outliner-expanded?
  34
  35 : <expand-button> ( ? -- gadget )
  36     #! If true, the button expands, otherwise it collapses.
  37     dup [ swap find-outliner set-outliner-expanded? ] curry
  38     >r <expand-arrow> r> <highlight-button> ;
  39
  40 : setup-expand ( expanded? outliner -- )
  41     >r not <expand-button> r> @top-left grid-add ;
  42
  43 : setup-center ( expanded? outliner -- )
  44     [ swap [ outliner-quot make-pane ] [ drop f ] if ] keep
  45     @center grid-add ;
  46
  47 : setup-guide ( expanded? outliner -- )
  48     >r [ <guide-gadget> ] [ f ] if r> @left grid-add ;
  49
  50 : set-outliner-expanded? ( expanded? outliner -- )
  51     #! Call the expander quotation if expanding.
  52     2dup setup-expand 2dup setup-center setup-guide ;
  53
  54 C: outliner ( gadget quot -- gadget )
  55     #! The quotation generates child gadgets.
  56     dup delegate>frame
  57     [ set-outliner-quot ] keep
  58     [ >r 1array make-shelf r> @top grid-add ] keep
  59     f over set-outliner-expanded? ;