diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 6df3e306dd..084aa0ac89 100644 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -75,3 +75,7 @@ IN: dlists.tests dup clone 3 over push-back [ dlist>seq ] bi@ ] unit-test + +[ V{ f 3 1 f } ] [ 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test + +[ V{ } ] [ dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index bd4e7c46e6..d8b78558d4 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -154,7 +154,7 @@ M: dlist clear-deque ( dlist -- ) [ obj>> ] prepose dlist-each-node ; inline : dlist>seq ( dlist -- seq ) - [ ] pusher [ dlist-each ] dip ; + [ drop t ] pusher [ dlist-each ] dip ; : 1dlist ( obj -- dlist ) [ push-front ] keep ; diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor index 7330ac1a56..f9f84fbbae 100644 --- a/basis/linked-assocs/linked-assocs.factor +++ b/basis/linked-assocs/linked-assocs.factor @@ -28,9 +28,6 @@ M: linked-assoc set-at [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep assoc>> set-at ; -: dlist>seq ( dlist -- seq ) - [ ] pusher [ dlist-each ] dip ; - M: linked-assoc >alist dlist>> dlist>seq ; diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 030f0977e2..175425f948 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -33,7 +33,7 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ; [ first ] [ ] bi exec-with-path ; : exec-args-with-env ( seq seq -- int ) - >r [ first ] [ ] bi r> exec-with-env ; + [ [ first ] [ ] bi ] dip exec-with-env ; : with-fork ( child parent -- ) [ [ fork-process dup zero? ] dip [ drop ] prepose ] dip diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index 56c632edb4..ad7c161713 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -31,8 +31,8 @@ C-STRUCT: statvfs { "uid_t" "f_owner" } { { "uint32_t" 4 } "f_spare" } { { "char" _VFS_NAMELEN } "f_fstypename" } - { { "char" _VFS_NAMELEN } "f_mntonname" } - { { "char" _VFS_NAMELEN } "f_mntfromname" } ; + { { "char" _VFS_MNAMELEN } "f_mntonname" } + { { "char" _VFS_MNAMELEN } "f_mntfromname" } ; FUNCTION: int statvfs ( char* path, statvfs *buf ) ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index ca8a7a2e60..d917425bf9 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -198,10 +198,10 @@ FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; : PATH_MAX 1024 ; inline : read-symbolic-link ( path -- path ) - PATH_MAX dup >r - PATH_MAX - [ readlink ] unix-system-call - r> swap head-slice >string ; + PATH_MAX dup [ + PATH_MAX + [ readlink ] unix-system-call + ] dip swap head-slice >string ; FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index eeebe1c12d..857abcf5d3 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,18 +6,18 @@ USING: kernel namespaces math.order math.vectors math.trig - math.physics.pos - math.physics.vel + math.ranges combinators arrays sequences random vars combinators.lib combinators.short-circuit - accessors ; + accessors + flatland ; IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid < vel ; +TUPLE: boid < ; C: boid @@ -62,11 +62,9 @@ VAR: separation-radius ! random-boid and random-boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: random-range ( a b -- n ) 1+ over - random + ; - : random-pos ( -- pos ) world-size> [ random ] map ; -: random-vel ( -- vel ) 2 [ drop -10 10 random-range ] map ; +: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ; : random-boid ( -- boid ) random-pos random-vel ; diff --git a/extra/combinators/cleave/enhanced/enhanced.factor b/extra/combinators/cleave/enhanced/enhanced.factor new file mode 100644 index 0000000000..b55979a791 --- /dev/null +++ b/extra/combinators/cleave/enhanced/enhanced.factor @@ -0,0 +1,31 @@ + +USING: combinators.cleave fry kernel macros parser quotations ; + +IN: combinators.cleave.enhanced + +: \\ + scan-word literalize parsed + scan-word literalize parsed ; parsing + +MACRO: bi ( p q -- quot ) + [ >quot ] dip + >quot + '[ _ _ [ keep ] dip call ] ; + +MACRO: tri ( p q r -- quot ) + [ >quot ] 2dip + [ >quot ] dip + >quot + '[ _ _ _ [ [ keep ] dip keep ] dip call ] ; + +MACRO: bi* ( p q -- quot ) + [ >quot ] dip + >quot + '[ _ _ [ dip ] dip call ] ; + +MACRO: tri* ( p q r -- quot ) + [ >quot ] 2dip + [ >quot ] dip + >quot + '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ; + diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor new file mode 100644 index 0000000000..a33da32908 --- /dev/null +++ b/extra/flatland/flatland.factor @@ -0,0 +1,178 @@ + +USING: accessors arrays fry kernel math math.vectors sequences + math.intervals + multi-methods + combinators.cleave.enhanced + multi-method-syntax ; + +IN: flatland + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Two dimensional world protocol + +GENERIC: x ( obj -- x ) +GENERIC: y ( obj -- y ) + +GENERIC: (x!) ( x obj -- ) +GENERIC: (y!) ( y obj -- ) + +: x! ( obj x -- obj ) over (x!) ; +: y! ( obj y -- obj ) over (y!) ; + +GENERIC: width ( obj -- width ) +GENERIC: height ( obj -- height ) + +GENERIC: (width!) ( width obj -- ) +GENERIC: (height!) ( height obj -- ) + +: width! ( obj width -- obj ) over (width!) ; +: height! ( obj height -- obj ) over (width!) ; + +! Predicates on relative placement + +GENERIC: to-the-left-of? ( obj obj -- ? ) +GENERIC: to-the-right-of? ( obj obj -- ? ) + +GENERIC: below? ( obj obj -- ? ) +GENERIC: above? ( obj obj -- ? ) + +GENERIC: in-between-horizontally? ( obj obj -- ? ) + +GENERIC: horizontal-interval ( obj -- interval ) + +GENERIC: move-to ( obj obj -- ) + +GENERIC: move-by ( obj delta -- ) + +GENERIC: move-left-by ( obj obj -- ) +GENERIC: move-right-by ( obj obj -- ) + +GENERIC: left ( obj -- left ) +GENERIC: right ( obj -- right ) +GENERIC: bottom ( obj -- bottom ) +GENERIC: top ( obj -- top ) + +GENERIC: distance ( a b -- c ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Some of the above methods work on two element sequences. +! A two element sequence may represent a point in space or describe +! width and height. + +METHOD: x ( sequence -- x ) first ; +METHOD: y ( sequence -- y ) second ; + +METHOD: (x!) ( number sequence -- ) set-first ; +METHOD: (y!) ( number sequence -- ) set-second ; + +METHOD: width ( sequence -- width ) first ; +METHOD: height ( sequence -- height ) second ; + +: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline +: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline + +METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ; +METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ; + +METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ; +METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ; + +! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ; +! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ; + +! METHOD:: move-left-by ( SEQ:sequence X:number -- ) +! SEQ { X 0 } { -1 0 } v* move-by ; + +METHOD: distance ( sequence sequence -- dist ) v- norm ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A class for objects with a position + +TUPLE: pos ; + +METHOD: x ( -- x ) pos>> first ; +METHOD: y ( -- y ) pos>> second ; + +METHOD: (x!) ( number -- ) pos>> set-first ; +METHOD: (y!) ( number -- ) pos>> set-second ; + +METHOD: to-the-left-of? ( number -- ? ) [ x ] dip < ; +METHOD: to-the-right-of? ( number -- ? ) [ x ] dip > ; + +METHOD: move-left-by ( number -- ) [ pos>> ] dip move-left-by ; +METHOD: move-right-by ( number -- ) [ pos>> ] dip move-right-by ; + +METHOD: above? ( number -- ? ) [ y ] dip > ; +METHOD: below? ( number -- ? ) [ y ] dip < ; + +METHOD: move-by ( sequence -- ) '[ _ v+ ] change-pos drop ; + +METHOD: distance ( -- dist ) [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A class for objects with velocity. It inherits from . Hey, if +! it's moving it has a position right? Unless it's some alternate universe... + +TUPLE: < vel ; + +: moving-up? ( obj -- ? ) vel>> y 0 > ; +: moving-down? ( obj -- ? ) vel>> y 0 < ; + +: step-size ( vel time -- dist ) [ vel>> ] dip v*n ; +: move-for ( vel time -- ) dupd step-size move-by ; + +: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! The 'pos' slot indicates the lower left hand corner of the +! rectangle. The 'dim' is holds the width and height. + +TUPLE: < dim ; + +METHOD: width ( -- width ) dim>> first ; +METHOD: height ( -- height ) dim>> second ; + +METHOD: left ( -- x ) x ; +METHOD: right ( -- x ) \\ x width bi + ; +METHOD: bottom ( -- y ) y ; +METHOD: top ( -- y ) \\ y height bi + ; + +: bottom-left ( rectangle -- pos ) pos>> ; + +: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ; +: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ; + +: center ( rectangle -- seq ) \\ center-x center-y bi 2array ; + +METHOD: to-the-left-of? ( -- ? ) \\ x left bi* < ; +METHOD: to-the-right-of? ( -- ? ) \\ x right bi* > ; + +METHOD: below? ( -- ? ) \\ y bottom bi* < ; +METHOD: above? ( -- ? ) \\ y top bi* > ; + +METHOD: horizontal-interval ( -- interval ) + \\ left right bi [a,b] ; + +METHOD: in-between-horizontally? ( -- ? ) + \\ x horizontal-interval bi* interval-contains? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: left right bottom top ; + +METHOD: left ( -- left ) left>> ; +METHOD: right ( -- right ) right>> ; +METHOD: bottom ( -- bottom ) bottom>> ; +METHOD: top ( -- top ) top>> ; + +METHOD: width ( -- width ) \\ right>> left>> bi - ; +METHOD: height ( -- height ) \\ top>> bottom>> bi - ; + +! METHOD: to-extent ( -- ) +! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; + diff --git a/extra/multi-method-syntax/multi-method-syntax.factor b/extra/multi-method-syntax/multi-method-syntax.factor new file mode 100644 index 0000000000..9f05525f23 --- /dev/null +++ b/extra/multi-method-syntax/multi-method-syntax.factor @@ -0,0 +1,23 @@ + +USING: accessors effects.parser kernel lexer multi-methods + parser sequences words ; + +IN: multi-method-syntax + +! A nicer specializer syntax to hold us over till multi-methods go in +! officially. +! +! Use both 'multi-methods' and 'multi-method-syntax' in that order. + +: scan-specializer ( -- specializer ) + + scan drop ! eat opening parenthesis + + ")" parse-effect in>> [ search ] map ; + +: CREATE-METHOD ( -- method ) + scan-word scan-specializer swap create-method-in ; + +: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ; + +: METHOD: (METHOD:) define ; parsing \ No newline at end of file diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor new file mode 100644 index 0000000000..befb64a7a7 --- /dev/null +++ b/extra/pong/pong.factor @@ -0,0 +1,195 @@ + +USING: kernel accessors locals math math.intervals math.order + namespaces sequences threads + ui + ui.gadgets + ui.gestures + ui.render + calendar + multi-methods + multi-method-syntax + combinators.short-circuit.smart + combinators.cleave.enhanced + processing.shapes + flatland ; + +IN: pong + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: clamp-to-interval ( x interval -- x ) + [ from>> first max ] [ to>> first min ] bi ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < ; +TUPLE: < ; + +TUPLE: < { speed initial: 10 } ; + +: computer-move-left ( computer -- ) dup speed>> move-left-by ; +: computer-move-right ( computer -- ) dup speed>> move-right-by ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < + { diameter initial: 20 } + { bounciness initial: 1.2 } + { max-speed initial: 10 } ; + +: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ; +: below-upper-bound? ( ball field -- ? ) top 50 + below? ; + +: in-bounds? ( ball field -- ? ) + { + [ above-lower-bound? ] + [ below-upper-bound? ] + } && ; + +:: bounce-change-vertical-velocity ( BALL -- ) + + BALL vel>> y neg + BALL bounciness>> * + + BALL max-speed>> min + + BALL vel>> (y!) ; + +:: bounce-off-paddle ( BALL PADDLE -- ) + + BALL bounce-change-vertical-velocity + + BALL x PADDLE center x - 0.25 * BALL vel>> (x!) + + PADDLE top BALL pos>> (y!) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mouse-x ( -- x ) hand-loc get first ; + +:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval ) + + PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ; + +:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- ) + + mouse-x + + PADDLE PLAY-FIELD valid-paddle-interval + + clamp-to-interval + + PADDLE pos>> (x!) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Protocol for drawing PONG objects + +GENERIC: draw ( obj -- ) + +METHOD: draw ( -- ) [ bottom-left ] [ dim>> ] bi rectangle ; +METHOD: draw ( -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided + ! by multi-methods + +TUPLE: < gadget draw closed ; + +M: pref-dim* ( -- dim ) drop { 400 400 } ; +M: draw-gadget* ( -- ) draw>> call ; +M: ungraft* ( -- ) t >>closed drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-draw-closure ( -- closure ) + + ! Establish some bindings + + [let | PLAY-FIELD [ T{ { pos { 0 0 } } { dim { 400 400 } } } ] + BALL [ T{ { pos { 50 50 } } { vel { 3 4 } } } ] + + PLAYER [ T{ { pos { 200 396 } } { dim { 75 4 } } } ] + COMPUTER [ T{ { pos { 200 0 } } { dim { 75 4 } } } ] | + + ! Define some internal words in terms of those bindings ... + + [wlet | align-player-with-mouse [ ( -- ) + PLAYER PLAY-FIELD align-paddle-with-mouse ] + + move-ball [ ( -- ) BALL 1 move-for ] + + player-blocked-ball? [ ( -- ? ) + BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ] + + computer-blocked-ball? [ ( -- ? ) + BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ] + + bounce-off-wall? [ ( -- ? ) + BALL PLAY-FIELD in-between-horizontally? not ] | + + ! Note, we're returning a quotation. + ! The quotation closes over the bindings established by the 'let'. + ! Thus the name of the word 'make-draw-closure'. + ! This closure is intended to be placed in the 'draw' slot of a + ! gadget. + + [ + + BALL PLAY-FIELD in-bounds? + [ + align-player-with-mouse + + move-ball + + ! computer reaction + + BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when + BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when + + ! check if ball bounced off something + + player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when + computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when + bounce-off-wall? [ BALL reverse-horizontal-velocity ] when + + ! draw the objects + + COMPUTER draw + PLAYER draw + BALL draw + + ] + when + + ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround. + ! The stack effects in the wlet expression throw + ! off the effect for the whole word, so we reset + ! it to the correct one here. + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: pong-loop-step ( PONG -- ? ) + PONG closed>> + [ f ] + [ PONG relayout-1 25 milliseconds sleep t ] + if ; + +:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: play-pong ( -- ) + + new-gadget + make-draw-closure >>draw + dup "PONG" open-window + + start-pong-thread ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: play-pong-main ( -- ) [ play-pong ] with-ui ; + +MAIN: play-pong-main \ No newline at end of file