basis/compiler/utilities/utilities.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences sequences.private arrays vectors fry
   4 math math.order namespaces assocs locals ;
   5 IN: compiler.utilities
   6
   7 : flattener ( seq quot -- seq vector quot' )
   8     over length <vector> [
   9         dup
  10         '[
  11             @ [
  12                 dup [ array? ] [ vector? ] bi or
  13                 [ _ push-all ] [ _ push ] if
  14             ] when*
  15         ]
  16     ] keep ; inline
  17
  18 : flattening ( seq quot combinator -- seq' )
  19     [ flattener ] dip dip { } like ; inline
  20
  21 : map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
  22
  23 : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
  24
  25 SYMBOL: yield-hook
  26
  27 yield-hook [ [ ] ] initialize
  28
  29 : alist-most ( alist quot -- pair )
  30     [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
  31
  32 : alist-min ( alist -- pair ) [ before? ] alist-most ;
  33
  34 : alist-max ( alist -- pair ) [ after? ] alist-most ;
  35
  36 : penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
  37
  38 :: compress-path ( source assoc -- destination )
  39     [let | destination [ source assoc at ] |
  40         source destination = [ source ] [
  41             [let | destination' [ destination assoc compress-path ] |
  42                 destination' destination = [
  43                     destination' source assoc set-at
  44                 ] unless
  45                 destination'
  46             ]
  47         ] if
  48     ] ;