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 MACRO: output>sequence-n ( quot exemplar n -- quot )
  71     3dup nip [ outputs ] dip - -rot
  72     '[ @ [ _ _ nsequence ] _ ndip ] ;
  73
  74 MACRO: output>array-n ( quot n -- array )
  75     '[ _ { } _ output>sequence-n ] ;
  76
  77 : cleave>array ( obj quots -- array )
  78     '[ _ cleave ] output>array ; inline
  79
  80 : cleave>sequence ( x seq exemplar -- array )
  81     [ '[ _ cleave ] ] dip output>sequence ; inline
  82
  83 : input<sequence ( seq quot -- )
  84     [ inputs firstn ] [ call ] bi ; inline
  85
  86 : input<sequence-unsafe ( seq quot -- )
  87     [ inputs firstn-unsafe ] [ call ] bi ; inline
  88
  89 : reduce-outputs ( quot operation -- )
  90     [ [ call ] [ [ drop ] compose outputs ] bi ] dip swap call-n ; inline
  91
  92 : sum-outputs ( quot -- n )
  93     [ + ] reduce-outputs ; inline
  94
  95 : map-outputs ( quot mapper -- )
  96     [ drop call ] [ swap outputs ] 2bi napply ; inline
  97
  98 MACRO: map-reduce-outputs ( quot mapper reducer -- quot )
  99     [ '[ _ _ map-outputs ] ] dip '[ _ _ reduce-outputs ] ;
 100
 101 : append-outputs-as ( quot exemplar -- seq )
 102     [ [ call ] [ outputs ] bi ] dip nappend-as ; inline
 103
 104 : append-outputs ( quot -- seq )
 105     { } append-outputs-as ; inline
 106
 107 : preserving ( quot -- )
 108     [ inputs ndup ] [ call ] bi ; inline
 109
 110 : dropping ( quot -- quot' )
 111     inputs '[ _ ndrop ] ; inline
 112
 113 : nullary ( quot -- )
 114     dropping call ; inline
 115
 116 : smart-if ( pred true false -- )
 117     [ preserving ] 2dip if ; inline
 118
 119 : smart-when ( pred true -- )
 120     [ ] smart-if ; inline
 121
 122 : smart-unless ( pred false -- )
 123     [ [ ] ] dip smart-if ; inline
 124
 125 : smart-if* ( pred true false -- )
 126     [ [ [ preserving ] [ dropping ] bi ] dip swap ] dip compose if ; inline
 127
 128 : smart-when* ( pred true -- )
 129     [ ] smart-if* ; inline
 130
 131 : smart-unless* ( pred false -- )
 132     [ [ ] ] dip smart-if* ; inline
 133
 134 : smart-apply ( quot n -- )
 135     [ dup inputs ] dip mnapply ; inline
 136
 137 : smart-with ( param obj quot -- obj curry )
 138     swapd dup inputs '[ [ _ -nrot ] dip call ] 2curry ; inline
 139
 140 MACRO: smart-reduce ( reduce-quots -- quot )
 141     unzip [ [ ] like ] bi@ dup length dup '[
 142         [ @ ] dip [ @ _ cleave-curry _ spread* ] each
 143     ] ;
 144
 145 MACRO: smart-map-reduce ( map-reduce-quots -- quot )
 146     [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
 147         [ first _ cleave ] keep
 148         [ @ _ cleave-curry _ spread* ]
 149         [ 1 ] 2dip setup-each (each-integer)
 150     ] ;
 151
 152 MACRO: smart-2reduce ( 2reduce-quots -- quot )
 153     unzip [ [ ] like ] bi@ dup length dup '[
 154         [ @ ] 2dip
 155         [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ] 2each
 156     ] ;
 157
 158 MACRO: smart-2map-reduce ( 2map-reduce-quots -- quot )
 159     [ keys ] [ [ [ ] concat-as ] [ ] map-as ] bi dup length dup '[
 160         [ [ first ] bi@ _ 2cleave ] 2keep
 161         [ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ]
 162         [ 1 ] 3dip (2each) (each-integer)
 163     ] ;