extra/cursors/cursors.factor

   1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays generalizations kernel math sequences
   4 sequences.private fry ;
   5 IN: cursors
   6
   7 GENERIC: cursor-done? ( cursor -- ? )
   8 GENERIC: cursor-get-unsafe ( cursor -- obj )
   9 GENERIC: cursor-advance ( cursor -- )
  10 GENERIC: cursor-valid? ( cursor -- ? )
  11 GENERIC: cursor-write ( obj cursor -- )
  12
  13 ERROR: cursor-ended cursor ;
  14
  15 : cursor-get ( cursor -- obj )
  16     dup cursor-done?
  17     [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
  18
  19 : find-done? ( cursor quot -- ? )
  20     over cursor-done?
  21     [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
  22
  23 : cursor-until ( cursor quot -- )
  24     [ find-done? not ]
  25     [ drop cursor-advance ] bi-curry bi-curry while ; inline
  26
  27 : cursor-each ( cursor quot -- )
  28     [ f ] compose cursor-until ; inline
  29
  30 : cursor-find ( cursor quot -- obj ? )
  31     [ cursor-until ] [ drop ] 2bi
  32     dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
  33
  34 : cursor-any? ( cursor quot -- ? )
  35     cursor-find nip ; inline
  36
  37 : cursor-all? ( cursor quot -- ? )
  38     [ not ] compose cursor-any? not ; inline
  39
  40 : cursor-map-quot ( quot to -- quot' )
  41     [ [ call ] dip cursor-write ] 2curry ; inline
  42
  43 : cursor-map ( from to quot -- )
  44     swap cursor-map-quot cursor-each ; inline
  45
  46 : cursor-write-if ( obj quot to -- )
  47     [ over [ call ] dip ] dip
  48     [ cursor-write ] 2curry when ; inline
  49
  50 : cursor-filter-quot ( quot to -- quot' )
  51     [ cursor-write-if ] 2curry ; inline
  52
  53 : cursor-filter ( from to quot -- )
  54     swap cursor-filter-quot cursor-each ; inline
  55
  56 TUPLE: from-sequence { seq sequence } { n integer } ;
  57
  58 : >from-sequence< ( from-sequence -- n seq )
  59     [ n>> ] [ seq>> ] bi ; inline
  60
  61 M: from-sequence cursor-done? ( cursor -- ? )
  62     >from-sequence< length >= ;
  63
  64 M: from-sequence cursor-valid?
  65     >from-sequence< bounds-check? not ;
  66
  67 M: from-sequence cursor-get-unsafe
  68     >from-sequence< nth-unsafe ;
  69
  70 M: from-sequence cursor-advance
  71     [ 1 + ] change-n drop ;
  72
  73 : >input ( seq -- cursor )
  74     0 from-sequence boa ; inline
  75
  76 : iterate ( seq quot iterator -- )
  77     [ >input ] 2dip call ; inline
  78
  79 : each ( seq quot -- ) [ cursor-each ] iterate ; inline
  80 : find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
  81 : any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
  82 : all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
  83
  84 TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
  85
  86 M: to-sequence cursor-write
  87     seq>> push ;
  88
  89 : freeze ( cursor -- seq )
  90     [ seq>> ] [ exemplar>> ] bi like ; inline
  91
  92 : >output ( seq -- cursor )
  93     [ [ length ] keep new-resizable ] keep
  94     to-sequence boa ; inline
  95
  96 : transform ( seq quot transformer -- newseq )
  97     [ [ >input ] [ >output ] bi ] 2dip
  98     [ call ]
  99     [ 2drop freeze ] 3bi ; inline
 100
 101 : map ( seq quot -- ) [ cursor-map ] transform ; inline
 102 : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
 103
 104 : find-done2? ( cursor cursor quot -- ? )
 105     2over [ cursor-done? ] either?
 106     [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline
 107
 108 : cursor-until2 ( cursor cursor quot -- )
 109     [ find-done2? not ]
 110     [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline
 111
 112 : cursor-each2 ( cursor cursor quot -- )
 113     [ f ] compose cursor-until2 ; inline
 114
 115 : cursor-map2 ( from to quot -- )
 116     swap cursor-map-quot cursor-each2 ; inline
 117
 118 : iterate2 ( seq1 seq2 quot iterator -- )
 119     [ [ >input ] bi@ ] 2dip call ; inline
 120
 121 : transform2 ( seq1 seq2 quot transformer -- newseq )
 122     [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip
 123     [ call ]
 124     [ 2drop nip freeze ] 4 nbi ; inline
 125
 126 : 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline
 127 : 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
 128
 129 : find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
 130     [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
 131     [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
 132
 133 : cursor-until3 ( cursor cursor quot -- )
 134     [ find-done3? not ]
 135     [ drop [ cursor-advance ] tri@ ]
 136     bi-curry bi-curry bi-curry bi-curry while ; inline
 137
 138 : cursor-each3 ( cursor cursor quot -- )
 139     [ f ] compose cursor-until3 ; inline
 140
 141 : cursor-map3 ( from to quot -- )
 142     swap cursor-map-quot cursor-each3 ; inline
 143
 144 : iterate3 ( seq1 seq2 seq3 quot iterator -- )
 145     [ [ >input ] tri@ ] 2dip call ; inline
 146
 147 : transform3 ( seq1 seq2 seq3 quot transformer -- newseq )
 148     [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip
 149     [ call ]
 150     [ 2drop 2nip freeze ] 5 nbi ; inline
 151
 152 : 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline
 153 : 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline