basis/ui/traverse/traverse.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors namespaces make sequences kernel math arrays io
   4 ui.gadgets generic combinators ;
   5 IN: ui.traverse
   6
   7 TUPLE: node value children ;
   8
   9 : traverse-step ( path gadget -- path' gadget' )
  10     >r unclip r> children>> ?nth ;
  11
  12 : make-node ( quot -- ) { } make node boa , ; inline
  13
  14 : traverse-to-path ( topath gadget -- )
  15     dup not [
  16         2drop
  17     ] [
  18         over empty? [
  19             nip ,
  20         ] [
  21             [
  22                 2dup children>> swap first head-slice %
  23                 tuck traverse-step traverse-to-path
  24             ] make-node
  25         ] if
  26     ] if ;
  27
  28 : traverse-from-path ( frompath gadget -- )
  29     dup not [
  30         2drop
  31     ] [
  32         over empty? [
  33             nip ,
  34         ] [
  35             [
  36                 2dup traverse-step traverse-from-path
  37                 tuck children>> swap first 1+ tail-slice %
  38             ] make-node
  39         ] if
  40     ] if ;
  41
  42 : traverse-pre ( frompath gadget -- )
  43     traverse-step traverse-from-path ;
  44
  45 : (traverse-middle) ( frompath topath gadget -- )
  46     >r >r first 1+ r> first r> children>> <slice> % ;
  47
  48 : traverse-post ( topath gadget -- )
  49     traverse-step traverse-to-path ;
  50
  51 : traverse-middle ( frompath topath gadget -- )
  52     [
  53         3dup nip traverse-pre
  54         3dup (traverse-middle)
  55         2dup traverse-post
  56         2nip
  57     ] make-node ;
  58
  59 DEFER: (gadget-subtree)
  60
  61 : traverse-child ( frompath topath gadget -- )
  62     dup -roll [
  63         >r >r rest-slice r> r> traverse-step (gadget-subtree)
  64     ] make-node ;
  65
  66 : (gadget-subtree) ( frompath topath gadget -- )
  67     {
  68         { [ dup not ] [ 3drop ] }
  69         { [ pick empty? pick empty? and ] [ 2nip , ] }
  70         { [ pick empty? ] [ rot drop traverse-to-path ] }
  71         { [ over empty? ] [ nip traverse-from-path ] }
  72         { [ pick first pick first = ] [ traverse-child ] }
  73         [ traverse-middle ]
  74     } cond ;
  75
  76 : gadget-subtree ( frompath topath gadget -- seq )
  77     [ (gadget-subtree) ] { } make ;
  78
  79 M: node gadget-text*
  80     dup children>> swap value>> gadget-seq-text ;
  81
  82 : gadget-text-range ( frompath topath gadget -- str )
  83     gadget-subtree gadget-text ;
  84
  85 : gadget-at-path ( parent path -- gadget )
  86     [ swap nth-gadget ] each ;