+ oop:\r
\r
- union metaclass\r
-- add defined methods to a word prop\r
-- M: sort method list, build vtable, redefine generic\r
- 2generic\r
- move generic, 2generic from kernel vocabulary\r
- generic = hashcode and math ops\r
-- no vtable word-prop\r
- make see work with generics\r
- doc comments of generics\r
-- GENERIC: don't install empty vtable if already defined\r
\r
+ ffi:\r
\r
"/library/generic/object.factor"\r
"/library/generic/builtin.factor"\r
"/library/generic/predicate.factor"\r
+ "/library/generic/union.factor"\r
"/library/generic/traits.factor"\r
\r
"/version.factor"\r
"/library/logic.factor"\r
"/library/cons.factor"\r
"/library/assoc.factor"\r
- "/library/math/generic.factor"\r
+ "/library/math/math.factor"\r
+ "/library/math/integer.factor"\r
+ "/library/math/ratio.factor"\r
+ "/library/math/float.factor"\r
+ "/library/math/complex.factor"\r
"/library/words.factor"\r
- "/library/math/arithmetic.factor"\r
"/library/math/math-combinators.factor"\r
- "/library/math/math.factor"\r
"/library/lists.factor"\r
"/library/vectors.factor"\r
"/library/strings.factor"\r
"/library/logic.factor" run-resource
"/library/cons.factor" run-resource
"/library/assoc.factor" run-resource
-"/library/math/generic.factor" run-resource
+"/library/math/math.factor" run-resource
+"/library/math/integer.factor" run-resource
+"/library/math/ratio.factor" run-resource
+"/library/math/float.factor" run-resource
+"/library/math/complex.factor" run-resource
"/library/words.factor" run-resource
-"/library/math/arithmetic.factor" run-resource
"/library/math/math-combinators.factor" run-resource
-"/library/math/math.factor" run-resource
"/library/lists.factor" run-resource
"/library/vectors.factor" run-resource
"/library/strings.factor" run-resource
"/library/generic/object.factor" run-resource
"/library/generic/builtin.factor" run-resource
"/library/generic/predicate.factor" run-resource
+"/library/generic/union.factor" run-resource
"/library/generic/traits.factor" run-resource
! init.factor leaves a boot quotation on the stack
( Words )
-: make-plist ( word -- plist )
- [
- dup word-name "name" swons ,
- dup word-vocabulary "vocabulary" swons ,
- parsing? [ t "parsing" swons , ] when
- ] make-list ;
-
: word, ( word -- )
[
word-tag >header ,
0 ,
dup word-primitive ,
dup word-parameter ' ,
- dup make-plist ' ,
+ dup word-plist ' ,
0 ,
0 ,
] make-list
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
-: builtin-method ( type generic definition -- )
- -rot "vtable" word-property add-method ;
-
-builtin [ builtin-method ] "define-method" set-word-property
-
builtin [
"builtin-type" word-property unit
] "builtin-supertypes" set-word-property
+builtin [
+ ( vtable definition class -- )
+ rot set-vtable
+] "add-method" set-word-property
+
+builtin 50 "priority" set-word-property
+
: builtin-predicate ( type# symbol -- word )
predicate-word [
swap [ swap type eq? ] cons define-compound
USE: strings
USE: words
USE: vectors
+USE: math
+USE: math-internals
! A simple single-dispatch generic word system.
! The class of an object with traits is determined by the object
! identity of the traits method map.
! - metaclass: a metaclass is a symbol with a handful of word
-! properties: "define-method" "builtin-types"
+! properties: "define-method" "builtin-types" "priority"
+
+! Metaclasses have priority -- this induces an order in which
+! methods are added to the vtable.
: undefined-method
"No applicable method." throw ;
#! A list of builtin supertypes of the class.
dup metaclass "builtin-supertypes" word-property call ;
-: add-method ( definition type vtable -- )
+: set-vtable ( definition class vtable -- )
>r "builtin-type" word-property r> set-vector-nth ;
-: define-generic ( word vtable -- )
- 2dup "vtable" set-word-property
- [ generic ] cons define-compound ;
+: <empty-vtable> ( -- vtable )
+ num-types [ drop [ undefined-method ] ] vector-project ;
+
+: class-ord ( class -- n ) metaclass "priority" word-property ;
+
+: class< ( cls1 cls2 -- ? )
+ swap car class-ord swap car class-ord < ;
-: <vtable> ( default -- vtable )
- num-types [ drop dup ] vector-project nip ;
+: sort-methods ( methods -- alist )
+ hash>alist [ class< ] sort ;
+
+: add-method ( vtable definition class -- )
+ #! Add the method entry to the vtable. Unlike define-method,
+ #! this is called at vtable build time, and in the sorted
+ #! order.
+ dup metaclass "add-method" word-property
+ [ [ undefined-method ] ] unless* call ;
+
+: <vtable> ( methods -- vtable )
+ <empty-vtable> swap sort-methods [
+ dupd unswons add-method
+ ] each ;
DEFER: add-traits-dispatch
+: define-generic ( word vtable -- )
+ over "combination" word-property cons define-compound ;
+
+: (define-method) ( definition class generic -- )
+ [ "methods" word-property [ set-hash ] keep <vtable> ] keep
+ swap define-generic ;
+
! Defining generic words
+: (GENERIC) ( combination -- )
+ #! Takes a combination parameter. A combination is a
+ #! quotation that takes some objects and a vtable from the
+ #! stack, and calls the appropriate row of the vtable.
+ CREATE 2dup "combination" word-property = [
+ 2drop
+ ] [
+ [ swap "combination" set-word-property ] keep
+ dup <namespace> "methods" set-word-property
+ <empty-vtable> [ add-traits-dispatch ] 2keep
+ define-generic
+ ] ifte ;
+
+: single-combination ( obj vtable -- )
+ >r dup type r> dispatch ; inline
+
: GENERIC:
- #! GENERIC: bar creates a generic word bar that calls the
- #! bar method on the traits object, with the traits object
- #! on the stack.
- CREATE [ undefined-method ] <vtable>
- 2dup add-traits-dispatch
- define-generic ; parsing
+ #! GENERIC: bar creates a generic word bar. Add methods to
+ #! the generic word using M:.
+ [ single-combination ] (GENERIC) ; parsing
+
+: arithmetic-combination ( n n vtable -- )
+ #! Note that the numbers remain on the stack, possibly after
+ #! being coerced to a maximal type.
+ >r arithmetic-type r> dispatch ; inline
+
+: 2GENERIC:
+ #! 2GENERIC: bar creates a generic word bar. Add methods to
+ #! the generic word using M:. 2GENERIC words dispatch on
+ #! arithmetic types and should not be used for non-numerical
+ #! types.
+ [ arithmetic-combination ] (GENERIC) ; parsing
: define-method ( class -- quotation )
#! In a vain attempt at something resembling a "meta object
#! protocol", we call the "define-method" word property with
#! stack ( class generic definition -- ).
metaclass "define-method" word-property
- [ [ undefined-method ] ] unless* ;
+ [ [ -rot (define-method) ] ] unless* ;
: M: ( -- class generic [ ] )
#! M: foo bar begins a definition of the bar generic word
USE: strings
USE: words
USE: vectors
+USE: math
! Catch-all metaclass for providing a default method.
SYMBOL: object
-: define-object ( generic definition -- )
- <vtable> define-generic drop ;
-
object object "metaclass" set-word-property
-object [
- define-object
-] "define-method" set-word-property
-
object [
drop num-types count
] "builtin-supertypes" set-word-property
+
+object [
+ ( vtable definition class -- )
+ drop over vector-length [
+ pick pick -rot set-vector-nth
+ ] times* 2drop
+] "add-method" set-word-property
+
+object 100 "priority" set-word-property
! Predicate metaclass for generalized predicate dispatch.
SYMBOL: predicate
-: predicate-dispatch ( class definition existing -- dispatch )
+: predicate-dispatch ( existing definition class -- dispatch )
[
- \ dup ,
- rot "predicate" word-property ,
- swap , , \ ifte ,
+ \ dup , "predicate" word-property , , , \ ifte ,
] make-list ;
-: (predicate-method) ( class generic definition type# -- )
- rot "vtable" word-property
- [ vector-nth predicate-dispatch ] 2keep
- set-vector-nth ;
-
-: predicate-method ( class generic definition -- )
- pick builtin-supertypes [
- >r 3dup r> (predicate-method)
- ] each 3drop ;
-
-predicate [
- predicate-method
-] "define-method" set-word-property
+: (predicate-method) ( vtable definition class type# -- )
+ >r rot r> swap [
+ vector-nth
+ ( vtable definition class existing )
+ -rot predicate-dispatch
+ ] 2keep set-vector-nth ;
predicate [
"superclass" word-property builtin-supertypes
] "builtin-supertypes" set-word-property
+predicate [
+ ( vtable definition class -- )
+ dup builtin-supertypes [
+ ( vtable definition class type# )
+ >r 3dup r> (predicate-method)
+ ] each 3drop
+] "add-method" set-word-property
+
+predicate 25 "priority" set-word-property
+
: define-predicate ( class predicate definition -- )
rot "superclass" word-property "predicate" word-property
[ \ dup , , , [ drop f ] , \ ifte , ] make-list
#! definitions.
"traits-map" word-property ;
-: traits-method ( class generic definition -- )
- swap rot traits-map set-hash ;
-
-traits [ traits-method ] "define-method" set-word-property
+traits [
+ ( class generic quotation )
+
+ swap rot traits-map set-hash
+] "define-method" set-word-property
traits [
\ vector "builtin-type" word-property unique,
] "builtin-supertypes" set-word-property
+traits 10 "priority" set-word-property
+
! Hashtable slot holding an optional delegate. Any undefined
! methods are called on the delegate. The object can also
! manually pass any methods on to the delegate.
: add-traits-dispatch ( word vtable -- )
>r unit [ car swap traits-dispatch call ] cons \ vector r>
- add-method ;
+ set-vtable ;
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: generic
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: namespaces
+USE: parser
+USE: strings
+USE: words
+USE: vectors
+
+! Union metaclass for dispatch on multiple classes.
+SYMBOL: union
+
+union [
+ [ ] swap "members" word-property [
+ builtin-supertypes append
+ ] each
+] "builtin-supertypes" set-word-property
+
+union [
+ ( vtable definition class -- )
+ "members" word-property [ >r 2dup r> add-method ] each 2drop
+] "add-method" set-word-property
+
+union 30 "priority" set-word-property
+
+: union-predicate ( definition -- list )
+ [
+ [
+ \ dup ,
+ unswons "predicate" word-property ,
+ [ drop t ] ,
+ union-predicate ,
+ \ ifte ,
+ ] make-list
+ ] [
+ [ drop f ]
+ ] ifte* ;
+
+: define-union ( class predicate definition -- )
+ [ union-predicate define-compound ] keep
+ "members" set-word-property ;
+
+: UNION: ( -- class predicate definition )
+ #! Followed by a class name, then a list of union members.
+ CREATE
+ dup union "metaclass" set-word-property
+ dup predicate-word
+ [ dupd "predicate" set-word-property ] keep
+ [ define-union ] [ ] ; parsing
-! :folding=none:collapseFolds=1:
+! :folding=indent:collapseFolds=1:
! $Id$
!
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: syntax
-USE: generic
-BUILTIN: f 6 FORGET: f?
-BUILTIN: t 7 FORGET: t?
-
-IN: vectors
-DEFER: vector=
-DEFER: vector-hashcode
-
-IN: lists
-DEFER: cons=
-DEFER: cons-hashcode
-
-IN: math
-DEFER: >rect
-DEFER: bitxor
-
IN: kernel
+USE: generic
USE: lists
USE: math
USE: math-internals
#! Returns one of "unix" or "win32".
11 getenv ;
-! The 'fake vtable' used here speeds things up a lot.
-! It is quite clumsy, however. A higher-level CLOS-style
-! 'generic words' system will be built later.
-
: dispatch ( n vtable -- )
vector-nth call ;
-: generic ( obj vtable -- )
- >r dup type r> dispatch ; inline
-
: 2generic ( n n vtable -- )
>r arithmetic-type r> dispatch ; inline
-: hashcode ( obj -- hash )
- #! If two objects are =, they must have equal hashcodes.
- {
- [ ] ! 0
- [ word-hashcode ] ! 1
- [ cons-hashcode ] ! 2
- [ drop 0 ] ! 3
- [ >fixnum ] ! 4
- [ >rect >fixnum swap >fixnum bitxor ] ! 5
- [ drop 0 ] ! 6
- [ drop 0 ] ! 7
- [ drop 0 ] ! 8
- [ >fixnum ] ! 9
- [ >fixnum ] ! 10
- [ vector-hashcode ] ! 11
- [ str-hashcode ] ! 12
- [ sbuf-hashcode ] ! 13
- [ drop 0 ] ! 14
- [ drop 0 ] ! 15
- [ drop 0 ] ! 16
- } generic ;
+GENERIC: hashcode
+M: object hashcode drop 0 ;
-IN: math DEFER: number= ( defined later... )
-IN: kernel
-: = ( obj obj -- ? )
- #! Push t if a is isomorphic to b.
- {
- [ number= ] ! 0
- [ eq? ] ! 1
- [ cons= ] ! 2
- [ eq? ] ! 3
- [ number= ] ! 4
- [ number= ] ! 5
- [ eq? ] ! 6
- [ eq? ] ! 7
- [ eq? ] ! 8
- [ number= ] ! 9
- [ number= ] ! 10
- [ vector= ] ! 11
- [ str= ] ! 12
- [ sbuf= ] ! 13
- [ eq? ] ! 14
- [ eq? ] ! 15
- [ eq? ] ! 16
- } generic ;
+GENERIC: =
+M: object = eq? ;
: set-boot ( quot -- )
#! Set the boot quotation.
: num-types ( -- n )
#! One more than the maximum value from type primitive.
17 ;
+
+IN: syntax
+BUILTIN: f 6 FORGET: f?
+BUILTIN: t 7 FORGET: t?
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: lists
+USE: generic
USE: kernel
USE: math
-USE: vectors
: 2list ( a b -- [ a b ] )
unit cons ;
#! partial order with stack effect ( o1 o2 -- ? ).
swap [ pick >r maximize r> swap ] (top) nip ; inline
-: cons= ( obj cons -- ? )
+M: cons = ( obj cons -- ? )
2dup eq? [
2drop t
] [
] ifte
] ifte ;
-: (cons-hashcode) ( cons count -- hash )
+: cons-hashcode ( cons count -- hash )
dup 0 = [
2drop 0
] [
over cons? [
pred >r uncons r> tuck
- (cons-hashcode) >r
- (cons-hashcode) r>
+ cons-hashcode >r
+ cons-hashcode r>
bitxor
] [
drop hashcode
] ifte
] ifte ;
-: cons-hashcode ( cons -- hash )
- 4 (cons-hashcode) ;
+M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
: project ( n quot -- list )
#! Execute the quotation n times, passing the loop counter
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: math
-USE: kernel
-
-: integer? dup fixnum? swap bignum? or ;
-: rational? dup integer? swap ratio? or ;
-: real? dup number? swap complex? not and ;
-
-: max ( x y -- z )
- 2dup > [ drop ] [ nip ] ifte ;
-
-: min ( x y -- z )
- 2dup < [ drop ] [ nip ] ifte ;
-
-: between? ( x min max -- ? )
- #! Push if min <= x <= max. Handles case where min > max
- #! by swapping them.
- 2dup > [ swap ] when >r dupd max r> min = ;
-
-: sq dup * ; inline
-
-: pred 1 - ; inline
-: succ 1 + ; inline
-
-: neg 0 swap - ; inline
-: recip 1 swap / ; inline
-
-: rem ( x y -- x%y )
- #! Like modulus, but always gives a positive result.
- [ mod ] keep over 0 < [ + ] [ drop ] ifte ;
-
-: sgn ( n -- -1/0/1 )
- #! Push the sign of a real number.
- dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
--- /dev/null
+! :folding=indent:collapseFolds=0:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: math
+USE: generic
+USE: kernel
+USE: math
+
+: >rect ( x -- xr xi ) dup real swap imaginary ;
+
+IN: math-internals
+
+: 2>rect ( x y -- xr yr xi yi )
+ [ swap real swap real ] 2keep
+ swap imaginary swap imaginary ;
+
+M: complex number= ( x y -- ? )
+ 2>rect number= [ number= ] [ 2drop f ] ifte ;
+
+: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
+: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline
+
+M: complex + 2>rect + >r + r> rect> ;
+M: complex - 2>rect - >r - r> rect> ;
+M: complex * ( x y -- x*y ) 2dup *re - -rot *im + rect> ;
+
+: abs^2 ( x -- y ) >rect sq swap sq + ; inline
+: complex/ ( x y -- r i m )
+ #! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi
+ dup abs^2 >r 2dup *re + -rot *im - r> ; inline
+
+M: complex / ( x y -- x/y ) complex/ tuck / >r / r> rect> ;
+M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> rect> ;
+
+M: complex abs ( z -- |z| ) >rect mag2 ;
+
+: conjugate ( z -- z* )
+ >rect neg rect> ;
+
+: arg ( z -- arg )
+ #! Compute the complex argument.
+ >rect swap fatan2 ;
+
+: >polar ( z -- abs arg )
+ >rect 2dup swap fatan2 >r mag2 r> ;
+
+: cis ( theta -- cis )
+ dup fcos swap fsin rect> ;
+
+: polar> ( abs arg -- z )
+ cis * ;
+
+M: complex hashcode ( n -- n )
+ >rect >fixnum swap >fixnum bitxor ;
--- /dev/null
+! :folding=indent:collapseFolds=0:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: math-internals
+USE: generic
+USE: kernel
+USE: math
+
+M: float number= float= ;
+M: float < float< ;
+M: float <= float<= ;
+M: float > float> ;
+M: float >= float>= ;
+
+M: float + float+ ;
+M: float - float- ;
+M: float * float* ;
+M: float / float/f ;
+M: float /f float/f ;
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: math
-USE: errors
-USE: generic
-USE: kernel
-USE: vectors
-USE: words
-
-BUILTIN: fixnum 0
-BUILTIN: ratio 4
-BUILTIN: complex 5
-BUILTIN: bignum 9
-BUILTIN: float 10
-
-DEFER: number=
-DEFER: mod
-DEFER: abs
-DEFER: <
-DEFER: <=
-DEFER: >
-DEFER: >=
-DEFER: neg
-DEFER: /i
-DEFER: *
-DEFER: +
-DEFER: -
-DEFER: /
-DEFER: /f
-DEFER: sq
-
-: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
-: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
-
-: >rect ( x -- x:re x: im ) dup real swap imaginary ;
-: 2>rect ( x y -- x:re y:re x:im y:im )
- [ swap real swap real ] 2keep
- swap imaginary swap imaginary ;
-
-: 2>fraction ( a/b c/d -- a c b d )
- [ swap numerator swap numerator ] 2keep
- swap denominator swap denominator ;
-
-IN: math-internals
-
-: reduce ( x y -- x' y' )
- dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
-: ratio ( x y -- x/y ) reduce fraction> ;
-
-: ratio= ( a/b c/d -- ? )
- 2>fraction number= [ number= ] [ 2drop f ] ifte ;
-: ratio-scale ( a/b c/d -- a*d b*c )
- 2>fraction >r * swap r> * swap ;
-: ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ;
-: ratio+ ( x y -- x+y ) 2dup ratio-scale + -rot ratio+d ratio ;
-: ratio- ( x y -- x-y ) 2dup ratio-scale - -rot ratio+d ratio ;
-: ratio* ( x y -- x*y ) 2>fraction * >r * r> ratio ;
-: ratio/ ( x y -- x/y ) ratio-scale ratio ;
-: ratio/f ( x y -- x/y ) ratio-scale /f ;
-
-: ratio< ( x y -- ? ) ratio-scale < ;
-: ratio<= ( x y -- ? ) ratio-scale <= ;
-: ratio> ( x y -- ? ) ratio-scale > ;
-: ratio>= ( x y -- ? ) ratio-scale >= ;
-
-: complex= ( x y -- ? )
- 2>rect number= [ number= ] [ 2drop f ] ifte ;
-
-: complex+ ( x y -- x+y ) 2>rect + >r + r> rect> ;
-: complex- ( x y -- x-y ) 2>rect - >r - r> rect> ;
-: complex*re ( x y -- x:re * y:re x:im * r:im )
- 2>rect * >r * r> ;
-: complex*im ( x y -- x:im * y:re x:re * y:im )
- 2>rect >r * swap r> * ;
-: complex* ( x y -- x*y )
- 2dup complex*re - -rot complex*im + rect> ;
-: abs^2 ( x -- y ) >rect sq swap sq + ;
-: (complex/) ( x y -- r i m )
- #! r = x:re * y:re + x:im * y:im
- #! i = x:im * y:re - x:re * y:im
- #! m = y:re * y:re + y:im * y:im
- dup abs^2 >r 2dup complex*re + -rot complex*im - r> ;
-: complex/ ( x y -- x/y )
- (complex/) tuck / >r / r> rect> ;
-: complex/f ( x y -- x/y )
- (complex/) tuck /f >r /f r> rect> ;
-
-IN: math
-USE: math-internals
-
-: number= ( x y -- ? )
- {
- [ fixnum= ]
- [ 2drop f ]
- [ 2drop f ]
- [ 2drop f ]
- [ ratio= ]
- [ complex= ]
- [ 2drop f ]
- [ 2drop f ]
- [ 2drop f ]
- [ bignum= ]
- [ float= ]
- [ 2drop f ]
- [ 2drop f ]
- [ 2drop f ]
- [ 2drop f ]
- [ 2drop f ]
- [ 2drop f ]
- } 2generic ;
-
-: + ( x y -- x+y )
- {
- [ fixnum+ ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio+ ]
- [ complex+ ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum+ ]
- [ float+ ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: - ( x y -- x-y )
- {
- [ fixnum- ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio- ]
- [ complex- ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum- ]
- [ float- ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: * ( x y -- x*y )
- {
- [ fixnum* ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio* ]
- [ complex* ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum* ]
- [ float* ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: / ( x y -- x/y )
- {
- [ ratio ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio/ ]
- [ complex/ ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio ]
- [ float/f ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: /i ( x y -- x/y )
- {
- [ fixnum/i ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum/i ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: /f ( x y -- x/y )
- {
- [ fixnum/f ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio/f ]
- [ complex/f ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum/f ]
- [ float/f ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: mod ( x y -- x%y )
- {
- [ fixnum-mod ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum-mod ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: /mod ( x y -- x/y x%y )
- {
- [ fixnum/mod ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum/mod ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: bitand ( x y -- x&y )
- {
- [ fixnum-bitand ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum-bitand ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: bitor ( x y -- x|y )
- {
- [ fixnum-bitor ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum-bitor ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: bitxor ( x y -- x^y )
- {
- [ fixnum-bitxor ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum-bitxor ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: bitnot ( x -- ~x )
- {
- [ fixnum-bitnot ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum-bitnot ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } generic ;
-
-: shift ( x n -- x<<n )
- {
- [ fixnum-shift ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum-shift ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: < ( x y -- ? )
- {
- [ fixnum< ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio< ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum< ]
- [ float< ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: <= ( x y -- ? )
- {
- [ fixnum<= ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio<= ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum<= ]
- [ float<= ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: > ( x y -- ? )
- {
- [ fixnum> ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio> ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum> ]
- [ float> ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
-
-: >= ( x y -- ? )
- {
- [ fixnum>= ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ ratio>= ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ bignum>= ]
- [ float>= ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- [ undefined-method ]
- } 2generic ;
--- /dev/null
+! :folding=indent:collapseFolds=0:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: math-internals
+USE: generic
+USE: kernel
+USE: math
+
+: reduce ( x y -- x' y' )
+ dup 0 < [ swap neg swap neg ] when
+ 2dup gcd tuck /i >r /i r> ; inline
+
+: integer/ ( x y -- x/y )
+ reduce fraction> ; inline
+
+M: fixnum number= fixnum= ;
+M: fixnum < fixnum< ;
+M: fixnum <= fixnum<= ;
+M: fixnum > fixnum> ;
+M: fixnum >= fixnum>= ;
+
+M: fixnum + fixnum+ ;
+M: fixnum - fixnum- ;
+M: fixnum * fixnum* ;
+M: fixnum / integer/ ;
+M: fixnum /i fixnum/i ;
+M: fixnum /f fixnum/f ;
+M: fixnum mod fixnum-mod ;
+
+M: fixnum /mod fixnum/mod ;
+
+M: fixnum bitand fixnum-bitand ;
+M: fixnum bitor fixnum-bitor ;
+M: fixnum bitxor fixnum-bitxor ;
+M: fixnum shift fixnum-shift ;
+
+M: fixnum bitnot fixnum-bitnot ;
+
+M: bignum number= bignum= ;
+M: bignum < bignum< ;
+M: bignum <= bignum<= ;
+M: bignum > bignum> ;
+M: bignum >= bignum>= ;
+
+M: bignum + bignum+ ;
+M: bignum - bignum- ;
+M: bignum * bignum* ;
+M: bignum / integer/ ;
+M: bignum /i bignum/i ;
+M: bignum /f bignum/f ;
+M: bignum mod bignum-mod ;
+
+M: bignum /mod bignum/mod ;
+
+M: bignum bitand bignum-bitand ;
+M: bignum bitor bignum-bitor ;
+M: bignum bitxor bignum-bitxor ;
+M: bignum shift bignum-shift ;
+
+M: bignum bitnot bignum-bitnot ;
#! than it produces.
0 swap (times) ; inline
+: fac ( n -- n! )
+ 1 swap [ succ * ] times* ;
+
: 2times-succ ( #{ a b } #{ c d } -- z )
#! Lexicographically add #{ 0 1 } to a complex number.
#! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }.
! $Id$
!
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2003, 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
+USE: generic
USE: kernel
-USE: math
USE: math-internals
-: fac ( n -- n! )
- ! This is the naive implementation, for benchmarking purposes.
- 1 swap [ succ * ] times* ;
+! Math operations
+2GENERIC: number= ( x y -- ? )
+2GENERIC: < ( x y -- ? )
+2GENERIC: <= ( x y -- ? )
+2GENERIC: > ( x y -- ? )
+2GENERIC: >= ( x y -- ? )
-: mag2 ( x y -- mag )
- #! Returns the magnitude of the vector (x,y).
- swap sq swap sq + fsqrt ;
+2GENERIC: + ( x y -- x+y )
+2GENERIC: - ( x y -- x-y )
+2GENERIC: * ( x y -- x*y )
+2GENERIC: / ( x y -- x/y )
+2GENERIC: /i ( x y -- x/y )
+2GENERIC: /f ( x y -- x/y )
+2GENERIC: mod ( x y -- x%y )
+
+2GENERIC: /mod ( x y -- x/y x%y )
+
+2GENERIC: bitand ( x y -- z )
+2GENERIC: bitor ( x y -- z )
+2GENERIC: bitxor ( x y -- z )
+2GENERIC: shift ( x n -- y )
+
+GENERIC: bitnot ( n -- n )
+
+! Math types
+BUILTIN: fixnum 0
+BUILTIN: bignum 9
+UNION: integer fixnum bignum ;
+
+BUILTIN: ratio 4
+UNION: rational integer ratio ;
+
+BUILTIN: float 10
+UNION: real rational float ;
+
+BUILTIN: complex 5
+UNION: number real complex ;
+
+M: real hashcode ( n -- n ) >fixnum ;
-: abs ( z -- abs )
- #! Compute the complex absolute value.
- dup complex? [ >rect mag2 ] [ dup 0 < [ neg ] when ] ifte ;
+M: number = ( n n -- ? ) number= ;
-: conjugate ( z -- z* )
- >rect neg rect> ;
+: max ( x y -- z )
+ 2dup > [ drop ] [ nip ] ifte ;
-: arg ( z -- arg )
- #! Compute the complex argument.
- >rect swap fatan2 ; inline
+: min ( x y -- z )
+ 2dup < [ drop ] [ nip ] ifte ;
+
+: between? ( x min max -- ? )
+ #! Push if min <= x <= max. Handles case where min > max
+ #! by swapping them.
+ 2dup > [ swap ] when >r dupd max r> min = ;
+
+: sq dup * ; inline
+
+: pred 1 - ; inline
+: succ 1 + ; inline
+
+: neg 0 swap - ; inline
+: recip 1 swap / ; inline
+
+: rem ( x y -- x%y )
+ #! Like modulus, but always gives a positive result.
+ [ mod ] keep over 0 < [ + ] [ drop ] ifte ;
+
+: sgn ( n -- -1/0/1 )
+ #! Push the sign of a real number.
+ dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
+
+: mag2 ( x y -- mag )
+ #! Returns the magnitude of the vector (x,y).
+ swap sq swap sq + fsqrt ;
-: >polar ( z -- abs arg )
- >rect 2dup swap fatan2 >r mag2 r> ;
+GENERIC: abs ( z -- |z| )
+M: real abs dup 0 < [ neg ] when ;
-: cis ( theta -- cis )
- dup fcos swap fsin rect> ;
+: (gcd) ( x y -- z )
+ dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
-: polar> ( abs arg -- z )
- cis * ; inline
+: gcd ( x y -- z )
+ #! Greatest common divisor.
+ abs swap abs 2dup < [ swap ] when (gcd) ;
: align ( offset width -- offset )
2dup mod dup 0 = [ 2drop ] [ - + ] ifte ;
--- /dev/null
+! :folding=indent:collapseFolds=0:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: math-internals
+USE: generic
+USE: kernel
+USE: math
+
+: 2>fraction ( a/b c/d -- a c b d )
+ [ swap numerator swap numerator ] 2keep
+ swap denominator swap denominator ; inline
+
+M: ratio number= ( a/b c/d -- ? )
+ 2>fraction number= [ number= ] [ 2drop f ] ifte ;
+
+: scale ( a/b c/d -- a*d b*c )
+ 2>fraction >r * swap r> * swap ; inline
+
+: ratio+d ( a/b c/d -- b*d )
+ denominator swap denominator * ; inline
+
+M: ratio < scale < ;
+M: ratio <= scale <= ;
+M: ratio > scale > ;
+M: ratio >= scale >= ;
+
+M: ratio + ( x y -- x+y ) 2dup scale + -rot ratio+d integer/ ;
+M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d integer/ ;
+M: ratio * ( x y -- x*y ) 2>fraction * >r * r> integer/ ;
+M: ratio / scale integer/ ;
+M: ratio /i scale /i ;
+M: ratio /f scale /f ;
USE: lists
USE: math
+! Define methods bound to primitives
BUILTIN: string 12
+M: string hashcode str-hashcode ;
+M: string = str= ;
+
BUILTIN: sbuf 13
+M: sbuf hashcode sbuf-hashcode ;
+M: sbuf = sbuf= ;
: f-or-"" ( obj -- ? )
dup not swap "" = or ;
-rot 2dup >r >r >r str-nth r> call r> r>
] times* 2drop ; inline
-: blank? ( ch -- ? ) " \t\n\r" str-contains? ;
-: letter? ( ch -- ? ) CHAR: a CHAR: z between? ;
-: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ;
-: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ;
-: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ;
+PREDICATE: integer blank " \t\n\r" str-contains? ;
+PREDICATE: integer letter CHAR: a CHAR: z between? ;
+PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
+PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
+PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without
: not-a-number "Not a number" throw ;
-: digit> ( ch -- n )
- [
- [ digit? ] [ CHAR: 0 - ]
- [ letter? ] [ CHAR: a - 10 + ]
- [ LETTER? ] [ CHAR: A - 10 + ]
- [ drop t ] [ not-a-number ]
- ] cond ;
+GENERIC: digit> ( ch -- n )
+M: digit digit> CHAR: 0 - ;
+M: letter digit> CHAR: a - 10 + ;
+M: LETTER digit> CHAR: A - 10 + ;
+M: object digit> not-a-number ;
: digit+ ( num digit base -- num )
2dup < [ rot * + ] [ not-a-number ] ifte ;
#! conversion fails.
swap "-" ?str-head [ (base>) neg ] [ (base>) ] ifte ;
-DEFER: str>number
-FORGET: str>number
GENERIC: str>number ( str -- num )
M: string str>number 10 base> ;
[ 0 ] [ [ 1 2 | 3 ] funny-length ] unit-test
[ 3 ] [ [ 1 2 3 ] funny-length ] unit-test
[ "hello" funny-length ] unit-test-fails
+
+! Testing method sorting
+GENERIC: sorting-test
+M: fixnum sorting-test drop "fixnum" ;
+M: object sorting-test drop "object" ;
+[ "fixnum" ] [ 3 sorting-test ] unit-test
+[ "object" ] [ f sorting-test ] unit-test
+
+! Testing unions
+UNION: funnies cons ratio complex ;
+
+GENERIC: funny
+M: funnies funny drop 2 ;
+M: object funny drop 0 ;
+
+[ 2 ] [ [ { } ] funny ] unit-test
+[ 0 ] [ { } funny ] unit-test
+
+PREDICATE: funnies very-funny number? ;
+
+GENERIC: gooey
+M: very-funny gooey sq ;
+
+[ 1/4 ] [ 1/2 gooey ] unit-test
: vector-length= ( vec vec -- ? )
vector-length swap vector-length number= ;
-: vector= ( obj vec -- ? )
+M: vector = ( obj vec -- ? )
#! Check if two vectors are equal. Two vectors are
#! considered equal if they have the same length and contain
#! equal elements.
: ?vector-nth ( n vec -- obj/f )
2dup vector-length >= [ 2drop f ] [ vector-nth ] ifte ;
-: vector-hashcode ( vec -- n )
+M: vector hashcode ( vec -- n )
0 swap 4 [
over ?vector-nth hashcode rot bitxor swap
] times* drop ;
BUILTIN: word 1
+M: word hashcode word-hashcode ;
+
SYMBOL: vocabularies
: word-property ( word pname -- pvalue )
#define NUMBER_TYPE 103 /* F_COMPLEX or REAL */
#define TEXT_TYPE 104 /* F_FIXNUM or F_STRING */
-/* CELL type_of(CELL tagged); */
-
bool typep(CELL type, CELL tagged);
INLINE CELL tag_header(CELL cell)
projects / factor.git / commitdiff