core/generic/math/math.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs classes classes.algebra combinators
   4 definitions generic kernel kernel.private math math.order
   5 math.private namespaces quotations sequences words ;
   6 IN: generic.math
   7
   8 PREDICATE: math-class < class
   9     dup null bootstrap-word eq? [
  10         drop f
  11     ] [
  12         number bootstrap-word class<=
  13     ] if ;
  14
  15 <PRIVATE
  16
  17 : bootstrap-words ( classes -- classes' )
  18     [ bootstrap-word ] map ;
  19
  20 : math-precedence ( class -- pair )
  21     [
  22         { fixnum integer rational real number object } bootstrap-words
  23         swap [ swap class<= ] curry find drop -1 or
  24     ] [
  25         { fixnum bignum ratio float complex object } bootstrap-words
  26         swap [ class<= ] curry find drop -1 or
  27     ] bi 2array ;
  28
  29 : (math-upgrade) ( max class -- quot )
  30     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
  31
  32 PRIVATE>
  33
  34 : math-class-max ( class1 class2 -- class )
  35     [ [ math-precedence ] bi@ after? ] most ;
  36
  37 : math-upgrade ( class1 class2 -- quot )
  38     [ math-class-max ] 2keep
  39     [
  40         (math-upgrade)
  41         dup empty? [ [ dip ] curry [ ] like ] unless
  42     ] [ (math-upgrade) ]
  43     bi-curry* bi append ;
  44
  45 ERROR: no-math-method left right generic ;
  46
  47 : default-math-method ( generic -- quot )
  48     [ no-math-method ] curry [ ] like ;
  49
  50 <PRIVATE
  51
  52 : (math-method) ( generic class -- quot )
  53     over ?lookup-method
  54     [ 1quotation ]
  55     [ default-math-method ] ?if ;
  56
  57 PRIVATE>
  58
  59 : object-method ( generic -- quot )
  60     object bootstrap-word (math-method) ;
  61
  62 : math-method ( word class1 class2 -- quot )
  63     2dup and [
  64         [ 2array [ declare ] curry nip ]
  65         [ math-upgrade nip ]
  66         [ math-class-max over nearest-class (math-method) ]
  67         3tri 3append
  68     ] [
  69         2drop object-method
  70     ] if ;
  71
  72 <PRIVATE
  73
  74 SYMBOL: generic-word
  75
  76 : make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist )
  77     [ bootstrap-words ] dip
  78     [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
  79
  80 : math-alist>quot ( alist -- quot )
  81     [ generic-word get object-method ] dip alist>quot ;
  82
  83 : tag-dispatch-entry ( tag picker -- quot )
  84     [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ;
  85
  86 : tag-dispatch ( picker alist -- alist' )
  87     swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
  88
  89 : tuple-dispatch-entry ( class picker -- quot )
  90     [ 1quotation [ { tuple } declare class-of ] [ eq? ] surround ] dip prepend ;
  91
  92 : tuple-dispatch ( picker alist -- alist' )
  93     swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
  94
  95 : math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot )
  96     [ [ { bignum float fixnum } ] dip make-math-method-table ]
  97     [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
  98     tuple swap 2array prefix tag-dispatch ; inline
  99
 100 : fixnum-optimization ( word quot -- word quot' )
 101     [ dup fixnum bootstrap-word dup math-method ]
 102     [
 103         ! remove redundant fixnum check since we know
 104         ! both can't be fixnums in this branch
 105         dup length 3 - cut unclip
 106         [ length 2 - ] [ nth ] bi prefix append
 107     ] bi*
 108     [ if ] 2curry [ 2dup both-fixnums? ] prepend ;
 109
 110 PRIVATE>
 111
 112 SINGLETON: math-combination
 113
 114 M: math-combination make-default-method
 115     drop default-math-method ;
 116
 117 M: math-combination perform-combination
 118     drop dup generic-word [
 119         dup [ over ] [
 120             dup math-class? [
 121                 [ dup ] [ math-method ] 2with math-dispatch-step
 122             ] [
 123                 drop object-method
 124             ] if
 125         ] with math-dispatch-step
 126         fixnum-optimization
 127         define
 128     ] with-variable ;
 129
 130 PREDICATE: math-generic < generic
 131     "combination" word-prop math-combination? ;
 132
 133 M: math-generic definer drop \ MATH: f ;