unmaintained/ui/gadgets/tiling/tiling.factor

   1
   2 USING: kernel sequences math math.order
   3        ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
   4        help.syntax
   5        easy-help ;
   6
   7 IN: ui.gadgets.tiling
   8
   9 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  10
  11 ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
  12
  13 Summary:
  14
  15     A gadget which tiles it's children.
  16
  17     A tiling gadget may contain any number of children, but only a
  18     fixed number is displayed at one time. How many are displayed can
  19     be controlled via Control-[ and Control-].
  20
  21     The focus may be switched with Alt-Left and Alt-Right.
  22
  23     The focused child may be moved via Shift-Alt-Left and
  24     Shift-Alt-Right. ..
  25
  26 Example:
  27
  28     <tiling-shelf>
  29       "resource:" directory-files
  30         [ [ drop ] <bevel-button> tiling-add ]
  31       each
  32     "Files" open-window ..
  33
  34 ;
  35
  36 ABOUT: "ui.gadgets.tiling"
  37
  38 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  39
  40 TUPLE: tiling < track gadgets tiles first focused ;
  41
  42 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  43
  44 : init-tiling ( tiling -- tiling )
  45   init-track
  46   { 1 0 }    >>orientation
  47   V{ } clone >>gadgets
  48   2          >>tiles
  49   0          >>first
  50   0          >>focused ;
  51
  52 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  53
  54 : <tiling> ( -- gadget ) tiling new init-tiling ;
  55
  56 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  57
  58 : bounded-subseq ( seq a b -- seq )
  59   [ 0 max ] dip
  60   pick length [ min ] curry bi@
  61   rot
  62   subseq ;
  63
  64 : tiling-gadgets-to-map ( tiling -- gadgets )
  65   [ gadgets>> ]
  66   [ first>> ]
  67   [ [ first>> ] [ tiles>> ] bi + ]
  68   tri
  69   bounded-subseq ;
  70
  71 : tiling-map-gadgets ( tiling -- tiling )
  72   dup clear-track
  73   dup tiling-gadgets-to-map [ 1 track-add ] each ;
  74
  75 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  76
  77 : tiling-add ( tiling gadget -- tiling )
  78   over gadgets>> push
  79   tiling-map-gadgets ;
  80
  81 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  82
  83 : first-gadget ( tiling -- index ) drop 0 ;
  84
  85 : last-gadget ( tiling -- index ) gadgets>> length 1 - ;
  86
  87 : first-viewable ( tiling -- index ) first>> ;
  88
  89 : last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
  90
  91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92
  93 : make-focused-mapped ( tiling -- tiling )
  94
  95   dup [ focused>> ] [ first>> ] bi <
  96     [ dup first>> 1 - >>first ]
  97     [ ]
  98   if
  99
 100   dup [ last-viewable ] [ focused>> ] bi <
 101     [ dup first>> 1 + >>first ]
 102     [ ]
 103   if ;
 104
 105 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 106
 107 : check-focused-bounds ( tiling -- tiling )
 108   dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
 109
 110 : focus-prev ( tiling -- tiling )
 111   dup focused>> 1 - >>focused
 112   check-focused-bounds
 113   make-focused-mapped
 114   tiling-map-gadgets
 115   dup request-focus ;
 116
 117 : focus-next ( tiling -- tiling )
 118   dup focused>> 1 + >>focused
 119   check-focused-bounds
 120   make-focused-mapped
 121   tiling-map-gadgets
 122   dup request-focus ;
 123
 124 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 125
 126 : exchanged! ( seq a b -- )
 127                    [ 0 max ] bi@
 128   pick length 1 - '[ _ min ] bi@
 129   rot exchange ;
 130
 131 : move-prev ( tiling -- tiling )
 132   dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
 133   focus-prev ;
 134
 135 : move-next ( tiling -- tiling )
 136   dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
 137   focus-next ;
 138
 139 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 140
 141 : add-tile ( tiling -- tiling )
 142   dup tiles>> 1 + >>tiles
 143   tiling-map-gadgets ;
 144
 145 : del-tile ( tiling -- tiling )
 146   dup tiles>> 1 - 1 max >>tiles
 147   tiling-map-gadgets ;
 148
 149 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 150
 151 M: tiling focusable-child* ( tiling -- child/t )
 152    [ focused>> ] [ gadgets>> ] bi nth ;
 153
 154 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 155
 156 TUPLE: tiling-shelf < tiling ;
 157 TUPLE: tiling-pile  < tiling ;
 158
 159 : <tiling-shelf> ( -- gadget )
 160   tiling-shelf new init-tiling { 1 0 } >>orientation ;
 161
 162 : <tiling-pile> ( -- gadget )
 163   tiling-pile new init-tiling { 0 1 } >>orientation ;
 164
 165 tiling-shelf
 166  H{
 167     { T{ key-down f { A+    } "LEFT"  } [ focus-prev  drop ] }
 168     { T{ key-down f { A+    } "RIGHT" } [ focus-next drop ] }
 169     { T{ key-down f { S+ A+ } "LEFT"  } [ move-prev   drop ] }
 170     { T{ key-down f { S+ A+ } "RIGHT" } [ move-next  drop ] }
 171     { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
 172     { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
 173   }
 174 set-gestures
 175
 176 tiling-pile
 177  H{
 178     { T{ key-down f { A+    } "UP"  } [ focus-prev  drop ] }
 179     { T{ key-down f { A+    } "DOWN" } [ focus-next drop ] }
 180     { T{ key-down f { S+ A+ } "UP"  } [ move-prev   drop ] }
 181     { T{ key-down f { S+ A+ } "DOWN" } [ move-next  drop ] }
 182     { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
 183     { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
 184   }
 185 set-gestures