steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

removed times*, use repeat instead

cvs
Slava Pestov 2005-01-23 21:47:28 +00:00
parent 406a989bab
commit 73d505339a
29 changed files with 182 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
examples/dejong.factor
View File

@ -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 ( -- )

10
examples/factoroids.factor
View File

@ -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 ( -- )
<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.

12
examples/mandel.factor
View File

@ -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
: <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
@ -73,14 +73,14 @@ SYMBOL: center
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
] [

1
library/bootstrap/boot-stage2.factor
View File

@ -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"

1
library/bootstrap/boot.factor
View File

@ -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,

4
library/bootstrap/image.factor
View File

@ -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 ;

12
library/compiler/alien.factor
View File

@ -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 ;

7
library/generic/complement.factor
View File

@ -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

4
library/generic/object.factor
View File

@ -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

19
library/hashtables.factor
View File

@ -105,22 +105,3 @@ PREDICATE: vector hashtable ( obj -- ? )
: 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 ;

11
library/inference/types.factor
View File

@ -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

13
library/lists.factor
View File

@ -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.

91
library/math/math-combinators.factor
View File

@ -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) ;

16
library/math/math.factor
View File

@ -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

5
library/sdl/sdl-ttf.factor
View File

@ -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 ;

26
library/sdl/sdl-utils.factor
View File

@ -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

34
library/sdl/sdl-video.factor
View File

@ -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"

18
library/strings.factor
View File

@ -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? ;

2
library/syntax/prettyprint.factor
View File

@ -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 {.} ;

2
library/test/benchmark/empty-loop.factor
View File

@ -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

14
library/test/benchmark/fac.factor
View File

@ -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

4
library/test/benchmark/hashtables.factor
View File

@ -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 <hashtable> swap 2dup store-hash lookup-hash ; compiled

4
library/test/benchmark/vectors.factor
View File

@ -7,7 +7,7 @@ USE: test
! 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.
@ -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 <vector> over fill-vector rot copy-vector ; compiled

10
library/test/generic.factor
View File

@ -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

6
library/test/hashtables.factor
View File

@ -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 <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
[

21
library/test/math/math-combinators.factor
View File

@ -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

8
library/test/vectors.factor
View File

@ -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

12
library/ui/console.factor
View File

@ -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 ( -- )
[

53
library/vectors.factor
View File

@ -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 <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= ;
@ -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