Update 'ui.gadgets.tiling'. Add some help.

diff --git a/extra/ui/gadgets/tiling/tiling.factor b/extra/ui/gadgets/tiling/tiling.factor
new file mode 100644 (file)
index 0000000..8a3c878
--- /dev/null
+++ b/extra/ui/gadgets/tiling/tiling.factor
@@ -0,0 +1,185 @@
+
+USING: kernel sequences math math.order
+       ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
+       help.syntax
+       easy-help ;
+
+IN: ui.gadgets.tiling
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
+
+Summary:
+
+    A gadget which tiles it's children.
+
+    A tiling gadget may contain any number of children, but only a
+    fixed number is displayed at one time. How many are displayed can
+    be controlled via Control-[ and Control-].
+
+    The focus may be switched with Alt-Left and Alt-Right.
+
+    The focused child may be moved via Shift-Alt-Left and
+    Shift-Alt-Right. ..
+
+Example:
+
+    <tiling-shelf>
+      "resource:" directory-files
+        [ [ drop ] <bevel-button> tiling-add ]
+      each
+    "Files" open-window ..
+
+;
+
+ABOUT: "ui.gadgets.tiling"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+  init-track
+  { 1 0 }    >>orientation
+  V{ } clone >>gadgets
+  2          >>tiles
+  0          >>first
+  0          >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+  [ 0 max ] dip
+  pick length [ min ] curry bi@
+  rot
+  subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+  [ gadgets>> ]
+  [ first>> ]
+  [ [ first>> ] [ tiles>> ] bi + ]
+  tri
+  bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+  dup clear-track
+  dup tiling-gadgets-to-map [ 1 track-add ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+  over gadgets>> push
+  tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+  dup [ focused>> ] [ first>> ] bi <
+    [ dup first>> 1 - >>first ]
+    [ ]
+  if
+
+  dup [ last-viewable ] [ focused>> ] bi <
+    [ dup first>> 1 + >>first ]
+    [ ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+  dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+  dup focused>> 1 - >>focused
+  check-focused-bounds
+  make-focused-mapped
+  tiling-map-gadgets
+  dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+  dup focused>> 1 + >>focused
+  check-focused-bounds
+  make-focused-mapped
+  tiling-map-gadgets
+  dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+                   [ 0 max ] bi@
+  pick length 1 - '[ _ min ] bi@
+  rot exchange ;
+
+: move-prev ( tiling -- tiling )
+  dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+  focus-prev ;
+
+: move-next ( tiling -- tiling )
+  dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+  focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+  dup tiles>> 1 + >>tiles
+  tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+  dup tiles>> 1 - 1 max >>tiles
+  tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+   [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile  < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+  tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+  tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+    { T{ key-down f { A+    } "LEFT"  } [ focus-prev  drop ] }
+    { T{ key-down f { A+    } "RIGHT" } [ focus-next drop ] }
+    { T{ key-down f { S+ A+ } "LEFT"  } [ move-prev   drop ] }
+    { T{ key-down f { S+ A+ } "RIGHT" } [ move-next  drop ] }
+    { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
+    { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
+  }
+set-gestures
+
+tiling-pile
+ H{
+    { T{ key-down f { A+    } "UP"  } [ focus-prev  drop ] }
+    { T{ key-down f { A+    } "DOWN" } [ focus-next drop ] }
+    { T{ key-down f { S+ A+ } "UP"  } [ move-prev   drop ] }
+    { T{ key-down f { S+ A+ } "DOWN" } [ move-next  drop ] }
+    { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
+    { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
+  }
+set-gestures