basis/ui/traverse/traverse.factor

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