basis/ui/traverse/traverse.factor

   1 ! Copyright (C) 2007, 2009 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 fry sets ;
   5 IN: ui.traverse
   6
   7 TUPLE: node value children ;
   8
   9 : traverse-step ( path gadget -- path' gadget' )
  10     [ unclip ] dip 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                 [ children>> swap first head-slice % ]
  23                 [ tuck traverse-step traverse-to-path ]
  24                 2bi
  25             ] make-node
  26         ] if
  27     ] if ;
  28
  29 : traverse-from-path ( frompath gadget -- )
  30     dup not [
  31         2drop
  32     ] [
  33         over empty? [
  34             nip ,
  35         ] [
  36             [
  37                 [ traverse-step traverse-from-path ]
  38                 [ tuck children>> swap first 1 + tail-slice % ] 2bi
  39             ] make-node
  40         ] if
  41     ] if ;
  42
  43 : traverse-pre ( frompath gadget -- )
  44     traverse-step traverse-from-path ;
  45
  46 : (traverse-middle) ( frompath topath gadget -- )
  47     [ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
  48
  49 : traverse-post ( topath gadget -- )
  50     traverse-step traverse-to-path ;
  51
  52 : traverse-middle ( frompath topath gadget -- )
  53     [
  54         3dup nip traverse-pre
  55         3dup (traverse-middle)
  56         2dup traverse-post
  57         2nip
  58     ] make-node ;
  59
  60 DEFER: (gadget-subtree)
  61
  62 : traverse-child ( frompath topath gadget -- )
  63     [ 2nip ] 3keep
  64     [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ]
  65     make-node ;
  66
  67 : (gadget-subtree) ( frompath topath gadget -- )
  68     {
  69         { [ dup not ] [ 3drop ] }
  70         { [ pick empty? pick empty? and ] [ 2nip , ] }
  71         { [ pick empty? ] [ traverse-to-path drop ] }
  72         { [ over empty? ] [ nip traverse-from-path ] }
  73         { [ pick first pick first = ] [ traverse-child ] }
  74         [ traverse-middle ]
  75     } cond ;
  76
  77 : gadget-subtree ( frompath topath gadget -- seq )
  78     [ (gadget-subtree) ] { } make ;
  79
  80 M: node gadget-text*
  81     [ children>> ] [ value>> ] bi gadget-seq-text ;
  82
  83 : gadget-text-range ( frompath topath gadget -- str )
  84     gadget-subtree gadget-text ;
  85
  86 : gadget-at-path ( parent path -- gadget )
  87     [ swap nth-gadget ] each ;
  88
  89 GENERIC# leaves* 1 ( tree assoc -- )
  90
  91 M: node leaves* [ children>> ] dip leaves* ;
  92
  93 M: array leaves* '[ _ leaves* ] each ;
  94
  95 M: gadget leaves* conjoin ;
  96
  97 : leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;