basis/compiler/utilities/utilities.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs fry hashtables kernel locals math
   4 math.order namespaces sequences vectors ;
   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 : pad-tail-shorter ( seq1 seq2 elt -- seq1' seq2' )
  26     2over longer length swap [ pad-tail ] 2curry bi@ ;
  27
  28 SYMBOL: yield-hook
  29
  30 yield-hook [ [ ] ] initialize
  31
  32 : alist-most ( alist quot -- pair )
  33     [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
  34
  35 : alist-min ( alist -- pair ) [ before=? ] alist-most ;
  36
  37 : alist-max ( alist -- pair ) [ after=? ] alist-most ;
  38
  39 : penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
  40
  41 :: compress-path ( source assoc -- destination )
  42     source assoc at :> destination
  43     source destination = [ source ] [
  44         destination assoc compress-path :> destination'
  45         destination' destination = [
  46             destination' source assoc set-at
  47         ] unless
  48         destination'
  49     ] if ;
  50
  51 : unique ( seq -- assoc )
  52     [ dup ] H{ } map>assoc ;
  53
  54 : conjoin ( elt assoc -- )
  55     dupd set-at ;
  56
  57 : conjoin-at ( value key assoc -- )
  58     [ dupd ?set-at ] change-at ;