extra/lists/lists.factor

   1 ! Copyright (C) 2008 Chris Double & James Cash
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences accessors math ;
   4
   5 IN: lists
   6
   7 ! List Protocol
   8 MIXIN: list
   9 GENERIC: car   ( cons -- car )
  10 GENERIC: cdr   ( cons -- cdr )
  11 GENERIC: nil?  ( cons -- ? )
  12
  13 TUPLE: cons car cdr ;
  14
  15 C: cons cons
  16
  17 M: cons car ( cons -- car )
  18     car>> ;
  19
  20 M: cons cdr ( cons -- cdr )
  21     cdr>> ;
  22
  23 : nil ( -- cons )
  24   T{ cons f f f } ;
  25
  26 M: cons nil? ( cons -- bool )
  27     nil eq? ;
  28
  29 : 1list ( obj -- cons )
  30     nil cons ;
  31
  32 : 2list ( a b -- cons )
  33     nil cons cons ;
  34
  35 : 3list ( a b c -- cons )
  36     nil cons cons cons ;
  37
  38 : 2car ( cons -- car caar )
  39     [ car ] [ cdr car ] bi ;
  40
  41 : 3car ( cons -- car caar caaar )
  42     [ car ] [ cdr car ] [ cdr cdr car ] tri ;
  43
  44 : uncons ( cons -- cdr car )
  45     [ cdr ] [ car ] bi ;
  46
  47 : lnth ( n list -- elt )
  48     swap [ cdr ] times car ;
  49
  50 : (llength) ( list acc -- n )
  51     over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
  52
  53 : llength ( list -- n )
  54     0 (llength) ;
  55
  56 : leach ( list quot -- )
  57     over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline
  58
  59 : lreduce ( list identity quot -- result )
  60     swapd leach ; inline
  61
  62 : seq>cons ( seq -- cons )
  63     <reversed> nil [ f cons swap >>cdr ] reduce ;
  64
  65 : (lmap) ( acc cons quot -- seq )
  66     over nil? [ 2drop ]
  67     [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; inline
  68
  69 : lmap ( cons quot -- seq )
  70     [ { } clone ] 2dip (map-cons) ; inline
  71
  72 : cons>seq ( cons -- array )
  73     [ ] map-cons ;
  74
  75 INSTANCE: cons list