extra/sequences/modified/modified.factor

   1 ! Copyright (C) 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel math sequences sequences.private shuffle ;
   4 IN: sequences.modified
   5
   6 TUPLE: modified ;
   7
   8 GENERIC: modified-nth ( n seq -- elt )
   9 M: modified nth modified-nth ;
  10 M: modified nth-unsafe modified-nth ;
  11
  12 GENERIC: modified-set-nth ( elt n seq -- )
  13 M: modified set-nth modified-set-nth ;
  14 M: modified set-nth-unsafe modified-set-nth ;
  15
  16 INSTANCE: modified virtual-sequence
  17
  18 TUPLE: 1modified < modified seq ;
  19
  20 M: modified length seq>> length ;
  21 M: modified set-length seq>> set-length ;
  22
  23 M: 1modified virtual-seq seq>> ;
  24
  25 TUPLE: scaled < 1modified c ;
  26 C: <scaled> scaled
  27
  28 : scale ( seq c -- new-seq )
  29     dupd <scaled> swap like ;
  30
  31 M: scaled modified-nth ( n seq -- elt )
  32     [ seq>> nth ] [ c>> * ] bi ;
  33
  34 M: scaled modified-set-nth ( elt n seq -- elt )
  35     ! don't set c to 0!
  36     tuck [ c>> / ] 2dip seq>> set-nth ;
  37
  38 TUPLE: offset < 1modified n ;
  39 C: <offset> offset
  40
  41 : seq-offset ( seq n -- new-seq )
  42     dupd <offset> swap like ;
  43
  44 M: offset modified-nth ( n seq -- elt )
  45     [ seq>> nth ] [ n>> + ] bi ;
  46
  47 M: offset modified-set-nth ( elt n seq -- )
  48     tuck [ n>> - ] 2dip seq>> set-nth ;
  49
  50 TUPLE: summed < modified seqs ;
  51 C: <summed> summed
  52
  53 M: summed length seqs>> [ length ] map supremum ;
  54
  55 <PRIVATE
  56 : ?+ ( x/f y/f -- sum )
  57     #! addition that treats f as 0
  58     [
  59         swap [ + ] when*
  60     ] [
  61         [ ] [ 0 ] if*
  62     ] if* ;
  63 PRIVATE>
  64
  65 M: summed modified-nth ( n seq -- )
  66     seqs>> [ ?nth ?+ ] with 0 swap reduce ;
  67
  68 M: summed modified-set-nth ( elt n seq -- ) immutable ;
  69
  70 M: summed set-length ( n seq -- )
  71     seqs>> [ set-length ] with each ;
  72
  73 M: summed virtual-seq ( summed -- seq ) [ ] { } map-as ;
  74
  75 : <2summed> ( seq seq -- summed-seq ) 2array <summed> ;
  76 : <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ;