basis/combinators/smart/smart.factor

   1 ! Copyright (C) 2009, 2011 Doug Coleman, John Benediktsson.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators effects fry
   4 generalizations kernel macros math math.order memoize sequences
   5 sequences.generalizations sequences.private stack-checker
   6 stack-checker.backend stack-checker.errors stack-checker.values
   7 stack-checker.visitor words ;
   8 IN: combinators.smart
   9
  10 GENERIC: infer-known* ( known -- effect )
  11
  12 : infer-known ( value -- effect )
  13     known dup (literal-value?) [
  14         (literal) [ infer-literal-quot ] with-infer drop
  15     ] [ infer-known* ] if ;
  16
  17 IDENTITY-MEMO: inputs/outputs ( quot -- in out )
  18     infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
  19
  20 : inputs ( quot -- n ) inputs/outputs drop ; inline
  21
  22 : outputs ( quot -- n ) inputs/outputs nip ; inline
  23
  24 \ inputs/outputs [
  25     peek-d
  26     infer-known [
  27         [ pop-d 1array #drop, ]
  28         [ [ in>> ] [ out>> ] bi [ length apply-object ] bi@ ] bi*
  29     ] [
  30         \ inputs/outputs dup required-stack-effect apply-word/effect
  31         pop-d pop-d swap
  32         [ [ input-parameter swap set-known ] [ push-d ] bi ] bi@
  33     ] if*
  34 ] "special" set-word-prop
  35
  36 M: curried infer-known*
  37     quot>> infer-known dup [
  38         curry-effect
  39     ] [
  40         drop f
  41     ] if ;
  42
  43 M: composed infer-known*
  44     [ quot1>> ] [ quot2>> ] bi
  45     [ infer-known ] bi@
  46     2dup and [ compose-effects ] [ 2drop f ] if ;
  47
  48 M: declared-effect infer-known*
  49     known>> infer-known* ;
  50
  51 M: input-parameter infer-known* drop f ;
  52
  53 M: object infer-known* drop f ;
  54
  55 : drop-inputs ( quot -- )
  56     inputs ndrop ; inline
  57
  58 : drop-outputs ( quot -- )
  59     [ call ] [ outputs ndrop ] bi ; inline
  60
  61 : keep-inputs ( quot -- )
  62     [ ] [ inputs ] bi nkeep ; inline
  63
  64 : output>sequence ( quot exemplar -- seq )
  65     [ [ call ] [ outputs ] bi ] dip nsequence ; inline
  66
  67 : output>array ( quot -- array )
  68     { } output>sequence ; inline
  69
  70 : cleave>array ( obj quots -- array )
  71     '[ _ cleave ] output>array ; inline
  72
  73 : cleave>sequence ( x seq exemplar -- array )
  74     [ '[ _ cleave ] ] dip output>sequence ; inline
  75
  76 : input<sequence ( seq quot -- )
  77     [ inputs firstn ] [ call ] bi ; inline
  78
  79 : input<sequence-unsafe ( seq quot -- )
  80     [ inputs firstn-unsafe ] [ call ] bi ; inline
  81
  82 : reduce-outputs ( quot operation -- )
  83     [ [ call ] [ [ drop ] compose outputs ] bi ] dip swap call-n ; inline
  84
  85 : sum-outputs ( quot -- n )
  86     [ + ] reduce-outputs ; inline
  87
  88 : map-outputs ( quot mapper -- )
  89     [ drop call ] [ swap outputs ] 2bi napply ; inline
  90
  91 MACRO: map-reduce-outputs ( quot mapper reducer -- quot )
  92     [ '[ _ _ map-outputs ] ] dip '[ _ _ reduce-outputs ] ;
  93
  94 : append-outputs-as ( quot exemplar -- seq )
  95     [ [ call ] [ outputs ] bi ] dip nappend-as ; inline
  96
  97 : append-outputs ( quot -- seq )
  98     { } append-outputs-as ; inline
  99
 100 : preserving ( quot -- )
 101     [ inputs ndup ] [ call ] bi ; inline
 102
 103 : dropping ( quot -- quot' )
 104     inputs '[ _ ndrop ] ; inline
 105
 106 : nullary ( quot -- )
 107     dropping call ; inline
 108
 109 : smart-if ( pred true false -- )
 110     [ preserving ] 2dip if ; inline
 111
 112 : smart-when ( pred true -- )
 113     [ ] smart-if ; inline
 114
 115 : smart-unless ( pred false -- )
 116     [ [ ] ] dip smart-if ; inline
 117
 118 : smart-if* ( pred true false -- )
 119     [ [ [ preserving ] [ dropping ] bi ] dip swap ] dip compose if ; inline
 120
 121 : smart-when* ( pred true -- )
 122     [ ] smart-if* ; inline
 123
 124 : smart-unless* ( pred false -- )
 125     [ [ ] ] dip smart-if* ; inline
 126
 127 : smart-apply ( quot n -- )
 128     [ dup inputs ] dip mnapply ; inline
 129
 130 : smart-with ( param obj quot -- obj curry )
 131     swapd dup inputs '[ [ _ -nrot ] dip call ] 2curry ; inline
 132
 133 MACRO: smart-reduce ( reduce-quots -- quot )
 134     unzip [ [ ] like ] bi@ dup length dup '[
 135         [ @ ] dip [ @ _ cleave-curry _ spread* ] each
 136     ] ;
 137
 138 MACRO: smart-map-reduce ( map-reduce-quots -- quot )
 139     [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
 140         [ first _ cleave ] keep
 141         [ @ _ cleave-curry _ spread* ]
 142         [ 1 ] 2dip (each) (each-integer)
 143     ] ;
 144
 145 MACRO: smart-2reduce ( 2reduce-quots -- quot )
 146     unzip [ [ ] like ] bi@ dup length dup '[
 147         [ @ ] 2dip
 148         [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ] 2each
 149     ] ;
 150
 151 MACRO: smart-2map-reduce ( 2map-reduce-quots -- quot )
 152     [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
 153         [ [ first ] bi@ _ 2cleave ] 2keep
 154         [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ]
 155         [ 1 ] 3dip (2each) (each-integer)
 156     ] ;