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