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