unmaintained/enchilada/engine/engine.factor

   1 ! Copyright (C) 2007 Robbert van Dalen.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 IN: enchilada.engine
   5 USING: generic kernel math sequences isequences.interface isequences.base isequences.ops ;
   6
   7 ! Provides Enchilada's rewriting expression engine.
   8 !
   9
  10 GENERIC: !! ( list -- list )
  11 GENERIC: \\ ( list -- list )
  12
  13 GENERIC: e-reducible? ( e -- ? )
  14 GENERIC: e-dyadic? ( o -- ? )
  15 GENERIC: e-operator? ( o -- ? )
  16 GENERIC: e-list? ( o -- ? )
  17 GENERIC: e-symbol? ( o -- ? )
  18
  19 GENERIC: e-m-operate ( v op -- e )
  20 GENERIC: e-d-operate ( v1 v2 op -- e )
  21
  22 GENERIC: e-reduce ( e -- e )
  23 GENERIC: free-symbols ( s -- symbols )
  24
  25 TUPLE: ireplace from to seq ;
  26
  27 : unpack-ireplace ( ireplace -- from to seq )
  28     dup ireplace-from swap dup ireplace-to swap ireplace-seq ; inline
  29
  30 GENERIC: e-replace ( from to sequence -- s )
  31
  32 : (ireplace1) ( from to seq -- ireplace )
  33     dup is-atom?
  34     [ pick over i-cmp 0 = [ drop nip ] [ nip nip ] if ]
  35     [ <ireplace> ] if ;
  36
  37 : <i-replace> ( from to seq -- ireplace )
  38    dup i-length dup 0 =
  39    [ 3drop drop 0 ]
  40    [ 1 = [ (ireplace1) ] [ <ireplace> ] if ]
  41    if ;
  42
  43 : ireplace-i-at ( s i -- v )
  44    swap dup ireplace-seq rot i-at dup >r swap dup ireplace-from rot i-cmp 0 =
  45    [ r> drop ireplace-to ]
  46    [ dup ireplace-from swap ireplace-to r> e-replace ]
  47    if ;
  48
  49 M: object e-replace <i-replace> ;
  50 M: integer e-replace -rot 2drop ;
  51
  52 M: ireplace i-length ireplace-seq i-length ;
  53 M: ireplace i-at ireplace-i-at ;
  54 M: ireplace ileft unpack-ireplace ileft e-replace ;
  55 M: ireplace iright unpack-ireplace iright e-replace ;
  56 M: ireplace ihead (ihead) ;
  57 M: ireplace itail (itail) ;
  58 M: ireplace $$ unpack-ireplace [ $$ ] 2apply rot $$ quick-hash quick-hash ;
  59
  60 TUPLE: esymbol seq ;
  61
  62 GENERIC: esymbol/i-cmp ( esymbol s -- i )
  63
  64 M: object esymbol/i-cmp 2drop -1 ;
  65 M: esymbol esymbol/i-cmp swap [ esymbol-seq ] 2apply i-cmp ;
  66 M: esymbol object/i-cmp 2drop 1 ;
  67 M: esymbol i-cmp swap esymbol/i-cmp ;
  68
  69 DEFER: (sunion)
  70
  71 : (sunion6) ( s1 s2 -- s )
  72     2dup [ 0 i-at ] 2apply i-cmp dup zero?
  73     [ 2drop ] [ 0 > [ swap ] when ++ ] if ; inline
  74
  75 : (sunion5) ( s1 s2 -- s )
  76     over ileft i-length pick swap i-at icut rot left-right
  77     swap roll (sunion) -rot swap (sunion) ++ ; inline
  78
  79 : (sunion4) ( s1 s2 -- s )
  80    2dup ifirst swap ilast i-cmp dup zero?
  81    [ drop 1 itail ++ ] [ 0 > [ ++ ] [ (sunion5) ] if ] if ; inline
  82
  83 : (sunion3) ( s1 s2 ls1 ls2 -- s )
  84     1 =
  85     [ 1 = [ (sunion6) ] [ (sunion4) ] if ]
  86     [ 1 = [ swap ] when (sunion4) ] if ; inline
  87
  88 : (sunion2) ( s1 s2 -- s )
  89     2dup [ i-length ] 2apply 2dup zero?
  90     [ 3drop drop ] [ zero? [ 2drop nip ] [ (sunion3) ] if ] if ; inline
  91
  92 : (sunion) ( s1 s2 -- s )
  93     2dup eq? [ drop ] [ (sunion2) ] if ; inline
  94
  95 : s-union ( s1 s2 -- s )
  96     (sunion) ; inline
  97
  98 : (free-symbols) ( s -- symbols )
  99     dup is-atom?
 100     [ dup e-symbol? [ drop 0 ] unless ]
 101     [ 0 i-at free-symbols ] if ;
 102
 103 M: object free-symbols
 104     dup i-length dup 0 =
 105     [ 2drop 0 ]
 106     [ 1 = [ (free-symbols) ] [ left-right [ free-symbols ] 2apply s-union ] if ] if ;
 107
 108 M: integer free-symbols drop 0 ;
 109
 110 M: object !!
 111     dup i-length dup 0 =
 112     [ 2drop 0 ]
 113     [ 1 = [ 0 i-at dup left-side swap right-side [ e-reduce ] 2apply <i-dual-sided> <i> ] [ left-right [ !! ] 2apply ++ ] if ] if ;
 114
 115 M: integer !! ;
 116
 117
 118 : (\\) ( expr -- list )
 119    dup i-length dup 0 =
 120    [ 2drop 0 ]
 121    [ 1 = [ <i> ] [ left-right [ (\\) ] 2apply ++ ] if ] if ;
 122
 123 M: object \\
 124     dup i-length dup 0 =
 125     [ 2drop 0 ]
 126     [ 1 = [ 0 i-at left-side (\\) ] [ left-right [ \\ ] 2apply ++ ] if ] if ;
 127 M: integer \\ ;
 128
 129 TUPLE: emacro symbols expr eager? ;
 130
 131 : symbol-list? ( symbols -- ? )
 132     i-sort dup free-symbols i-cmp 0 = ; inline
 133
 134 : full-reduce ( expr -- expr )
 135         dup e-reducible? [ e-reduce full-reduce ] when ;
 136
 137 : <e-macro> ( symbols expr eager? -- e-macro )
 138     dup [ swap full-reduce swap ] when
 139     >r swap dup symbol-list? [ swap r> <emacro> ] [ "illegal symbol list" throw ] if ;
 140
 141 M: emacro free-symbols dup emacro-expr free-symbols swap emacro-symbols i-diff ;
 142
 143 M: emacro e-replace
 144     pick over [ free-symbols ] 2apply i-intersect i-length 0 =
 145     [ -rot 2drop ]
 146     [ dup >r emacro-expr e-replace r> dup emacro-symbols swap emacro-eager? rot swap <e-macro> ] if ;
 147
 148 : eflatten ( s -- s )
 149     dup i-length dup zero?
 150     [ 2drop 0 ]
 151     [ 1 = [ 0 i-at left-side ] [ left-right [ eflatten ] 2apply ++ ] if ] if ; inline
 152
 153 TUPLE: c-op v d-op ;
 154
 155 M: object e-operator? drop f ;
 156 M: object e-list? dup e-operator? not swap e-symbol? not and ;
 157 M: object e-symbol? drop f ;
 158 M: object e-dyadic? drop f ;
 159
 160 M: esymbol e-symbol? drop t ;
 161
 162 M: c-op e-m-operate
 163     dup c-op-v swap c-op-d-op e-d-operate ;
 164
 165 TUPLE: .- ;
 166 M: .- e-m-operate drop -- <i> ;
 167 TUPLE: .` ;
 168 M: .` e-m-operate drop `` <i> ;
 169 TUPLE: .$ ;
 170 M: .$ e-m-operate drop $$ <i> ;
 171 TUPLE: .~ ;
 172 M: .~ e-m-operate drop ~~ <i> ;
 173 TUPLE: .: ;
 174 M: .: e-m-operate drop :: <i> ;
 175 TUPLE: .# ;
 176 M: .# e-m-operate drop ## <i> ;
 177 TUPLE: .^ ;
 178 M: .^ e-m-operate drop eflatten ;
 179 TUPLE: .! ;
 180 M: .! e-m-operate drop !! <i> ;
 181 TUPLE: .\ ;
 182 M: .\ e-m-operate drop \\ <i> ;
 183
 184 TUPLE: .+ ;
 185 M: .+ e-d-operate drop ++ <i> ;
 186 TUPLE: .* ;
 187 M: .* e-d-operate drop ** [ <i> ] 2apply ++ ;
 188 TUPLE: ./ ;
 189 M: ./ e-d-operate drop // [ <i> ] 2apply ++ ;
 190 TUPLE: .& ;
 191 M: .& e-d-operate drop && <i> ;
 192 TUPLE: .| ;
 193 M: .| e-d-operate drop || <i> ;
 194 TUPLE: .< ;
 195 M: .< e-d-operate drop << [ <i> ] 2apply ++ ;
 196 TUPLE: .> ;
 197 M: .> e-d-operate drop >> <i> ;
 198 TUPLE: .@ ;
 199 M: .@ e-d-operate >r swap 0 i-cmp 0 = [ dup eflatten swap <i> ++ r> ++ ] [ r> 2drop 0 ] if ;
 200 TUPLE: .? ;
 201 M: .? e-d-operate drop (i-eq?) [ 1 ] [ 0 ] if <i> ;
 202 TUPLE: .% ;
 203 M: .% e-d-operate drop %% [ <i> ] 2apply ++ ;
 204
 205 UNION: monadic-class c-op .- .` .$ .~ .: .# .^ .! .\ emacro ;
 206 UNION: dyadic-class .+ .* ./ .& .| .< .> .@ .? .% ;
 207 UNION: operator-class monadic-class dyadic-class ;
 208
 209 M: operator-class e-operator? drop t ;
 210 M: monadic-class e-dyadic? drop f ;
 211 M: dyadic-class e-dyadic? drop t ;
 212
 213 DEFER: +e+
 214
 215 : (e-reducible?) ( e -- ? )
 216     left-right 2dup [ e-reducible? ] either?
 217     [ 2drop t ] [ ifirst e-operator? swap ilast e-list? and ] if ; inline
 218
 219 M: object e-reducible?
 220     dup i-length 1 <= [ drop f ] [ (e-reducible?) ] if ;
 221
 222 : (e-reduce2) ( e1 e2 -- e )
 223     2dup ifirst swap ilast swap e-m-operate
 224     -rot 1 itail swap dup i-length 1- ihead rot ++ swap ++ ; inline
 225
 226 : (e-reduce) ( e -- e )
 227     left-right swap dup e-reducible? [ (e-reduce) swap ++ ]
 228     [ swap dup e-reducible? [ (e-reduce) ++ ] [ (e-reduce2) ] if ] if ; inline
 229
 230 M: object e-reduce
 231     dup e-reducible? [ (e-reduce) ] when ;
 232
 233 : (+e+2) ( e1 e2 -- e )
 234     2dup ifirst swap ilast swap <c-op>
 235     -rot 1 itail swap dup i-length 1- ihead rot ++ swap ++ ; inline
 236
 237 : (+e+1) ( e1 e2 -- e )
 238     2dup ifirst e-dyadic? swap ilast e-list? and
 239     [ (+e+2) ] [ ++g ] if ; inline
 240
 241 TUPLE: e-exp expr reducible ;
 242
 243 M: e-exp e-reducible? e-exp-reducible ;
 244
 245 : <expr> ( s -- e-exp )
 246     dup e-exp? [ dup e-reducible? <e-exp> ] unless ; inline
 247
 248 : +e+ ( e1 e2 -- e )
 249     2dup [ i-length 1 >= ] both?
 250     [ (+e+1) ] [ ++g ] if <expr> ; inline
 251
 252 : e-ipair ( e1 e2 -- e )
 253     <isequence> <expr> ; inline
 254
 255 M: c-op e-replace dup >r c-op-v e-replace r> c-op-d-op <c-op> ;
 256
 257
 258 GENERIC: e-exp/++ ( s e -- e )
 259 GENERIC: e-exp/ipair ( s e -- e )
 260
 261 M: e-exp ++ swap e-exp/++ ;
 262 M: e-exp ipair swap e-exp/ipair ;
 263
 264 M: object e-exp/++ swap +e+ ;
 265 M: object e-exp/ipair swap e-ipair ;
 266
 267 M: e-exp e-exp/++ swap +e+ ;
 268 M: e-exp e-exp/ipair swap e-ipair ;
 269 M: e-exp object/++ swap +e+ ;
 270 M: e-exp object/ipair swap e-ipair ;
 271
 272 M: operator-class ++ +e+ ;
 273
 274 M: e-exp i-length e-exp-expr i-length ;
 275 M: e-exp i-at swap e-exp-expr swap i-at ;
 276 M: e-exp ileft e-exp-expr ileft ;
 277 M: e-exp iright e-exp-expr iright ;
 278 M: e-exp ihead swap e-exp-expr swap ihead ;
 279 M: e-exp itail swap e-exp-expr swap itail ;
 280 M: e-exp $$ e-exp-expr $$ ;
 281
 282 M: e-exp e-replace
 283     dup i-length 1 =
 284     [ e-exp-expr e-replace ]
 285     [ 3dup iright e-replace >r ileft e-replace r> ++ ] if ;
 286
 287 TUPLE: ereplacement from to ;
 288
 289 : (ereplace) ( symbols from-symbol --  to-symbol )
 290    esymbol-seq dup ++ <esymbol> dup pick i-intersect i-length zero?
 291    [ nip ] [ (ereplace) ] if ; inline
 292
 293 : (replacements3) ( symbols from-symbol --  newsymbols replacement )
 294     2dup (ereplace) rot over i-union -rot <ereplacement> ; inline
 295
 296 : (replacements2) ( symbols intersect -- replacements )
 297    dup i-length zero?
 298    [ 2drop 0 ]
 299    [ dup >r ifirst (replacements3) swap r> 1 itail (replacements2) ++ ] if ;
 300
 301 : replace-s ( s replacements -- s )
 302     dup i-length dup zero?
 303     [ 2drop ]
 304     [ 1 = [ 0 i-at dup ereplacement-from swap ereplacement-to rot e-replace ] [ left-right >r replace-s r> replace-s ] if ] if ;
 305
 306 : (replacements) ( value macro -- replacements )
 307     dup emacro-expr free-symbols swap emacro-symbols -1 ++
 308     i-intersect tuck swap free-symbols i-intersect (replacements2) ; inline
 309
 310 : (replace-macro) ( replacements macro -- macro )
 311     2dup dup >r emacro-symbols swap replace-s swap emacro-expr rot replace-s r> emacro-eager? <e-macro> ;
 312
 313 : (eval-macro) ( value macro -- macro )
 314     dup >r emacro-symbols dup -1 ++ swap ilast rot <i> r> dup >r emacro-expr e-replace r> emacro-eager? <e-macro> ;
 315
 316 : eval-macro ( value macro -- s )
 317     2dup (replacements) swap (replace-macro) (eval-macro) ;
 318
 319 : emacro-e-m-operate ( value macro -- s )
 320         eval-macro dup emacro-symbols i-length zero? [ emacro-expr ] when ;
 321
 322 M: emacro e-m-operate emacro-e-m-operate ;