Add ui.gadgets.tiling

2008-07-22 14:20:55 -05:00 · 2008-07-22 14:20:55 -05:00 · a27be7daae
parent e799acd1c3
commit a27be7daae
1 changed files with 118 additions and 0 deletions
--- a/extra/ui/gadgets/tiling/tiling.factor
+++ b/extra/ui/gadgets/tiling/tiling.factor
@ -0,0 +1,118 @@
+
+USING: kernel sequences math math.order
+       ui.gadgets ui.gadgets.tracks ui.gestures
+       accessors ;
+
+IN: ui.gadgets.tiling
+
+TUPLE: tiling < track gadgets columns first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+  init-track
+  { 1 0 }    >>orientation
+  V{ } clone >>gadgets
+  2          >>columns
+  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>> ] [ columns>> ] 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>> ] [ columns>> ] 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-left ( tiling -- tiling )
+  dup focused>> 1 - >>focused
+  check-focused-bounds
+  make-focused-mapped
+  tiling-map-gadgets
+  dup request-focus ;
+
+: focus-right ( tiling -- tiling )
+  dup focused>> 1 + >>focused
+  check-focused-bounds
+  make-focused-mapped
+  tiling-map-gadgets
+  dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-column ( tiling -- tiling )
+  dup columns>> 1 + >>columns
+  tiling-map-gadgets ;
+
+: del-column ( tiling -- tiling )
+  dup columns>> 1 - 1 max >>columns
+  tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+   [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+tiling
+ H{
+    { T{ key-down f { A+ } "LEFT"  } [ focus-left  drop ] }
+    { T{ key-down f { A+ } "RIGHT" } [ focus-right drop ] }
+    { T{ key-down f { C+ } "["     } [ del-column  drop ] }
+    { T{ key-down f { C+ } "]"     } [ add-column  drop ] }
+  }
+set-gestures