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