diff --git a/examples/factoroids/actors.factor b/examples/factoroids/actors.factor index 4d44f90e0d..85f4e0acc3 100644 --- a/examples/factoroids/actors.factor +++ b/examples/factoroids/actors.factor @@ -9,42 +9,46 @@ SYMBOL: actors : remove-actor actors get delete ; -TUPLE: actor model colors up expiry ; +: default-priority 0 ; +: projectile-priority 1 ; +: powerup-priority 1 ; + +! model: see models.factor +! colors: a sequence to color parts of the model +! up: an orientation vector for rotation +! expiry: f or a time when the actor will cease to exist +! shield: f if invincible, otherwise an integer +! max-shield: shield is set to max-shield when we recharge +! priority: when two actors collide, the one with highest +! priority has its collision generic word called +! ai: object responding to ai-tick generic +TUPLE: actor model colors up expiry shield max-shield priority ai ; C: actor ( model colors position angle size -- actor ) [ >r r> set-delegate ] keep [ set-actor-colors ] keep - [ set-actor-model ] keep ; - -TUPLE: projectile owner ; - -C: projectile ( actor owner -- projectile ) - [ set-projectile-owner ] keep - [ set-delegate ] keep ; + [ set-actor-model ] keep + default-priority over set-actor-priority ; GENERIC: can-collide* ( actor actor -- ? ) -M: projectile can-collide* ( actor actor -- ? ) - over projectile? >r projectile-owner eq? r> or not ; - M: actor can-collide* ( actor actor -- ) 2drop t ; GENERIC: collision M: actor collision ( actor actor -- ) drop remove-actor ; -: can-collide? ( actor actor -- ? ) - 2dup eq? [ - 2drop f - ] [ - 2dup can-collide* >r swap can-collide* r> and - ] if ; +: can-collide? ( a1 a2 -- ? ) + #! If true, a collision test is performed, and a2's + #! collision generic is called. + 2dup eq? >r over actor-priority over actor-priority > r> or + [ 2drop f ] [ can-collide* ] if ; : collidable ( actor -- seq ) actors get [ can-collide? ] subset-with ; : ?collision ( actor actor -- ) - 2dup [ body-position ] 2apply v- norm 2 <= + 2dup [ body-position ] 2apply v- norm 1 <= [ 2dup collision 2dup swap collision ] when 2drop ; : ?collisions ( actor -- ) @@ -54,8 +58,14 @@ M: actor collision ( actor actor -- ) drop remove-actor ; dup actor-expiry [ millis <= [ dup remove-actor ] when ] when* drop ; +GENERIC: ai-tick + +M: f ai-tick ( actor ai -- ) 2drop ; + : actor-tick ( time actor -- ) - dup ?expire-actor dup ?collisions body-tick ; + dup ?expire-actor dup ?collisions + dup dup actor-ai ai-tick + body-tick ; : draw-actor ( actor -- ) GL_MODELVIEW [ @@ -68,27 +78,11 @@ M: actor collision ( actor actor -- ) drop remove-actor ; : spawn-big-block ( position -- ) >r cube { { 1/2 1/2 1 1 } } r> 360 random-int { 3 3 3 } add-actor ; -: init-actors - V{ } clone actors set - { 15 3 25 } spawn-big-block - { 20 2 25 } spawn-big-block - { 30 1 20 } spawn-big-block - { 30 1/2 15 } spawn-big-block - factoroid { { 1 0 0 1 } { 2/3 0 0 1 } } { 25 1/2 25 } 0 { 3/4 1/4 2 } player set - player get add-actor ; +: ( position -- ) + >r factoroid { { 1 0 0 1 } { 2/3 0 0 1 } } r> 0 { 3/4 1/4 2 } ; : draw-actors actors get [ draw-actor ] each ; : tick-actors ( time -- ) actors get clone [ actor-tick ] each-with ; - -: add-expiring-actor ( actor time-to-live -- ) - millis + over set-actor-expiry add-actor ; - -: ( position angle owner -- rocket ) - >r >r >r rocket { { 1 1 0 1 } { 1 1 1 1 } } r> r> { 1/2 1/2 5 } - r> 1/2000 over set-body-acceleration ; - -: spawn-rocket ( position angle owner -- ) - 1000 add-expiring-actor ; diff --git a/examples/factoroids/ai.factor b/examples/factoroids/ai.factor new file mode 100644 index 0000000000..48ea59b4d9 --- /dev/null +++ b/examples/factoroids/ai.factor @@ -0,0 +1,52 @@ +USING: arrays gadgets generic hashtables io kernel math +namespaces opengl prettyprint sdl sequences threads ; +IN: factoroids + +! The approach AI moves the player towards a certain point +TUPLE: approach point ; + +: turn-toward ( point actor -- ) + [ body-perp v. sgn 30 /f ] keep set-body-angle-delta ; + +: approached? ( actor ai -- ? ) + approach-point >r body-position r> v- norm-sq 4 <= ; + +M: approach ai-tick ( actor ai -- ) + 2dup approached? [ + drop + 0 over set-body-acceleration + 0 swap set-body-angle-delta + ] [ + approach-point over turn-toward + drop + ! 1 60000 /f swap set-body-acceleration + ] if ; + +! The dumbass just wanders around, approaching random points +TUPLE: dumbass ; + +C: dumbass ( -- dumbass ) f over set-delegate ; + +: init-dumbass ( actor ai -- ) + swap body-position + 10 random-int 5 - 10 random-int 5 - 0 3array v+ + swap set-approach-point ; + +M: dumbass ai-tick ( actor ai -- ) + dup approach-point [ + 2dup approached? + [ init-dumbass ] [ delegate ai-tick ] if + ] [ + init-dumbass + ] if ; + +! The follower follows an actor +TUPLE: follower actor ; + +C: follower ( actor -- follower ) + [ set-follower-actor ] keep + f over set-delegate ; + +M: follower ai-tick ( actor ai -- ) + dup follower-actor body-position over set-approach-point + delegate ai-tick ; diff --git a/examples/factoroids/bodies.factor b/examples/factoroids/bodies.factor index 97956ef38d..c36c2ae415 100644 --- a/examples/factoroids/bodies.factor +++ b/examples/factoroids/bodies.factor @@ -7,10 +7,6 @@ angle-delta direction ; GENERIC: tick ( time obj -- ) -: update-direction ( body -- ) - dup body-angle deg>rad dup sin swap cos 0 swap 3array - swap set-body-direction ; - C: body ( position angle size -- ) [ set-body-size ] keep [ set-body-angle ] keep @@ -43,6 +39,10 @@ C: body ( position angle size -- ) [ [ scaled-velocity ] keep body-position v+ ] keep set-body-position ; +: update-direction ( body -- ) + dup body-angle deg>rad dup sin swap cos 0 swap 3array + swap set-body-direction ; + : body-tick ( time body -- ) [ update-angle ] 2keep [ update-velocity ] 2keep @@ -63,3 +63,8 @@ C: body ( position angle size -- ) rot body-up >r >r first3 r> first3 r> first3 gluLookAt ; + +: body-perp ( v -- v ) + #! Return a vector perpendicular to the direction vector + #! and also perpendicular to the y axis. + body-direction first3 swap >r neg swap r> swap 3array ; diff --git a/examples/factoroids/factoroids.factor b/examples/factoroids/factoroids.factor index 2d7af83e7c..04fb203853 100644 --- a/examples/factoroids/factoroids.factor +++ b/examples/factoroids/factoroids.factor @@ -66,6 +66,15 @@ SYMBOL: last-frame 2 sleep check-event [ run-game ] unless ; +: init-actors + V{ } clone actors set + { 25 1/2 25 } player set + { 30 1/2 30 } player get over set-actor-ai add-actor + { 15 1/2 30 } player get over set-actor-ai add-actor + { 10 1/2 30 } over set-actor-ai add-actor + { 5 1/2 30 } over set-actor-ai add-actor + player get add-actor ; + : factoroids init-actors 800 600 [ diff --git a/examples/factoroids/load.factor b/examples/factoroids/load.factor index 7088cea35d..1c9b13d4f6 100644 --- a/examples/factoroids/load.factor +++ b/examples/factoroids/load.factor @@ -4,6 +4,8 @@ USING: io parser ; "examples/factoroids/models.factor" run-file "examples/factoroids/bodies.factor" run-file "examples/factoroids/actors.factor" run-file +"examples/factoroids/projectiles.factor" run-file +"examples/factoroids/ai.factor" run-file "examples/factoroids/input.factor" run-file "examples/factoroids/factoroids.factor" run-file diff --git a/examples/factoroids/models.factor b/examples/factoroids/models.factor index 34b3335d5d..1056acad63 100644 --- a/examples/factoroids/models.factor +++ b/examples/factoroids/models.factor @@ -140,59 +140,3 @@ TUPLE: model faces ; } } } ; - -: rocket - T{ model f - { - T{ face f - 0 - { 0 -1 0 } - { - { -1/2 0 -1/2 } - { 0 1/2 -1/2 } - { 1/2 0 -1/2 } - { 0 -1/2 -1/2 } - } - } - - T{ face f - 1 - f - { - { -1/2 0 -1/2 } - { 0 1/2 -1/2 } - { 0 0 1/2 } - } - } - - T{ face f - 1 - f - { - { 0 1/2 -1/2 } - { 1/2 0 -1/2 } - { 0 0 1/2 } - } - } - - T{ face f - 1 - f - { - { 1/2 0 -1/2 } - { 0 -1/2 -1/2 } - { 0 0 1/2 } - } - } - - T{ face f - 1 - f - { - { 0 -1/2 -1/2 } - { -1/2 0 -1/2 } - { 0 0 1/2 } - } - } - } - } ; diff --git a/examples/factoroids/projectiles.factor b/examples/factoroids/projectiles.factor new file mode 100644 index 0000000000..177f8b4eee --- /dev/null +++ b/examples/factoroids/projectiles.factor @@ -0,0 +1,79 @@ +USING: arrays gadgets generic hashtables io kernel math +namespaces opengl prettyprint sdl sequences threads ; +IN: factoroids + +: add-expiring-actor ( actor time-to-live -- ) + millis + over set-actor-expiry add-actor ; + +TUPLE: projectile owner ; + +C: projectile ( actor owner -- projectile ) + [ set-projectile-owner ] keep + [ set-delegate ] keep + projectile-priority over set-actor-priority ; + +M: projectile can-collide* ( actor actor -- ? ) + over projectile? >r projectile-owner eq? r> or not ; + +: rocket + T{ model f + { + T{ face f + 0 + { 0 -1 0 } + { + { -1/2 0 -1/2 } + { 0 1/2 -1/2 } + { 1/2 0 -1/2 } + { 0 -1/2 -1/2 } + } + } + + T{ face f + 1 + f + { + { -1/2 0 -1/2 } + { 0 1/2 -1/2 } + { 0 0 1/2 } + } + } + + T{ face f + 1 + f + { + { 0 1/2 -1/2 } + { 1/2 0 -1/2 } + { 0 0 1/2 } + } + } + + T{ face f + 1 + f + { + { 1/2 0 -1/2 } + { 0 -1/2 -1/2 } + { 0 0 1/2 } + } + } + + T{ face f + 1 + f + { + { 0 -1/2 -1/2 } + { -1/2 0 -1/2 } + { 0 0 1/2 } + } + } + } + } ; + +: ( position angle owner -- rocket ) + >r >r >r rocket { { 1 1 0 1 } { 1 1 1 1 } } r> r> { 1/2 1/2 5 } + r> 1/2000 over set-body-acceleration ; + +: spawn-rocket ( position angle owner -- ) + 1000 add-expiring-actor ; diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 992f2e2048..ce2964008c 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -132,12 +132,8 @@ M: alien-node linearize* ( node -- ) [ dup parameters stack-space %cleanup , ] unless dup linearize-return linearize-next ; -: unpair ( seq -- odds evens ) - 2 swap group flip dup empty? - [ drop { } { } ] [ first2 ] if ; - : parse-arglist ( lst -- types stack effect ) - unpair [ + 2 swap group unpair [ " " % [ "," ?tail drop % " " % ] each "-- " % ] "" make ; diff --git a/library/alien/syntax.factor b/library/alien/syntax.factor index 4c7579c1d2..2b4541e133 100644 --- a/library/alien/syntax.factor +++ b/library/alien/syntax.factor @@ -13,7 +13,6 @@ sequences words ; ! ! : glTranslatef ( x y z -- ) ! "void" "gl" "glTranslatef" [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ; -! \ glTranslatef compile ! ! other forms: ! diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 045de71e5a..15a50a607e 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -121,7 +121,7 @@ M: object peek ( sequence -- element ) : pop* ( sequence -- ) #! Shorten the sequence by one element. [ length 1- ] keep - [ f -rot set-nth ] 2keep + [ 0 -rot set-nth ] 2keep set-length ; : pop ( sequence -- element ) diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index b468cb3263..0b3a9a3e7b 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -52,7 +52,7 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; : (group) ( n seq -- ) 2dup length >= [ - dup like , drop + dup empty? [ 2drop ] [ dup like , drop ] if ] [ 2dup head , dupd tail-slice (group) ] if ; @@ -106,6 +106,9 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; 2dup mismatch dup -1 = [ drop 2dup min-length ] when tuck swap tail-slice >r swap tail-slice r> ; +: unpair ( seq -- firsts seconds ) + flip dup empty? [ drop { } { } ] [ first2 ] if ; + IN: strings : completion? ( partial completion quot -- ? ) diff --git a/library/inference/inline-methods.factor b/library/inference/inline-methods.factor index b157087827..276f31cfc2 100644 --- a/library/inference/inline-methods.factor +++ b/library/inference/inline-methods.factor @@ -19,7 +19,11 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; [ swap ?hash [ object ] unless* ] map-with ; : dispatching-classes ( node -- seq ) - dup dup node-param dispatching-values node-classes* ; + dup node-in-d empty? [ + drop { } + ] [ + dup dup node-param dispatching-values node-classes* + ] if ; : already-inlined? ( node -- ? ) #! Was this node inlined from definition of 'word'? diff --git a/library/opengl/opengl-utils.factor b/library/opengl/opengl-utils.factor index ead4cfa6c0..dcd99d945a 100644 --- a/library/opengl/opengl-utils.factor +++ b/library/opengl/opengl-utils.factor @@ -64,9 +64,6 @@ USING: alien errors kernel math namespaces opengl sdl sequences ; : four-sides ( dim -- ) dup top-left dup top-right dup bottom-right bottom-left ; -: gl-line ( from to color -- ) - gl-color [ gl-vertex ] 2apply ; - : gl-fill-rect ( dim -- ) #! Draws a two-dimensional box. GL_QUADS [ four-sides ] do-state ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 4aedfd981b..f0aabc9583 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -211,7 +211,7 @@ M: real pprint* ( obj -- ) number>string f text ; : ch>unicode-escape ( ch -- esc ) >hex 4 CHAR: 0 pad-left "\\u" swap append ; -: unparse-ch ( ch -- ch/str ) +: unparse-ch ( ch -- ) dup quotable? [ , ] [ diff --git a/library/test/collections/sequences.factor b/library/test/collections/sequences.factor index e94bbfac39..038eb615f2 100644 --- a/library/test/collections/sequences.factor +++ b/library/test/collections/sequences.factor @@ -205,3 +205,5 @@ unit-test ] unit-test [ 1 ] [ 1/2 { 1 2 3 } nth ] unit-test + +[ { } ] [ 0 { } group ] unit-test diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 338c5faf07..685ee7d943 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -1,7 +1,7 @@ -IN: temporary USING: arrays assembler compiler compiler-backend generic hashtables inference kernel kernel-internals lists math optimizer prettyprint sequences strings test vectors words ; +IN: temporary : kill-1 [ 1 2 3 ] [ + ] over drop drop ; compiled @@ -205,3 +205,9 @@ TUPLE: pred-test ; : blah over cons? [ bleh >r 2cdr r> ] [ 2drop f f f ] if ; compiled [ f ] [ [ 1 2 3 ] [ 1 3 2 ] blah drop 2car = ] unit-test + +! regression +: (the-test) dup 0 > [ 1- (the-test) ] when ; inline +: the-test 2 dup (the-test) ; compiled + +[ 2 0 ] [ the-test ] unit-test diff --git a/library/test/prettyprint.factor b/library/test/prettyprint.factor index b7b1bc4102..8931dddbd9 100644 --- a/library/test/prettyprint.factor +++ b/library/test/prettyprint.factor @@ -61,7 +61,7 @@ unit-test TUPLE: cat gender declawed? castrated? ; -[ "T{ cat \n f \"m\" \n t f\n}" ] +[ "T{ cat \n f \"m\" \n t f\n}" ] [ [ 10 margin set diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 4660a63d96..d568156b1d 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -23,7 +23,7 @@ M: array rect-dim drop { 0 0 0 } ; : |v-| ( vec vec -- vec ) v- [ 0 max ] map ; -: ( loc ext ) dupd swap |v-| ; +: ( loc ext -- rect ) dupd swap |v-| ; : >absolute ( rect -- rect ) rect-bounds >r origin get v+ r> ;