diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 28f27c5650..31d5f86979 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -39,6 +39,7 @@ - inform-compile dies with funny error - amd64 %unbox-struct +- amd64 %write-barrier - float intrinsics - complex float type - complex float intrinsics diff --git a/examples/factoroids/actors.factor b/examples/factoroids/actors.factor deleted file mode 100644 index 85f4e0acc3..0000000000 --- a/examples/factoroids/actors.factor +++ /dev/null @@ -1,88 +0,0 @@ -USING: arrays gadgets generic hashtables io kernel math -namespaces opengl prettyprint sdl sequences threads ; -IN: factoroids - -SYMBOL: player -SYMBOL: actors - -: add-actor dup actors get push ; - -: remove-actor actors get delete ; - -: 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 - default-priority over set-actor-priority ; - -GENERIC: can-collide* ( actor actor -- ? ) - -M: actor can-collide* ( actor actor -- ) 2drop t ; - -GENERIC: collision - -M: actor collision ( actor actor -- ) drop remove-actor ; - -: 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 1 <= - [ 2dup collision 2dup swap collision ] when 2drop ; - -: ?collisions ( actor -- ) - dup collidable [ ?collision ] each-with ; - -: ?expire-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 - dup dup actor-ai ai-tick - body-tick ; - -: draw-actor ( actor -- ) - GL_MODELVIEW [ - dup body-position gl-translate - dup body-angle over body-up gl-rotate - dup body-size gl-scale - dup actor-colors swap actor-model draw-model - ] do-matrix ; - -: spawn-big-block ( position -- ) - >r cube { { 1/2 1/2 1 1 } } r> 360 random-int { 3 3 3 } 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 ; diff --git a/examples/factoroids/ai.factor b/examples/factoroids/ai.factor deleted file mode 100644 index 48ea59b4d9..0000000000 --- a/examples/factoroids/ai.factor +++ /dev/null @@ -1,52 +0,0 @@ -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 deleted file mode 100644 index 4c9176b86f..0000000000 --- a/examples/factoroids/bodies.factor +++ /dev/null @@ -1,70 +0,0 @@ -USING: arrays gadgets generic hashtables io kernel math -namespaces opengl sdl sequences threads ; -IN: factoroids - -TUPLE: body position velocity acceleration size up angle -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 - [ set-body-position ] keep - { 0 1 0 } over set-body-up - 0 over set-body-velocity - 0 over set-body-acceleration - 0 over set-body-angle-delta - dup update-direction ; - -: scaled-angle-delta ( time body -- x ) body-angle-delta * ; - -: scaled-acceleration ( time body -- x ) body-acceleration * ; - -: scaled-velocity ( time body -- x ) - [ body-velocity * ] keep body-direction n*v ; - -: friction 0.95 ; - -: update-angle ( time body -- ) - [ [ scaled-angle-delta ] keep body-angle + ] keep - set-body-angle ; - -: update-velocity ( time body -- ) - [ - [ scaled-acceleration ] keep body-velocity + friction * - ] keep set-body-velocity ; - -: update-position ( time body -- ) - [ [ scaled-velocity ] keep body-position v+ ] keep - set-body-position ; - -: body-tick ( time body -- ) - [ update-angle ] 2keep - [ update-velocity ] 2keep - [ update-position ] keep - update-direction ; - -: camera-position ( player -- vec ) - dup body-position swap body-direction 3 v*n v- { 0 1 0 } v+ ; - -: camera-look-at ( player -- vec ) - dup body-position swap body-direction 2 v*n v+ ; - -: camera-modelview ( player -- ) - GL_MODELVIEW glMatrixMode - glLoadIdentity - dup camera-position - over camera-look-at - 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 deleted file mode 100644 index 41e3411ebc..0000000000 --- a/examples/factoroids/factoroids.factor +++ /dev/null @@ -1,82 +0,0 @@ -USING: arrays gadgets generic hashtables io kernel math -namespaces opengl sdl sequences styles threads ; -IN: factoroids - -: draw-sky - flat-projection - { 0 1 0 } { { 0 0 1/3 1 } { 2/3 2/3 1 1 } } { 1 1/2 0 } gl-gradient ; - -: make-sky-list ( -- id ) - GL_COMPILE [ draw-sky ] make-dlist ; - -: draw-ground - GL_DEPTH_TEST glDisable - { 0.0 0.0 0.0 1.0 } gl-color - GL_QUADS [ - { -1000 0 -1000 } gl-vertex - { -1000 0 1000 } gl-vertex - { 1000 0 1000 } gl-vertex - { 1000 0 -1000 } gl-vertex - ] do-state - GL_DEPTH_TEST glEnable ; - -: (grid-square) ( -- ) - GL_POINTS [ - 5 [ { 1 0 0 } n*v gl-vertex ] each - 5 [ { 0 0 1 } n*v gl-vertex ] each - ] do-state ; - -: grid-square ( w h -- ) - GL_MODELVIEW [ - [ 5 * ] 2apply 0 swap glTranslated - (grid-square) - ] do-matrix ; - -: draw-grid ( w h -- ) - { 1.0 1.0 1.0 1.0 } gl-color [ swap [ grid-square ] each-with ] each-with ; - -: make-ground-list ( -- id ) - GL_COMPILE [ draw-ground 50 50 draw-grid ] make-dlist ; - -SYMBOL: sky-list -SYMBOL: ground-list - -: init-dlists - make-sky-list sky-list set - make-ground-list ground-list set ; - -: draw-factoroids - [ - factoroids-gl - sky-list get glCallList - world-projection - player get camera-modelview - ground-list get glCallList - draw-actors - ] with-gl-surface ; - -SYMBOL: last-frame - -: advance-clock ( -- time ) - millis last-frame get over last-frame set - 30 min ; - -: run-game ( -- ) - advance-clock tick-actors - draw-factoroids - 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 [ - init-dlists millis last-frame set run-game - ] with-gl-screen ; diff --git a/examples/factoroids/input.factor b/examples/factoroids/input.factor deleted file mode 100644 index cb4c028940..0000000000 --- a/examples/factoroids/input.factor +++ /dev/null @@ -1,52 +0,0 @@ -IN: factoroids -USING: alien generic hashtables io kernel math namespaces sdl -sequences ; - -: fire ( -- ) - player get [ - dup body-position over body-direction 3 v*n v+ - swap body-angle - ] keep spawn-rocket ; - -: turn-left ( ? actor -- ) - swap [ 1 ] [ dup body-angle-delta 0 < -1 0 ? ] if 30 /f - swap set-body-angle-delta ; - -: turn-right ( ? actor -- ) - swap [ -1 ] [ dup body-angle-delta 0 > 1 0 ? ] if 30 /f - swap set-body-angle-delta ; - -: forward ( ? actor -- ) - swap [ 1 ] [ dup body-acceleration 0 < -1 0 ? ] if 6000 /f - swap set-body-acceleration ; - -: backward ( ? actor -- ) - swap [ -1 ] [ dup body-acceleration 0 > 1 0 ? ] if 60000 /f - swap set-body-acceleration ; - -: binding ( binding -- { down up } ) - keyboard-event>binding H{ - [[ [ "SPACE" ] { [ fire ] [ ] } ]] - [[ [ "LEFT" ] { [ t player get turn-left ] [ f player get turn-left ] } ]] - [[ [ "RIGHT" ] { [ t player get turn-right ] [ f player get turn-right ] } ]] - [[ [ "UP" ] { [ t player get forward ] [ f player get forward ] } ]] - [[ [ "DOWN" ] { [ t player get backward ] [ f player get backward ] } ]] - } hash ; - -GENERIC: handle-event ( event -- quit? ) - -M: object handle-event ( event -- quit? ) - drop f ; - -M: quit-event handle-event ( event -- quit? ) - drop t ; - -M: key-down-event handle-event ( event -- quit? ) - binding first call f ; - -M: key-up-event handle-event ( event -- quit? ) - binding second call f ; - -: check-event ( -- ? ) - "event" dup SDL_PollEvent - [ handle-event ] [ drop f ] if ; diff --git a/examples/factoroids/load.factor b/examples/factoroids/load.factor deleted file mode 100644 index f4fbfc18c5..0000000000 --- a/examples/factoroids/load.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: kernel io parser sequences ; - -{ - "utils" - "models" - "bodies" - "actors" - "projectiles" - "ai" - "input" - "factoroids" -} [ "/examples/factoroids/" swap ".factor" append3 run-resource ] each - -"To play Factoroids, enter the following in the listener:" print -terpri -" USE: factoroids" print -" factoroids" print diff --git a/examples/factoroids/models.factor b/examples/factoroids/models.factor deleted file mode 100644 index 1056acad63..0000000000 --- a/examples/factoroids/models.factor +++ /dev/null @@ -1,142 +0,0 @@ -USING: arrays gadgets generic hashtables io kernel math -namespaces opengl sdl sequences threads ; -IN: factoroids - -TUPLE: face color normal polygon ; - -: draw-face ( colors face -- ) - [ face-color swap nth gl-color ] keep - ( dup face-normal gl-normal ) - face-polygon gl-fill-poly ; - -TUPLE: model faces ; - -: draw-model ( colors model -- ) - model-faces [ draw-face ] each-with ; - -: cube - T{ model f - { - T{ face f - 0 - { 0 0 -1 } - { - { -1/2 -1/2 -1/2 } - { 1/2 -1/2 -1/2 } - { 1/2 1/2 -1/2 } - { -1/2 1/2 -1/2 } - } - } - - T{ face f - 0 - { 0 0 1 } - { - { -1/2 -1/2 1/2 } - { 1/2 -1/2 1/2 } - { 1/2 1/2 1/2 } - { -1/2 1/2 1/2 } - } - } - - T{ face f - 0 - { -1 0 0 } - { - { -1/2 -1/2 -1/2 } - { -1/2 -1/2 1/2 } - { -1/2 1/2 1/2 } - { -1/2 1/2 -1/2 } - } - } - - T{ face f - 0 - { 1 0 0 } - { - { 1/2 -1/2 -1/2 } - { 1/2 -1/2 1/2 } - { 1/2 1/2 1/2 } - { 1/2 1/2 -1/2 } - } - } - - T{ face f - 0 - { 0 -1 0 } - { - { -1/2 -1/2 -1/2 } - { -1/2 -1/2 1/2 } - { 1/2 -1/2 1/2 } - { 1/2 -1/2 -1/2 } - } - } - - T{ face f - 0 - { 0 1 0 } - { - { -1/2 1/2 -1/2 } - { -1/2 1/2 1/2 } - { 1/2 1/2 1/2 } - { 1/2 1/2 -1/2 } - } - } - } - } ; - -: factoroid - T{ model f - { - T{ face f - 1 - f - { - { -1/3 1/2 -1/2 } - { 1/3 1/2 -1/2 } - { 1/2 -1/2 -1/2 } - { -1/2 -1/2 -1/2 } - } - } - - T{ face f - 0 - f - { - { -1/3 1/2 -1/2 } - { -1/2 -1/2 -1/2 } - { 0 -1/2 1/2 } - } - } - - T{ face f - 0 - f - { - { 1/3 1/2 -1/2 } - { 1/2 -1/2 -1/2 } - { 0 -1/2 1/2 } - } - } - - T{ face f - 0 - f - { - { -1/3 1/2 -1/2 } - { 1/3 1/2 -1/2 } - { 0 -1/2 1/2 } - } - } - - T{ face f - 0 - f - { - { -1/2 -1/2 -1/2 } - { -1/2 -1/2 -1/2 } - { 0 -1/2 1/2 } - } - } - } - } ; diff --git a/examples/factoroids/projectiles.factor b/examples/factoroids/projectiles.factor deleted file mode 100644 index 177f8b4eee..0000000000 --- a/examples/factoroids/projectiles.factor +++ /dev/null @@ -1,79 +0,0 @@ -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/examples/factoroids/utils.factor b/examples/factoroids/utils.factor deleted file mode 100644 index 97d5d95a4f..0000000000 --- a/examples/factoroids/utils.factor +++ /dev/null @@ -1,51 +0,0 @@ -IN: factoroids -USING: alien kernel math namespaces opengl sdl sequences ; - -: deg>rad pi * 180 / ; inline - -: rad>deg 180 * pi / ; inline - -: flat-projection - GL_PROJECTION glMatrixMode - glLoadIdentity - 0 1 1 0 gluOrtho2D - GL_DEPTH_TEST glDisable - GL_MODELVIEW glMatrixMode - glLoadIdentity - GL_LIGHTING glDisable - ; - -: >float-array ( seq -- float-array ) - dup length dup "float" -rot - [ pick set-float-nth ] 2each ; - -: light-source - GL_LIGHTING glEnable - GL_LIGHT0 glEnable - GL_LIGHT0 GL_POSITION { 1 1 1 0 } >float-array glLightfv - GL_LIGHT0 GL_DIFFUSE { 1 0 0 1 } >float-array glLightfv - GL_LIGHT0 GL_SPECULAR { 1 1 1 1 } >float-array glLightfv - GL_LIGHT0 GL_AMBIENT { 0.1 0.1 0.1 1 } >float-array glLightfv ; - -: world-projection - GL_PROJECTION glMatrixMode - glLoadIdentity - 50 width get height get / 1 30 gluPerspective - GL_DEPTH_TEST glEnable - GL_MODELVIEW glMatrixMode - glLoadIdentity ; - -: factoroids-gl ( -- ) - 0.0 0.0 0.0 0.0 glClearColor - { 1.0 0.0 0.0 0.0 } gl-color - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - 0 0 width get height get glViewport - GL_SMOOTH glShadeModel - GL_PROJECTION glMatrixMode - glLoadIdentity ; - -: gl-normal ( normal -- ) first3 glNormal3d ; - -: gl-rotate first3 glRotated ; - -: gl-scale first3 glScaled ; diff --git a/library/cocoa/subclassing.factor b/library/cocoa/subclassing.factor index 14f5b4d443..53d7cf1244 100644 --- a/library/cocoa/subclassing.factor +++ b/library/cocoa/subclassing.factor @@ -6,25 +6,26 @@ libc math namespaces sequences strings ; : encode-types ( return types -- encoding ) >r 1array r> append - [ alien>objc-types get hash ] map >string ; + [ [ alien>objc-types get hash , CHAR: 0 , ] each ] "" make ; : prepare-method ( { name return types quot } -- sel type imp ) [ first3 encode-types >r sel_registerName r> ] keep - [ % \ alien-callback , ] [ ] make compile-1 ; + [ 1 swap tail % \ alien-callback , ] [ ] make ; : init-method ( method alien -- ) >r prepare-method r> - [ set-objc-method-imp ] keep - [ set-objc-method-types ] keep + [ >r compile-1 r> set-objc-method-imp ] keep + [ >r r> set-objc-method-types ] keep set-objc-method-name ; : ( n -- alien ) "objc-method-list" c-size - "objc-method" c-size rot * + 1 calloc ; + "objc-method" c-size pick * + 1 calloc + [ set-objc-method-list-count ] keep ; : ( methods -- alien ) dup length dup -rot - [ pick objc-method-nth init-method ] 2each ; + [ pick method-list@ objc-method-nth init-method ] 2each ; : ( methods -- lists ) alien-address