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-upgrade) ( max class -- quot )
  32     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
  33
  34 : math-upgrade ( class1 class2 -- quot )
  35     [ math-class-max ] 2keep
  36     [
  37         (math-upgrade)
  38         dup empty? [ [ dip ] curry [ ] like ] unless
  39     ] [ (math-upgrade) ]
  40     bi-curry* bi append ;
  41
  42 ERROR: no-math-method left right generic ;
  43
  44 : default-math-method ( generic -- quot )
  45     [ no-math-method ] curry [ ] like ;
  46
  47 : applicable-method ( generic class -- quot )
  48     over method
  49     [ 1quotation ]
  50     [ default-math-method ] ?if ;
  51
  52 : object-method ( generic -- quot )
  53     object bootstrap-word applicable-method ;
  54
  55 : math-method ( word class1 class2 -- quot )
  56     2dup and [
  57         [
  58             2dup 2array , \ declare ,
  59             2dup math-upgrade %
  60             math-class-max over order min-class applicable-method %
  61         ] [ ] make
  62     ] [
  63         2drop object-method
  64     ] if ;
  65
  66 SYMBOL: picker
  67
  68 : math-vtable ( picker quot -- quot )
  69     [
  70         [ , \ tag , ]
  71         [ num-tags get swap [ bootstrap-type>class ] prepose map , ] bi*
  72         \ dispatch ,
  73     ] [ ] make ; inline
  74
  75 TUPLE: math-combination ;
  76
  77 M: math-combination make-default-method
  78     drop default-math-method ;
  79
  80 M: math-combination perform-combination
  81     drop
  82     dup
  83     [
  84         [ 2dup both-fixnums? ] %
  85         dup fixnum bootstrap-word dup math-method ,
  86         \ over [
  87             dup math-class? [
  88                 \ dup [ [ 2dup ] dip math-method ] math-vtable
  89             ] [
  90                 over object-method
  91             ] if nip
  92         ] math-vtable nip ,
  93         \ if ,
  94     ] [ ] make define ;
  95
  96 PREDICATE: math-generic < generic ( word -- ? )
  97     "combination" word-prop math-combination? ;
  98
  99 M: math-generic definer drop \ MATH: f ;