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