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