-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences sorting binary-search math
-math.order arrays combinators kernel ;
+USING: accessors classes functors kernel math math.vectors
+sequences ;
IN: sequences.cords
-<PRIVATE
+MIXIN: cord
-TUPLE: simple-cord
- { first read-only } { second read-only } ;
+TUPLE: generic-cord
+ { head read-only } { tail read-only } ; final
+INSTANCE: generic-cord cord
-M: simple-cord length
- [ first>> length ] [ second>> length ] bi + ; inline
+M: cord length
+ [ head>> length ] [ tail>> length ] bi + ; inline
-M: simple-cord virtual-exemplar first>> ; inline
+M: cord virtual-exemplar head>> ; inline
-M: simple-cord virtual@
- 2dup first>> length <
- [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ; inline
+M: cord virtual@
+ 2dup head>> length <
+ [ head>> ] [ [ head>> length - ] [ tail>> ] bi ] if ; inline
-TUPLE: multi-cord
- { count read-only } { seqs read-only } ;
+INSTANCE: cord virtual-sequence
-M: multi-cord length count>> ; inline
+GENERIC: cord-append ( seq1 seq2 -- cord )
-M: multi-cord virtual@
- dupd
- seqs>> [ first <=> ] with search nip
- [ first - ] [ second ] bi ; inline
+M: object cord-append
+ generic-cord boa ; inline
-M: multi-cord virtual-exemplar
- seqs>> [ f ] [ first second ] if-empty ; inline
+<FUNCTOR: define-specialized-cord ( T C -- )
-: <cord> ( seqs -- cord )
- dup length 2 = [
- first2 simple-cord boa
- ] [
- [ 0 [ length + ] accumulate ] keep zip multi-cord boa
- ] if ; inline
+T-cord DEFINES-CLASS ${C}
-PRIVATE>
+WHERE
-UNION: cord simple-cord multi-cord ;
+TUPLE: T-cord
+ { head T read-only } { tail T read-only } ; final
+INSTANCE: T-cord cord
-INSTANCE: cord virtual-sequence
+M: T cord-append
+ 2dup [ T instance? ] both?
+ [ T-cord boa ] [ generic-cord boa ] if ; inline
+
+;FUNCTOR>
+
+: cord-map ( cord quot -- cord' )
+ [ [ head>> ] dip call ]
+ [ [ tail>> ] dip call ] 2bi cord-append ; inline
+
+:: cord-2map ( cord-a cord-b quot fallback -- cord' )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi cord-append
+ ] [ fallback call ] if ; inline
+
+: cord-both ( cord quot -- h t )
+ [ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline
+
+:: cord-2both ( cord-a cord-b quot combine fallback -- result )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi combine call
+ ] [ fallback call ] if ; inline
+
+<PRIVATE
+: split-shuffle ( shuf -- sh uf )
+ dup length 2 /i cut* ; foldable
+PRIVATE>
-INSTANCE: multi-cord virtual-sequence
-
-: cord-append ( seq1 seq2 -- cord )
- {
- { [ over empty? ] [ nip ] }
- { [ dup empty? ] [ drop ] }
- { [ 2dup [ cord? ] both? ] [ [ seqs>> values ] bi@ append <cord> ] }
- { [ over cord? ] [ [ seqs>> values ] dip suffix <cord> ] }
- { [ dup cord? ] [ seqs>> values swap prefix <cord> ] }
- [ 2array <cord> ]
- } cond ; inline
-
-: cord-concat ( seqs -- cord )
- {
- { [ dup empty? ] [ drop f ] }
- { [ dup length 1 = ] [ first ] }
- [
- [
- {
- { [ dup cord? ] [ seqs>> values ] }
- { [ dup empty? ] [ drop { } ] }
- [ 1array ]
- } cond
- ] map concat <cord>
- ]
- } cond ; inline
+M: cord v+ [ v+ ] [ call-next-method ] cord-2map ; inline
+M: cord v- [ v- ] [ call-next-method ] cord-2map ; inline
+M: cord vneg [ vneg ] cord-map ; inline
+M: cord v+- [ v+- ] [ call-next-method ] cord-2map ; inline
+M: cord vs+ [ vs+ ] [ call-next-method ] cord-2map ; inline
+M: cord vs- [ vs- ] [ call-next-method ] cord-2map ; inline
+M: cord vs* [ vs* ] [ call-next-method ] cord-2map ; inline
+M: cord v* [ v* ] [ call-next-method ] cord-2map ; inline
+M: cord v/ [ v/ ] [ call-next-method ] cord-2map ; inline
+M: cord vmin [ vmin ] [ call-next-method ] cord-2map ; inline
+M: cord vmax [ vmax ] [ call-next-method ] cord-2map ; inline
+M: cord vdot [ vdot ] [ + ] [ call-next-method ] cord-2both ; inline
+M: cord vsqrt [ vsqrt ] cord-map ; inline
+M: cord sum [ sum ] cord-both + ; inline
+M: cord vabs [ vabs ] cord-map ; inline
+M: cord vbitand [ vbitand ] [ call-next-method ] cord-2map ; inline
+M: cord vbitandn [ vbitandn ] [ call-next-method ] cord-2map ; inline
+M: cord vbitor [ vbitor ] [ call-next-method ] cord-2map ; inline
+M: cord vbitxor [ vbitxor ] [ call-next-method ] cord-2map ; inline
+M: cord vbitnot [ vbitnot ] cord-map ; inline
+M: cord vand [ vand ] [ call-next-method ] cord-2map ; inline
+M: cord vandn [ vandn ] [ call-next-method ] cord-2map ; inline
+M: cord vor [ vor ] [ call-next-method ] cord-2map ; inline
+M: cord vxor [ vxor ] [ call-next-method ] cord-2map ; inline
+M: cord vnot [ vnot ] cord-map ; inline
+M: cord vlshift '[ _ vlshift ] cord-map ; inline
+M: cord vrshift '[ _ vrshift ] cord-map ; inline
+M: cord (vmerge-head) [ head>> ] bi@ (vmerge) cord-append ; inline
+M: cord (vmerge-tail) [ tail>> ] bi@ (vmerge) cord-append ; inline
+M: cord v<= [ v<= ] [ call-next-method ] cord-2map ; inline
+M: cord v< [ v< ] [ call-next-method ] cord-2map ; inline
+M: cord v= [ v= ] [ call-next-method ] cord-2map ; inline
+M: cord v> [ v> ] [ call-next-method ] cord-2map ; inline
+M: cord v>= [ v>= ] [ call-next-method ] cord-2map ; inline
+M: cord vunordered? [ vunordered? ] [ call-next-method ] cord-2map ; inline
+M: cord vany? [ vany? ] cord-both or ; inline
+M: cord vall? [ vall? ] cord-both and ; inline
+M: cord vnone? [ vnone? ] cord-both and ; inline
+M: cord vshuffle-elements
+ [ [ head>> ] [ tail>> ] bi ] [ split-shuffle ] bi*
+ [ vshuffle2-elements ] bi-curry@ 2bi cord-append ; inline
+
+M: cord n+v [ n+v ] with cord-map ; inline
+M: cord n-v [ n-v ] with cord-map ; inline
+M: cord n*v [ n*v ] with cord-map ; inline
+M: cord n/v [ n/v ] with cord-map ; inline
+M: cord v+n '[ _ v+n ] cord-map ; inline
+M: cord v-n '[ _ v-n ] cord-map ; inline
+M: cord v*n '[ _ v*n ] cord-map ; inline
+M: cord v/n '[ _ v/n ] cord-map ; inline
+
+M: cord norm-sq [ norm-sq ] cord-both + ; inline
+M: cord distance v- norm ; inline
projects / factor.git / blobdiff