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 kernel math sequences sequences.private ;
   4 IN: cursors
   5
   6 GENERIC: cursor-done? ( cursor -- ? )
   7 GENERIC: cursor-get-unsafe ( cursor -- obj )
   8 GENERIC: cursor-advance ( cursor -- )
   9 GENERIC: cursor-valid? ( cursor -- ? )
  10 GENERIC: cursor-write ( obj cursor -- )
  11
  12 ERROR: cursor-ended cursor ;
  13
  14 : cursor-get ( cursor -- obj )
  15    dup cursor-done?
  16    [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
  17
  18 : find-done? ( quot cursor -- ? )
  19    dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
  20
  21 : cursor-until ( quot cursor -- )
  22    [ find-done? not ]
  23    [ cursor-advance drop ] bi-curry bi-curry while ; inline
  24
  25 : cursor-each ( cursor quot -- )
  26    [ f ] compose swap cursor-until ; inline
  27
  28 : cursor-find ( cursor quot -- obj ? )
  29    swap [ cursor-until ] keep
  30    dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
  31
  32 : cursor-any? ( cursor quot -- ? )
  33    cursor-find nip ; inline
  34
  35 : cursor-all? ( cursor quot -- ? )
  36    [ not ] compose cursor-any? not ; inline
  37
  38 : cursor-map-quot ( quot to -- quot' )
  39    [ [ call ] dip cursor-write ] 2curry ; inline
  40
  41 : cursor-map ( from to quot -- )
  42    swap cursor-map-quot cursor-each ; inline
  43
  44 : cursor-write-if ( obj quot to -- )
  45     [ over [ call ] dip ] dip
  46     [ cursor-write ] 2curry when ; inline
  47
  48 : cursor-filter-quot ( quot to -- quot' )
  49    [ cursor-write-if ] 2curry ; inline
  50
  51 : cursor-filter ( from to quot -- )
  52    swap cursor-filter-quot cursor-each ; inline
  53
  54 TUPLE: from-sequence { seq sequence } { n integer } ;
  55
  56 : >from-sequence< ( from-sequence -- n seq )
  57     [ n>> ] [ seq>> ] bi ; inline
  58
  59 M: from-sequence cursor-done? ( cursor -- ? )
  60     >from-sequence< length >= ;
  61
  62 M: from-sequence cursor-valid?
  63    >from-sequence< bounds-check? not ;
  64
  65 M: from-sequence cursor-get-unsafe
  66    >from-sequence< nth-unsafe ;
  67
  68 M: from-sequence cursor-advance
  69    [ 1+ ] change-n drop ;
  70
  71 : >input ( seq -- cursor )
  72    0 from-sequence boa ; inline
  73
  74 : iterate ( seq quot iterator -- )
  75    [ >input ] 2dip call ; inline
  76
  77 : each ( seq quot -- ) [ cursor-each ] iterate ; inline
  78 : find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
  79 : any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
  80 : all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
  81
  82 TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
  83
  84 M: to-sequence cursor-write
  85    seq>> push ;
  86
  87 : freeze ( cursor -- seq )
  88    [ seq>> ] [ exemplar>> ] bi like ; inline
  89
  90 : >output ( seq -- cursor )
  91    [ [ length ] keep new-resizable ] keep
  92    to-sequence boa ; inline
  93
  94 : transform ( seq quot transformer -- newseq )
  95    [ [ >input ] [ >output ] bi ] 2dip
  96    [ call ] [ 2drop freeze ] 3bi ; inline
  97
  98 : map ( seq quot -- ) [ cursor-map ] transform ; inline
  99 : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline