1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays generic hashtables kernel kernel.private math
4 namespaces sequences words quotations layouts combinators
5 sequences.private classes classes.builtin classes.algebra
6 definitions math.order math.private assocs ;
9 PREDICATE: math-class < class
10 dup null bootstrap-word eq? [
13 number bootstrap-word class<=
18 : last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
20 : bootstrap-words ( classes -- classes' )
21 [ bootstrap-word ] map ;
23 : math-precedence ( class -- pair )
25 { fixnum integer rational real number object } bootstrap-words
26 swap [ swap class<= ] curry find drop -1 or
28 { fixnum bignum ratio float complex object } bootstrap-words
29 swap [ class<= ] curry find drop -1 or
32 : (math-upgrade) ( max class -- quot )
33 dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
37 : math-class-max ( class1 class2 -- class )
38 [ [ math-precedence ] bi@ after? ] most ;
40 : math-upgrade ( class1 class2 -- quot )
41 [ math-class-max ] 2keep
44 dup empty? [ [ dip ] curry [ ] like ] unless
48 ERROR: no-math-method left right generic ;
50 : default-math-method ( generic -- quot )
51 [ no-math-method ] curry [ ] like ;
55 : applicable-method ( generic class -- quot )
58 [ default-math-method ] ?if ;
62 : object-method ( generic -- quot )
63 object bootstrap-word applicable-method ;
65 : math-method ( word class1 class2 -- quot )
67 [ 2array [ declare ] curry nip ]
69 [ math-class-max over order min-class applicable-method ]
79 : make-math-method-table ( classes quot: ( class -- quot ) -- alist )
80 [ bootstrap-words ] dip
81 [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
83 : math-alist>quot ( alist -- quot )
84 [ generic-word get object-method ] dip alist>quot ;
86 : tag-dispatch-entry ( tag picker -- quot )
87 [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ;
89 : tag-dispatch ( picker alist -- alist' )
90 swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
92 : tuple-dispatch-entry ( class picker -- quot )
93 [ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ;
95 : tuple-dispatch ( picker alist -- alist' )
96 swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
98 : math-dispatch-step ( picker quot: ( class -- quot ) -- quot )
99 [ [ { bignum float fixnum } ] dip make-math-method-table ]
100 [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
101 tuple swap 2array prefix tag-dispatch ; inline
105 SINGLETON: math-combination
107 M: math-combination make-default-method
108 drop default-math-method ;
110 M: math-combination perform-combination
111 drop dup generic-word [
113 [ fixnum bootstrap-word dup math-method ]
117 [ dup ] [ math-method ] with with math-dispatch-step
121 ] with math-dispatch-step
123 [ if ] 2curry [ 2dup both-fixnums? ] prepend
127 PREDICATE: math-generic < generic ( word -- ? )
128 "combination" word-prop math-combination? ;
130 M: math-generic definer drop \ MATH: f ;