diff --git a/examples/dejong.factor b/examples/dejong.factor index 6d3313e1c8..03c0f58f17 100644 --- a/examples/dejong.factor +++ b/examples/dejong.factor @@ -48,7 +48,7 @@ SYMBOL: d : 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 ( -- ) diff --git a/examples/factoroids.factor b/examples/factoroids.factor index b462e9d59c..4c3e908a7c 100644 --- a/examples/factoroids.factor +++ b/examples/factoroids.factor @@ -129,7 +129,7 @@ M: ship tick ( actor -- ? ) dup [ move ] bind active? ; 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 @@ -154,7 +154,7 @@ C: plasma ( actor dy -- plasma ) [ velocity set actor-xy - blue color set + blue rgb color set 10 len set 5 radius set active on @@ -195,7 +195,7 @@ SYMBOL: stars : 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 ) @@ -254,7 +254,7 @@ C: enemy ; : spawn-enemy ( -- ) [ random-x 10 rect> position set - red color set + red rgb color set 0 wiggle-x set 0 velocity set 10 radius set @@ -316,7 +316,7 @@ SYMBOL: event : 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. diff --git a/examples/mandel.factor b/examples/mandel.factor index 0e2ecf6888..a4384c2878 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -32,7 +32,7 @@ USE: test : 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 @@ -44,9 +44,9 @@ USE: test : ( 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 @@ -73,14 +73,14 @@ SYMBOL: center nb-iter get max-color min 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 ] [ diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index dd4addbadd..2456ed93f7 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -57,7 +57,6 @@ USE: namespaces "/library/math/float.factor" "/library/math/complex.factor" "/library/words.factor" - "/library/math/math-combinators.factor" "/library/lists.factor" "/library/vectors.factor" "/library/strings.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 6b7e0dd495..49a272f6c5 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -51,7 +51,6 @@ USE: hashtables "/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, diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 820c63283e..9b4e47857b 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -285,8 +285,8 @@ M: vector ' ( vector -- pointer ) ! 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 ; diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 7b99e0343e..056ae65cc7 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -2,7 +2,7 @@ ! $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: @@ -40,6 +40,7 @@ USE: parser USE: words USE: hashtables USE: strings +USE: unparser ! Command line parameters specify libraries to load. ! @@ -68,6 +69,15 @@ M: alien = ( obj obj -- ? ) 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 ; diff --git a/library/generic/complement.factor b/library/generic/complement.factor index e0014b1666..26bd8e3f62 100644 --- a/library/generic/complement.factor +++ b/library/generic/complement.factor @@ -48,7 +48,12 @@ complement [ 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 diff --git a/library/generic/object.factor b/library/generic/object.factor index 61e5941f24..7802599697 100644 --- a/library/generic/object.factor +++ b/library/generic/object.factor @@ -47,8 +47,8 @@ object [ 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 diff --git a/library/hashtables.factor b/library/hashtables.factor index e910815fc7..33e65a94cf 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -105,22 +105,3 @@ PREDICATE: vector hashtable ( obj -- ? ) : alist>hash ( alist -- hash ) 37 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 ; diff --git a/library/inference/types.factor b/library/inference/types.factor index e962b5ed90..5e6b19d114 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -74,15 +74,8 @@ USE: prettyprint ] "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 diff --git a/library/lists.factor b/library/lists.factor index cfe95b7db1..20265abfe2 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -161,15 +161,14 @@ M: cons = ( obj cons -- ? ) 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. diff --git a/library/math/math-combinators.factor b/library/math/math-combinators.factor deleted file mode 100644 index ae666d2136..0000000000 --- a/library/math/math-combinators.factor +++ /dev/null @@ -1,91 +0,0 @@ -! :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) ; diff --git a/library/math/math.factor b/library/math/math.factor index 6e733352b2..69abeb22fb 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -114,3 +114,19 @@ M: real abs dup 0 < [ neg ] when ; : 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 diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index 3961b0b0d8..a84417bb81 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -81,11 +81,14 @@ USE: alien : 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 ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 137d6deba1..2e7f1b406c 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -54,26 +54,28 @@ SYMBOL: surface #! 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 diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index 7f7ea3d696..a7c1722484 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -2,7 +2,7 @@ ! $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: @@ -60,6 +60,13 @@ BEGIN-STRUCT: rect 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 @@ -148,10 +155,9 @@ END-STRUCT ! 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 ; @@ -159,9 +165,21 @@ END-STRUCT : 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" diff --git a/library/strings.factor b/library/strings.factor index 42e82b7ee4..c663c27b1f 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -134,12 +134,20 @@ UNION: text string integer ; 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? ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 0af1918ff5..15fefa4794 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -186,7 +186,7 @@ M: hashtable prettyprint* ( indent hashtable -- indent ) : {.} ( vector -- ) #! Unparse each element on its own line. - stack>list [ . ] each ; + vector>list reverse [ . ] each ; : .s datastack {.} ; : .r callstack {.} ; diff --git a/library/test/benchmark/empty-loop.factor b/library/test/benchmark/empty-loop.factor index c9eb24ed22..43875a217a 100644 --- a/library/test/benchmark/empty-loop.factor +++ b/library/test/benchmark/empty-loop.factor @@ -8,7 +8,7 @@ USE: test [ ] times ; compiled : empty-loop-2 ( n -- ) - [ drop ] times* ; compiled + [ ] repeat ; compiled [ ] [ 5000000 empty-loop-1 ] unit-test [ ] [ 5000000 empty-loop-2 ] unit-test diff --git a/library/test/benchmark/fac.factor b/library/test/benchmark/fac.factor index 41dfabc6ee..5beeec8ff5 100644 --- a/library/test/benchmark/fac.factor +++ b/library/test/benchmark/fac.factor @@ -4,12 +4,22 @@ USE: 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 diff --git a/library/test/benchmark/hashtables.factor b/library/test/benchmark/hashtables.factor index 528e28cd1b..087cfb95b8 100644 --- a/library/test/benchmark/hashtables.factor +++ b/library/test/benchmark/hashtables.factor @@ -9,10 +9,10 @@ USE: compiler ! 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 swap 2dup store-hash lookup-hash ; compiled diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor index 80de85a7ae..8d6a767991 100644 --- a/library/test/benchmark/vectors.factor +++ b/library/test/benchmark/vectors.factor @@ -7,7 +7,7 @@ USE: test ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html : fill-vector ( n -- vector ) - dup swap [ dup pick set-vector-nth ] times* ; compiled + dup 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. @@ -15,7 +15,7 @@ USE: test : 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 over fill-vector rot copy-vector ; compiled diff --git a/library/test/generic.factor b/library/test/generic.factor index 08b1f95e23..7b039e6cd3 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -151,3 +151,13 @@ DEFER: bah 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 diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index cf7648aa5a..77cf386e86 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -11,7 +11,7 @@ USE: vectors : 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 ] @@ -40,11 +40,11 @@ unit-test 16 "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 [ diff --git a/library/test/math/math-combinators.factor b/library/test/math/math-combinators.factor index dec33d53d1..232248e079 100644 --- a/library/test/math/math-combinators.factor +++ b/library/test/math/math-combinators.factor @@ -2,19 +2,12 @@ IN: scratchpad 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 diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 33904da9b5..0b901472e3 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -56,14 +56,6 @@ USE: namespaces [ 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 diff --git a/library/ui/console.factor b/library/ui/console.factor index cf1a498ac7..2c2ff83c1f 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -105,9 +105,9 @@ SYMBOL: input-line 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 ; @@ -121,10 +121,10 @@ SYMBOL: input-line : 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 ; @@ -158,7 +158,7 @@ SYMBOL: input-line scrollbar-top width get scrollbar-bottom - black boxColor ; + black rgb boxColor ; : draw-console ( -- ) [ diff --git a/library/vectors.factor b/library/vectors.factor index 2ef7d37c99..ffa7ce67d8 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -82,12 +82,20 @@ BUILTIN: vector 11 : >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 @@ -113,34 +121,19 @@ BUILTIN: vector 11 [ rot vector-nappend ] keep [ swap vector-nappend ] keep ; -: vector-project ( n quot -- accum ) +: list>vector ( list -- vector ) + dup length 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 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 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= ; @@ -153,7 +146,7 @@ M: vector = ( obj vec -- ? ) ] [ over vector? [ 2dup vector-length= [ - swap stack>list swap stack>list = + swap vector>list swap vector>list = ] [ 2drop f ] ifte @@ -163,9 +156,11 @@ M: vector = ( obj vec -- ? ) ] 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