core/generic/math/math.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generic hashtables kernel kernel.private math
   4 namespaces make sequences words quotations layouts combinators
   5 sequences.private classes classes.builtin classes.algebra
   6 definitions math.order ;
   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 : last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
  17
  18 : math-precedence ( class -- pair )
  19     {
  20         { [ dup null class<= ] [ drop { -1 -1 } ] }
  21         { [ dup math-class? ] [ class-types last/first ] }
  22         [ drop { 100 100 } ]
  23     } cond ;
  24
  25 : math-class<=> ( class1 class2 -- class )
  26     [ math-precedence ] compare +gt+ eq? ;
  27
  28 : math-class-max ( class1 class2 -- class )
  29     [ math-class<=> ] most ;
  30
  31 : math-class-min ( class1 class2 -- class )
  32     [ swap math-class<=> ] most ;
  33
  34 : (math-upgrade) ( max class -- quot )
  35     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
  36
  37 : math-upgrade ( class1 class2 -- quot )
  38     [ math-class-max ] 2keep
  39     >r over r> (math-upgrade) >r (math-upgrade)
  40     dup empty? [ [ dip ] curry [ ] like ] unless
  41     r> append ;
  42
  43 ERROR: no-math-method left right generic ;
  44
  45 : default-math-method ( generic -- quot )
  46     [ no-math-method ] curry [ ] like ;
  47
  48 : applicable-method ( generic class -- quot )
  49     over method
  50     [ 1quotation ]
  51     [ default-math-method ] ?if ;
  52
  53 : object-method ( generic -- quot )
  54     object bootstrap-word applicable-method ;
  55
  56 : math-method ( word class1 class2 -- quot )
  57     2dup and [
  58         2dup math-upgrade >r
  59         math-class-max over order min-class applicable-method
  60         r> prepend
  61     ] [
  62         2drop object-method
  63     ] if ;
  64
  65 : math-vtable ( picker quot -- quot )
  66     [
  67         >r
  68         , \ tag ,
  69         num-tags get [ bootstrap-type>class ]
  70         r> compose map ,
  71         \ dispatch ,
  72     ] [ ] make ; inline
  73
  74 TUPLE: math-combination ;
  75
  76 M: math-combination make-default-method
  77     drop default-math-method ;
  78
  79 M: math-combination perform-combination
  80     drop
  81     dup
  82     \ over [
  83         dup math-class? [
  84             \ dup [ >r 2dup r> math-method ] math-vtable
  85         ] [
  86             over object-method
  87         ] if nip
  88     ] math-vtable nip
  89     define ;
  90
  91 PREDICATE: math-generic < generic ( word -- ? )
  92     "combination" word-prop math-combination? ;
  93
  94 M: math-generic definer drop \ MATH: f ;