: draw-dejong ( x0 y0 iterations -- )
[
- iterate-dejong 2dup scale-dejong rect> white pixel
+ iterate-dejong 2dup scale-dejong rect> white rgb pixel
] times 2drop ; compiled
: dejong ( -- )
C: ship ( -- ship )
[
width get 2 /i height get 50 - rect> position set
- white color set
+ white rgb color set
10 radius set
0 velocity set
active on
[
velocity set
actor-xy
- blue color set
+ blue rgb color set
10 len set
5 radius set
active on
: random-y 0 height get random-int ;
: random-position random-x random-y rect> ;
: random-byte 0 255 random-int ;
-: random-color random-byte random-byte random-byte 255 rgba ;
+: random-color random-byte random-byte random-byte rgb ;
: random-velocity 0 10 20 random-int 10 /f rect> ;
: random-star ( -- star )
: spawn-enemy ( -- )
<enemy> [
random-x 10 rect> position set
- red color set
+ red rgb color set
0 wiggle-x set
0 velocity set
10 radius set
: render ( -- )
#! Draw the scene.
- [ black clear-surface draw-stars draw-actors ] with-surface ;
+ [ black rgb clear-surface draw-stars draw-actors ] with-surface ;
: advance ( -- )
#! Advance game state by one frame.
: scale 255 * >fixnum ;
-: scale-rgba ( r g b -- n )
+: scale-rgb ( r g b -- n )
scale
swap scale 8 shift bitor
swap scale 16 shift bitor
: <color-map> ( nb-cols -- map )
[
dup [
- 360 * over 1 + / 360 / sat val
- hsv>rgb 1.0 scale-rgba ,
- ] times*
+ dup 360 * over 1 + / 360 / sat val
+ hsv>rgb 1.0 scale-rgb ,
+ ] repeat
] make-list list>vector nip ;
: absq >rect swap sq swap sq + ; inline
nb-iter get max-color min <color-map> cols set ;
: c ( #{ i j }# -- c )
- >rect >r
+ >r
x-inc get * center get real x-inc get width get 2 / * - + >float
r>
y-inc get * center get imaginary y-inc get height get 2 / * - + >float
rect> ;
: render ( -- )
- width get height get [
+ [
c 0 nb-iter get iter dup 0 = [
drop 0
] [
"/library/math/float.factor"\r
"/library/math/complex.factor"\r
"/library/words.factor"\r
- "/library/math/math-combinators.factor"\r
"/library/lists.factor"\r
"/library/vectors.factor"\r
"/library/strings.factor"\r
"/library/math/float.factor" parse-resource append,
"/library/math/complex.factor" parse-resource append,
"/library/words.factor" parse-resource append,
- "/library/math/math-combinators.factor" parse-resource append,
"/library/lists.factor" parse-resource append,
"/library/vectors.factor" parse-resource append,
"/library/strings.factor" parse-resource append,
! Now make a rehashing boot quotation
dup hash>alist [
>r dup vector-length [
- f swap pick set-vector-nth
- ] times* r>
+ [ f swap pick set-vector-nth ] keep
+ ] repeat r>
[ unswons rot set-hash ] each-with
] cons cons
boot-quot [ append ] change ;
! $Id$
!
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
USE: words
USE: hashtables
USE: strings
+USE: unparser
! Command line parameters specify libraries to load.
!
2drop f
] ifte ;
+M: alien unparse ( obj -- str )
+ [
+ "#<" ,
+ dup local-alien? "local-alien" "alien" ? ,
+ " @ " ,
+ alien-address unparse ,
+ ">" ,
+ ] make-string ;
+
: library ( name -- object )
dup [ "libraries" get hash ] when ;
complement [
( generic vtable definition class -- )
- drop num-types [ >r 3dup r> add-method ] times* 3drop
+ drop num-types [
+ [
+ >r 3dup r> builtin-type
+ dup [ add-method ] [ 2drop 2drop ] ifte
+ ] keep
+ ] repeat 3drop
] "add-method" set-word-property
complement 90 "priority" set-word-property
object [
( generic vtable definition class -- )
drop over vector-length [
- pick pick -rot set-vector-nth
- ] times* 3drop
+ 3dup rot set-vector-nth
+ ] repeat 3drop
] "add-method" set-word-property
object [ drop t ] "predicate" set-word-property
: alist>hash ( alist -- hash )
37 <hashtable> swap [ unswons pick set-hash ] each ;
-
-! In case I break hashing:
-
-! : hash* ( key table -- value )
-! hash>alist assoc* ;
-!
-! : set-hash ( value key table -- )
-! dup vector-length [
-! ( value key table index )
-! >r 3dup r>
-! ( value key table value key table index )
-! [
-! swap vector-nth
-! ( value key table value key alist )
-! set-assoc
-! ] keep
-! ( value key table new-assoc index )
-! pick set-vector-nth
-! ] times* 3drop ;
] "infer" set-word-property
: type-value-map ( value -- )
- [
- num-types [
- dup builtin-type dup [
- pick swons cons ,
- ] [
- 2drop
- ] ifte
- ] times*
- ] make-list nip ;
+ num-types [ dup builtin-type pick swons cons ] project
+ [ cdr cdr ] subset nip ;
\ type [
[ object ] ensure-d
M: cons hashcode ( cons -- hash ) car hashcode ;
-: project ( n quot -- list )
- #! Execute the quotation n times, passing the loop counter
- #! the quotation as it ranges from 0..n-1. Collect results
- #! in a new list.
- [ ] rot [ -rot over >r >r call r> cons r> swap ] times*
- nip reverse ; inline
+: (count) ( i n -- list )
+ 2dup >= [ 2drop [ ] ] [ >r dup 1 + r> (count) cons ] ifte ;
: count ( n -- [ 0 ... n-1 ] )
- [ ] project ;
+ 0 swap (count) ;
+
+: project ( n quot -- list )
+ >r count r> map ; inline
: head ( list n -- list )
#! Return the first n elements of the list.
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $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
-
-: times ( n quot -- )
- #! Evaluate a quotation n times.
- #!
- #! In order to compile, the code must produce as many values
- #! as it consumes.
- tuck >r dup 0 <= [ r> 3drop ] [ 1 - slip r> times ] ifte ;
- inline
-
-: (times) ( limit n quot -- )
- pick pick <= [
- 3drop
- ] [
- rot pick 1 + pick 3slip (times)
- ] ifte ; inline
-
-: times* ( n quot -- )
- #! Evaluate a quotation n times, pushing the index at each
- #! iteration. The index ranges from 0 to n-1.
- #!
- #! In order to compile, the code must consume one more value
- #! than it produces.
- 0 swap (times) ; inline
-
-: fac ( n -- n! )
- 1 swap [ 1 + * ] 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 }#.
- 2dup imaginary 1 + swap imaginary = [
- nip real 1 +
- ] [
- nip >rect 1 + rect>
- ] ifte ; inline
-
-: 2times<= ( #{ a b }# #{ c d }# -- ? )
- swap real swap real <= ; inline
-
-: (2times) ( limit n quot -- )
- pick pick 2times<= [
- 3drop
- ] [
- rot pick dupd 2times-succ pick 3slip (2times)
- ] ifte ; inline
-
-: 2times* ( #{ w h }# quot -- )
- #! Apply a quotation to each pair of complex numbers
- #! #{ a b }# such that a < w, b < h.
- 0 swap (2times) ; inline
-
-: (repeat) ( i n quot -- )
- pick pick >= [
- 3drop
- ] [
- [ swap >r call 1 + r> ] keep (repeat)
- ] ifte ;
-
-: repeat ( n quot -- )
- #! Execute a quotation n times. The loop counter is kept on
- #! the stack, and ranges from 0 to n-1.
- 0 -rot (repeat) ;
: align ( offset width -- offset )
2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;
+
+: (repeat) ( i n quot -- )
+ pick pick >= [
+ 3drop
+ ] [
+ [ swap >r call 1 + r> ] keep (repeat)
+ ] ifte ; inline
+
+: repeat ( n quot -- )
+ #! Execute a quotation n times. The loop counter is kept on
+ #! the stack, and ranges from 0 to n-1.
+ 0 -rot (repeat) ; inline
+
+: times ( n quot -- )
+ #! Evaluate a quotation n times.
+ swap [ >r dup slip r> ] repeat drop ; inline
: TTF_RenderText_Solid ( font text fg -- surface )
"surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" ] alien-invoke ;
+: TTF_RenderText_Shaded ( font text fg bg -- surface )
+ "surface*" "sdl-ttf" "TTF_RenderText_Shaded" [ "void*" "char*" "int" "int" ] alien-invoke ;
+
: TTF_RenderGlyph_Shaded ( font text fg bg -- surface )
"surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ;
: TTF_RenderText_Blended ( font text fg -- surface )
- "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" "int" ] alien-invoke ;
+ "surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
: TTF_RenderGlyph_Blended ( font text fg -- surface )
"surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
#! Set up SDL graphics and call the quotation.
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
-: rgba ( r g b a -- n )
+: rgb ( r g b a -- n )
+ 255
swap 8 shift bitor
swap 16 shift bitor
swap 24 shift bitor ;
-: black 0 0 0 255 rgba ;
-: white 255 255 255 255 rgba ;
-: red 255 0 0 255 rgba ;
-: green 0 255 0 255 rgba ;
-: blue 0 0 255 255 rgba ;
+: black 0 0 0 ;
+: white 255 255 255 ;
+: red 255 0 0 ;
+: green 0 255 0 ;
+: blue 0 0 255 ;
: clear-surface ( color -- )
>r surface get 0 0 width get height get r> boxColor ;
-: pixel-step ( quot #{ x y }# -- )
- tuck >r call >r surface get r> r> >rect rot pixelColor ;
- inline
-
-: with-pixels ( w h quot -- )
- -rot rect> [ over >r pixel-step r> ] 2times* drop ; inline
+: with-pixels ( quot -- )
+ width get [
+ height get [
+ [ rot dup slip swap surface get swap ] 2keep
+ [ rot pixelColor ] 2keep
+ ] repeat
+ ] repeat drop ; inline
: with-surface ( quot -- )
#! Execute a quotation, locking the current surface if it
! $Id$
!
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
FIELD: ushort h
END-STRUCT
+BEGIN-STRUCT: color
+ FIELD: uchar r
+ FIELD: uchar g
+ FIELD: uchar b
+ FIELD: uchar unused
+END-STRUCT
+
BEGIN-STRUCT: format
FIELD: void* palette
FIELD: uchar BitsPerPixel
! SDL_SetGamma: float types
-: SDL_FillRect ( surface rect color -- n )
- #! If rect is null, fills entire surface.
- "bool" "sdl" "SDL_FillRect"
- [ "surface*" "rect*" "uint" ] alien-invoke ;
+: SDL_MapRGB ( surface r g b -- rgb )
+ "uint" "sdl" "SDL_MapRGB"
+ [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ;
: SDL_LockSurface ( surface -- ? )
"bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-invoke ;
: SDL_UnlockSurface ( surface -- )
"void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-invoke ;
-: SDL_MapRGB ( surface r g b -- rgb )
- "uint" "sdl" "SDL_MapRGB"
- [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ;
+: SDL_FreeSurface ( surface -- )
+ "void" "sdl" "SDL_FreeSurface" [ "surface*" ] alien-invoke ;
+
+: SDL_UpperBlit ( src srcrect dst dstrect -- )
+ #! The blit function should not be called on a locked
+ #! surface.
+ "int" "sdl" "SDL_UpperBlit" [
+ "surface*" "rect*"
+ "surface*" "rect*"
+ ] alien-invoke ;
+
+: SDL_FillRect ( surface rect color -- n )
+ #! If rect is null, fills entire surface.
+ "bool" "sdl" "SDL_FillRect"
+ [ "surface*" "rect*" "uint" ] alien-invoke ;
: SDL_WM_SetCaption ( title icon -- )
"void" "sdl" "SDL_WM_SetCaption"
rot str-head swap
] ifte ;
-: str-each ( str [ code ] -- )
- #! Execute the code, with each character of the string
+: (str>list) ( i str -- list )
+ 2dup str-length >= [
+ 2drop [ ]
+ ] [
+ 2dup str-nth >r >r 1 + r> (str>list) r> swons
+ ] ifte ;
+
+: str>list ( str -- list )
+ 0 swap (str>list) ;
+
+: str-each ( str quot -- )
+ #! Execute the quotation with each character of the string
#! pushed onto the stack.
- over str-length [
- -rot 2dup >r >r >r str-nth r> call r> r>
- ] times* 2drop ; inline
+ >r str>list r> each ; inline
PREDICATE: integer blank " \t\n\r" str-contains? ;
PREDICATE: integer letter CHAR: a CHAR: z between? ;
: {.} ( vector -- )
#! Unparse each element on its own line.
- stack>list [ . ] each ;
+ vector>list reverse [ . ] each ;
: .s datastack {.} ;
: .r callstack {.} ;
[ ] times ; compiled
: empty-loop-2 ( n -- )
- [ drop ] times* ; compiled
+ [ ] repeat ; compiled
[ ] [ 5000000 empty-loop-1 ] unit-test
[ ] [ 5000000 empty-loop-2 ] unit-test
USE: compiler
USE: kernel
+: (fac) ( n! i -- n! )
+ dup 0 = [
+ drop
+ ] [
+ [ * ] keep 1 - (fac)
+ ] ifte ;
+
+: fac ( n -- n! )
+ 1 swap (fac) ;
+
: small-fac-benchmark
#! This tests fixnum math.
- 1 swap [ 10 fac 10 [ 1 + / ] times* max ] times ; compiled
+ 1 swap [ 10 fac 10 [ [ 1 + / ] keep ] repeat max ] times ; compiled
: big-fac-benchmark
- 10000 fac 10000 [ 1 + / ] times* ; compiled
+ 10000 fac 10000 [ [ 1 + / ] keep ] repeat ; compiled
[ 1 ] [ big-fac-benchmark ] unit-test
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
: store-hash ( hashtable n -- )
- [ dup >hex swap pick set-hash ] times* drop ; compiled
+ [ [ dup >hex swap pick set-hash ] keep ] repeat drop ; compiled
: lookup-hash ( hashtable n -- )
- [ unparse over hash drop ] times* drop ; compiled
+ [ [ unparse over hash drop ] keep ] repeat drop ; compiled
: hashtable-benchmark ( n -- )
60000 <hashtable> swap 2dup store-hash lookup-hash ; compiled
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
: fill-vector ( n -- vector )
- dup <vector> swap [ dup pick set-vector-nth ] times* ; compiled
+ dup <vector> swap [ [ dup pick set-vector-nth ] keep ] repeat ; compiled
: copy-elt ( vec-y vec-x n -- )
#! Copy nth element from vec-x to vec-y.
: copy-vector ( vec-y vec-x n -- )
#! Copy first n-1 elements from vec-x to vec-y.
- [ >r 2dup r> copy-elt ] times* 2drop ; compiled
+ [ [ >r 2dup r> copy-elt ] keep ] repeat 2drop ; compiled
: vector-benchmark ( n -- )
0 <vector> over fill-vector rot copy-vector ; compiled
FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ fixnum alien class-or ] unit-test
+
+DEFER: complement-test
+FORGET: complement-test
+GENERIC: complement-test
+
+M: f complement-test drop "f" ;
+M: general-t complement-test drop "general-t" ;
+
+[ "general-t" ] [ 5 complement-test ] unit-test
+[ "f" ] [ f complement-test ] unit-test
: silly-key/value dup dup * swap ;
-1000 [ silly-key/value "testhash" get set-hash ] times*
+1000 [ [ silly-key/value "testhash" get set-hash ] keep ] repeat
[ f ]
[ 1000 count [ silly-key/value "testhash" get hash = not ] subset ]
16 <hashtable> "testhash" set
t #{ 2 3 }# "testhash" get set-hash
-f 100 fac "testhash" get set-hash
+f 100000000000000000000000000 "testhash" get set-hash
{ } { [ { } ] } "testhash" get set-hash
[ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test
-[ f ] [ 100 fac "testhash" get hash* cdr ] unit-test
+[ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test
[ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test
[
USE: kernel
USE: math
USE: test
+USE: namespaces
-[ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test
-[ ] [ 0 [ ] times* ] unit-test
+[ ] [ 5 [ ] times ] unit-test
+[ ] [ 0 [ ] times ] unit-test
+[ ] [ -1 [ ] times ] unit-test
-[ #{ 1 1 }# ] [ #{ 2 3 }# #{ 1 0 }# 2times-succ ] unit-test
-[ #{ 1 2 }# ] [ #{ 2 3 }# #{ 1 1 }# 2times-succ ] unit-test
-[ #{ 2 0 }# ] [ #{ 3 3 }# #{ 1 2 }# 2times-succ ] unit-test
-[ #{ 2 1 }# ] [ #{ 3 3 }# #{ 2 0 }# 2times-succ ] unit-test
-[ #{ 2 0 }# ] [ #{ 2 2 }# #{ 1 1 }# 2times-succ ] unit-test
-
-[ #{ 0 0 }# #{ 0 1 }# #{ 1 0 }# #{ 1 1 }# ]
-[ #{ 2 2 }# [ ] 2times* ] unit-test
-
-[ #{ 0 0 }# #{ 0 1 }# #{ 0 2 }# #{ 1 0 }# #{ 1 1 }# #{ 1 2 }#
- #{ 2 0 }# #{ 2 1 }# #{ 2 2 }# ]
-[ #{ 3 3 }# [ ] 2times* ] unit-test
+[ ] [ 5 [ ] repeat ] unit-test
+[ [ 0 1 2 3 4 ] ] [ [ 5 [ dup , ] repeat ] make-list ] unit-test
+[ [ ] ] [ [ -1 [ dup , ] repeat ] make-list ] unit-test
[ 4 [ CHAR: a fill ] vector-project ]
unit-test
-[ { 6 8 10 12 } ]
-[ { 1 2 3 4 } { 5 6 7 8 } vector-zip [ uncons + ] vector-map ]
-unit-test
-
-[ { [[ 1 5 ]] [[ 2 6 ]] [[ 3 7 ]] [[ 4 8 ]] } ]
-[ { 1 2 3 4 } { 5 6 7 8 } vector-zip ]
-unit-test
-
[ [ ] ] [ 0 { } vector-tail ] unit-test
[ [ ] ] [ 2 { 1 2 } vector-tail ] unit-test
[ [ 3 4 ] ] [ 2 { 1 2 3 4 } vector-tail ] unit-test
total-lines fix-first-line first-line set ;
! Rendering
-: background white ;
-: foreground black ;
-: cursor red ;
+: background white rgb ;
+: foreground black rgb ;
+: cursor red rgb ;
: next-line ( -- )
0 x set line-height y [ + ] change ;
: draw-lines ( -- )
visible-lines available-lines min [
- first-line get +
+ dup first-line get +
lines get vector-nth draw-line
next-line
- ] times* ;
+ ] repeat ;
: blink-interval 500 ;
scrollbar-top
width get
scrollbar-bottom
- black boxColor ;
+ black rgb boxColor ;
: draw-console ( -- )
[
: >pop> ( stack -- stack )
dup vector-pop drop ;
-: vector-each ( vector code -- )
- #! Execute the code, with each element of the vector
+: (vector>list) ( i vec -- list )
+ 2dup vector-length >= [
+ 2drop [ ]
+ ] [
+ 2dup vector-nth >r >r 1 + r> (vector>list) r> swons
+ ] ifte ;
+
+: vector>list ( str -- list )
+ 0 swap (vector>list) ;
+
+: vector-each ( vector quotation -- )
+ #! Execute the quotation with each element of the vector
#! pushed onto the stack.
- over vector-length [
- -rot 2dup >r >r >r vector-nth r> call r> r>
- ] times* 2drop ; inline
+ >r vector>list r> each ; inline
: vector-map ( vector code -- vector )
#! Applies code to each element of the vector, return a new
[ rot vector-nappend ] keep
[ swap vector-nappend ] keep ;
-: vector-project ( n quot -- accum )
+: list>vector ( list -- vector )
+ dup length <vector> swap [ over vector-push ] each ;
+
+: vector-project ( n quot -- vector )
#! Execute the quotation n times, passing the loop counter
#! the quotation as it ranges from 0..n-1. Collect results
#! in a new vector.
- over <vector> rot [
- -rot 2dup >r >r slip vector-push r> r>
- ] times* nip ; inline
-
-: vector-zip ( v1 v2 -- v )
- #! Make a new vector with each pair of elements from the
- #! first two in a pair.
- over vector-length over vector-length min [
- pick pick >r over >r vector-nth r> r> vector-nth cons
- ] vector-project 2nip ;
+ project list>vector ; inline
: vector-clone ( vector -- vector )
#! Shallow copy of a vector.
[ ] vector-map ;
-: list>vector ( list -- vector )
- dup length <vector> swap [ over vector-push ] each ;
-
-: stack>list ( vector -- list )
- [ ] swap [ swons ] vector-each ;
-
-: vector>list ( vector -- list )
- stack>list reverse ;
-
: vector-length= ( vec vec -- ? )
vector-length swap vector-length number= ;
] [
over vector? [
2dup vector-length= [
- swap stack>list swap stack>list =
+ swap vector>list swap vector>list =
] [
2drop f
] ifte
] ifte ;
M: vector hashcode ( vec -- n )
- 0 swap dup vector-length 4 min [
- over vector-nth hashcode rot bitxor swap
- ] times* drop ;
+ dup vector-length 0 number= [
+ drop 0
+ ] [
+ 0 swap vector-nth hashcode
+ ] ifte ;
: vector-tail ( n vector -- list )
#! Return a new list with all elements from the nth
projects / factor.git / commitdiff