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 math.private ;
   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 SYMBOL: picker
  66
  67 : math-vtable ( picker quot -- quot )
  68     [
  69         swap picker set
  70         picker get , [ tag 0 eq? ] %
  71         num-tags get swap [ bootstrap-type>class ] prepose map
  72         unclip ,
  73         [
  74             picker get , [ tag 1 fixnum-fast ] % , \ dispatch ,
  75         ] [ ] make , \ if ,
  76     ] [ ] make ; inline
  77
  78 TUPLE: math-combination ;
  79
  80 M: math-combination make-default-method
  81     drop default-math-method ;
  82
  83 M: math-combination perform-combination
  84     drop
  85     dup
  86     \ over [
  87         dup math-class? [
  88             \ dup [ >r 2dup r> math-method ] math-vtable
  89         ] [
  90             over object-method
  91         ] if nip
  92     ] math-vtable nip define ;
  93
  94 PREDICATE: math-generic < generic ( word -- ? )
  95     "combination" word-prop math-combination? ;
  96
  97 M: math-generic definer drop \ MATH: f ;