extra/ui/gadgets/tiling/tiling.factor

   1
   2 USING: kernel sequences math math.order
   3        ui.gadgets ui.gadgets.tracks ui.gestures
   4        fry accessors ;
   5
   6 IN: ui.gadgets.tiling
   7
   8 TUPLE: tiling < track gadgets tiles first focused ;
   9
  10 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  11
  12 : init-tiling ( tiling -- tiling )
  13   init-track
  14   { 1 0 }    >>orientation
  15   V{ } clone >>gadgets
  16   2          >>tiles
  17   0          >>first
  18   0          >>focused ;
  19
  20 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  21
  22 : <tiling> ( -- gadget ) tiling new init-tiling ;
  23
  24 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  25
  26 : bounded-subseq ( seq a b -- seq )
  27   [ 0 max ] dip
  28   pick length [ min ] curry bi@
  29   rot
  30   subseq ;
  31
  32 : tiling-gadgets-to-map ( tiling -- gadgets )
  33   [ gadgets>> ]
  34   [ first>> ]
  35   [ [ first>> ] [ tiles>> ] bi + ]
  36   tri
  37   bounded-subseq ;
  38
  39 : tiling-map-gadgets ( tiling -- tiling )
  40   dup clear-track
  41   dup tiling-gadgets-to-map [ 1 track-add ] each ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : tiling-add ( tiling gadget -- tiling )
  46   over gadgets>> push
  47   tiling-map-gadgets ;
  48
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50
  51 : first-gadget ( tiling -- index ) drop 0 ;
  52
  53 : last-gadget ( tiling -- index ) gadgets>> length 1 - ;
  54
  55 : first-viewable ( tiling -- index ) first>> ;
  56
  57 : last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
  58
  59 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  60
  61 : make-focused-mapped ( tiling -- tiling )
  62
  63   dup [ focused>> ] [ first>> ] bi <
  64     [ dup first>> 1 - >>first ]
  65     [ ]
  66   if
  67
  68   dup [ last-viewable ] [ focused>> ] bi <
  69     [ dup first>> 1 + >>first ]
  70     [ ]
  71   if ;
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74
  75 : check-focused-bounds ( tiling -- tiling )
  76   dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
  77
  78 : focus-prev ( tiling -- tiling )
  79   dup focused>> 1 - >>focused
  80   check-focused-bounds
  81   make-focused-mapped
  82   tiling-map-gadgets
  83   dup request-focus ;
  84
  85 : focus-next ( tiling -- tiling )
  86   dup focused>> 1 + >>focused
  87   check-focused-bounds
  88   make-focused-mapped
  89   tiling-map-gadgets
  90   dup request-focus ;
  91
  92 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  93
  94 : exchanged! ( seq a b -- )
  95                    [ 0 max ] bi@
  96   pick length 1 - '[ , min ] bi@
  97   rot exchange ;
  98
  99 : move-prev ( tiling -- tiling )
 100   dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
 101   focus-prev ;
 102
 103 : move-next ( tiling -- tiling )
 104   dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
 105   focus-next ;
 106
 107 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 108
 109 : add-tile ( tiling -- tiling )
 110   dup tiles>> 1 + >>tiles
 111   tiling-map-gadgets ;
 112
 113 : del-tile ( tiling -- tiling )
 114   dup tiles>> 1 - 1 max >>tiles
 115   tiling-map-gadgets ;
 116
 117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 118
 119 M: tiling focusable-child* ( tiling -- child/t )
 120    [ focused>> ] [ gadgets>> ] bi nth ;
 121
 122 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 123
 124 TUPLE: tiling-shelf < tiling ;
 125 TUPLE: tiling-pile  < tiling ;
 126
 127 : <tiling-shelf> ( -- gadget )
 128   tiling-shelf new init-tiling { 1 0 } >>orientation ;
 129
 130 : <tiling-pile> ( -- gadget )
 131   tiling-pile new init-tiling { 0 1 } >>orientation ;
 132
 133 tiling-shelf
 134  H{
 135     { T{ key-down f { A+    } "LEFT"  } [ focus-prev  drop ] }
 136     { T{ key-down f { A+    } "RIGHT" } [ focus-next drop ] }
 137     { T{ key-down f { S+ A+ } "LEFT"  } [ move-prev   drop ] }
 138     { T{ key-down f { S+ A+ } "RIGHT" } [ move-next  drop ] }
 139     { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
 140     { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
 141   }
 142 set-gestures
 143
 144 tiling-pile
 145  H{
 146     { T{ key-down f { A+    } "UP"  } [ focus-prev  drop ] }
 147     { T{ key-down f { A+    } "DOWN" } [ focus-next drop ] }
 148     { T{ key-down f { S+ A+ } "UP"  } [ move-prev   drop ] }
 149     { T{ key-down f { S+ A+ } "DOWN" } [ move-next  drop ] }
 150     { T{ key-down f { C+    } "["     } [ del-tile  drop ] }
 151     { T{ key-down f { C+    } "]"     } [ add-tile  drop ] }
 152   }
 153 set-gestures