basis/combinators/smart/smart.factor

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