extra/newfx/newfx.factor

   1
   2 USING: kernel sequences assocs qualified circular sets fry sequences.lib ;
   3
   4 USING: math multi-methods ;
   5
   6 QUALIFIED: sequences
   7 QUALIFIED: assocs
   8 QUALIFIED: circular
   9 QUALIFIED: sets
  10
  11 IN: newfx
  12
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14 ! Now, we can see a new world coming into view.
  15 ! A world in which there is the very real prospect of a new world order.
  16 !
  17 !    - George Herbert Walker Bush
  18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  19
  20 GENERIC: at ( col key -- val )
  21 GENERIC: of ( key col -- val )
  22
  23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  24
  25 GENERIC: grab ( col key -- col val )
  26
  27 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  28
  29 GENERIC: is ( col key val -- col )
  30 GENERIC: as ( col val key -- col )
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 GENERIC: is-of ( key val col -- col )
  35 GENERIC: as-of ( val key col -- col )
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 GENERIC: mutate-at ( col key val -- )
  40 GENERIC: mutate-as ( col val key -- )
  41
  42 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  43
  44 GENERIC: at-mutate ( key val col -- )
  45 GENERIC: as-mutate ( val key col -- )
  46
  47 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  48 ! sequence
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50
  51 METHOD: at { sequence number  } swap nth ;
  52 METHOD: of { number  sequence }      nth ;
  53
  54 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  55
  56 METHOD: grab { sequence number } dupd swap nth ;
  57
  58 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  59
  60 METHOD: is { sequence number object  } swap pick set-nth ;
  61 METHOD: as { sequence object  number }      pick set-nth ;
  62
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 METHOD: is-of { number object  sequence } dup >r swapd set-nth r> ;
  66 METHOD: as-of { object  number sequence } dup >r       set-nth r> ;
  67
  68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  69
  70 METHOD: mutate-at { sequence number object  } swap rot set-nth ;
  71 METHOD: mutate-as { sequence object  number }      rot set-nth ;
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74
  75 METHOD: at-mutate { number object  sequence } swapd set-nth ;
  76 METHOD: as-mutate { object  number sequence }       set-nth ;
  77
  78 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  79 ! assoc
  80 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  81
  82 METHOD: at { assoc object } swap assocs:at ;
  83 METHOD: of { object assoc }      assocs:at ;
  84
  85 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  86
  87 METHOD: grab { assoc object } dupd swap assocs:at ;
  88
  89 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  90
  91 METHOD: is { assoc object object } swap pick set-at ;
  92 METHOD: as { assoc object object }      pick set-at ;
  93
  94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  95
  96 METHOD: is-of { object object assoc } dup >r swapd set-at r> ;
  97 METHOD: as-of { object object assoc } dup >r       set-at r> ;
  98
  99 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 100
 101 METHOD: mutate-at { assoc object object } swap rot set-at ;
 102 METHOD: mutate-as { assoc object object }      rot set-at ;
 103
 104 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 105
 106 METHOD: at-mutate { object object assoc } swapd set-at ;
 107 METHOD: as-mutate { object object assoc }       set-at ;
 108
 109 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 110
 111 : push      ( seq obj -- seq ) over sequences:push ;
 112 : push-on   ( obj seq -- seq ) tuck sequences:push ;
 113 : pushed    ( seq obj --     ) swap sequences:push ;
 114 : pushed-on ( obj seq --     )      sequences:push ;
 115
 116 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 117
 118 : member?    ( seq obj -- ? ) swap sequences:member? ;
 119 : member-of? ( obj seq -- ? )      sequences:member? ;
 120
 121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 122
 123 : delete-at-key ( tbl key -- tbl ) over delete-at ;
 124 : delete-key-of ( key tbl -- tbl ) tuck delete-at ;
 125
 126 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 127
 128 : delete      ( seq elt -- seq ) over sequences:delete ;
 129 : delete-from ( elt seq -- seq ) tuck sequences:delete ;
 130
 131 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 132
 133 : deleted      ( seq elt -- ) swap sequences:delete ;
 134 : deleted-from ( elt seq -- )      sequences:delete ;
 135
 136 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 137
 138 : remove      ( seq obj -- seq ) swap sequences:remove ;
 139 : remove-from ( obj seq -- seq )      sequences:remove ;
 140
 141 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 142
 143 : filter-of ( quot seq -- seq ) swap filter ;
 144
 145 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 146
 147 : map-over ( quot seq -- seq ) swap map ;
 148
 149 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 150
 151 : push-circular ( seq elt -- seq ) over circular:push-circular ;
 152
 153 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 154
 155 : prefix-on ( elt seq -- seq ) swap prefix ;
 156 : suffix-on ( elt seq -- seq ) swap suffix ;
 157
 158 : suffix!      ( seq elt -- seq ) over sequences:push ;
 159 : suffix-on!   ( elt seq -- seq ) tuck sequences:push ;
 160 : suffixed!    ( seq elt --     ) swap sequences:push ;
 161 : suffixed-on! ( elt seq --     )      sequences:push ;
 162
 163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 164
 165 : subseq ( seq from to -- subseq ) rot sequences:subseq ;
 166
 167 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 168
 169 : key ( table val -- key ) swap assocs:value-at ;
 170
 171 : key-of ( val table -- key ) assocs:value-at ;
 172
 173 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 174
 175 : index    ( seq obj -- i ) swap sequences:index ;
 176 : index-of ( obj seq -- i )      sequences:index ;
 177
 178 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 179
 180 : 1st ( seq -- obj ) 0 swap nth ;
 181 : 2nd ( seq -- obj ) 1 swap nth ;
 182 : 3rd ( seq -- obj ) 2 swap nth ;
 183 : 4th ( seq -- obj ) 3 swap nth ;
 184 : 5th ( seq -- obj ) 4 swap nth ;
 185 : 6th ( seq -- obj ) 5 swap nth ;
 186 : 7th ( seq -- obj ) 6 swap nth ;
 187 : 8th ( seq -- obj ) 7 swap nth ;
 188 : 9th ( seq -- obj ) 8 swap nth ;
 189
 190 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 191
 192 ! A note about the 'mutate' qualifier. Other words also technically mutate
 193 ! their primary object. However, the 'mutate' qualifier is supposed to
 194 ! indicate that this is the main objective of the word, as a side effect.
 195
 196 : adjoin      ( seq elt -- seq ) over sets:adjoin ;
 197 : adjoin-on   ( elt seq -- seq ) tuck sets:adjoin ;
 198 : adjoined    ( set elt --     ) swap sets:adjoin ;
 199 : adjoined-on ( elt set --     )      sets:adjoin ;
 200
 201 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 202
 203 : start ( seq subseq -- i ) swap sequences:start ;
 204
 205 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 206
 207 : pluck         ( seq i   -- seq ) cut-slice rest-slice append ;
 208 : pluck-from    ( i   seq -- seq ) swap pluck ;
 209 : pluck!        ( seq i   -- seq ) over delete-nth ;
 210 : pluck-from!   ( i   seq -- seq ) tuck delete-nth ;
 211 : plucked!      ( seq i   --     ) swap delete-nth ;
 212 : plucked-from! ( i   seq --     )      delete-nth ;
 213
 214 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 215
 216 : snip          ( seq a b -- seq ) >r over r> [ head ] [ tail ] 2bi* append ;
 217 : snip-this     ( a b seq -- seq ) -rot snip ;
 218 : snip!         ( seq a b -- seq )      pick delete-slice ;
 219 : snip-this!    ( a b seq -- seq ) -rot pick delete-slice ;
 220 : snipped!      ( seq a b --     )       rot delete-slice ;
 221 : snipped-from! ( a b seq --     )           delete-slice ;
 222
 223 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 224
 225 : invert-index ( seq i -- seq i ) >r dup length 1 - r> - ;
 226
 227 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 228
 229 : append!      ( a b -- ab )      over sequences:push-all ;
 230 : append-to!   ( b a -- ab ) swap over sequences:push-all ;
 231 : appended!    ( a b --    ) swap      sequences:push-all ;
 232 : appended-to! ( b a --    )           sequences:push-all ;
 233
 234 : prepend!   ( a b -- ba  ) over append 0 pick copy ;
 235 : prepended! ( a b --     ) over append 0 rot  copy ;
 236
 237 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 238
 239 : insert ( seq i obj -- seq ) >r cut r> prefix append ;
 240
 241 : splice ( seq i seq -- seq ) >r cut r> prepend append ;
 242
 243 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 244
 245 : purge ( seq quot -- seq ) [ not ] compose filter ;
 246
 247 : purge! ( seq quot -- seq )
 248   dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ;