basis/ui/gadgets/incremental/incremental.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators grouping kernel math math.vectors
   4 namespaces sequences threads ui.gadgets ui.gadgets.packs
   5 ui.gadgets.private ;
   6 IN: ui.gadgets.incremental
   7
   8 TUPLE: incremental < pack cursor ;
   9
  10 : <incremental> ( -- incremental )
  11     incremental new
  12         vertical >>orientation
  13         { 0 0 } >>cursor ;
  14
  15 M: incremental pref-dim*
  16     dup layout-state>> [
  17         dup call-next-method >>cursor
  18     ] when cursor>> ;
  19
  20 : next-cursor ( gadget incremental -- cursor )
  21     [
  22         [ dim>> ] [ cursor>> ] bi*
  23         [ vmax ] [ v+ ] 2bi
  24     ] keep orientation>> set-axis ;
  25
  26 : update-cursor ( gadget incremental -- )
  27     [ nip ] [ next-cursor ] 2bi >>cursor drop ;
  28
  29 : incremental-loc ( gadget incremental -- )
  30     [ cursor>> ] [ orientation>> ] bi v*
  31     >>loc drop ;
  32
  33 : prefer-incremental ( gadget -- )
  34     dup forget-pref-dim prefer ;
  35
  36 M: incremental dim-changed drop ;
  37
  38 : scroll-children ( incremental -- )
  39     dup children>> length 200,000 > [
  40         ! We let the length oscillate between 100k-200k, so we don't
  41         ! have to relayout the container every time a gadget is added.
  42         [ 100,000 bound cut* ] change-children
  43
  44         ! Unfocus if any focused gadgets were removed and relayout
  45         dup focus>> pick member-eq? [ f >>focus ] when relayout yield
  46
  47         ! Then we finish unparenting the scrolled of gadgets. Yield
  48         ! every 10k gadget so to not overflow the ungraft queue.
  49         10 <groups> [ [ (unparent) ] each yield ] each
  50     ] [ drop ] if ;
  51
  52 : add-incremental ( gadget incremental -- )
  53     not-in-layout
  54     dup scroll-children
  55     2dup (add-gadget)
  56     t in-layout? [
  57         {
  58             [ drop prefer-incremental ]
  59             [ drop layout-later ]
  60             [ incremental-loc ]
  61             [ update-cursor ]
  62             [ nip prefer-incremental ]
  63             [ nip parent>> [ invalidate* ] when* ]
  64         } 2cleave
  65     ] with-variable ;
  66
  67 : clear-incremental ( incremental -- )
  68     not-in-layout
  69     [ (clear-gadget) ]
  70     [ forget-pref-dim ]
  71     [ { 0 0 } >>cursor parent>> [ relayout ] when* ]
  72     tri ;