From 84c7f10ab7dbc5e0d3d901b848ef018ddb39a86d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 12:53:01 -0500 Subject: [PATCH 01/10] factor game-input and game-loop mgmt out to a game-world base object --- extra/game-worlds/game-worlds.factor | 24 ++++++++++++++++++++++++ extra/terrain/terrain.factor | 27 ++++++++++----------------- 2 files changed, 34 insertions(+), 17 deletions(-) create mode 100644 extra/game-worlds/game-worlds.factor diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor new file mode 100644 index 0000000000..864bd28fc1 --- /dev/null +++ b/extra/game-worlds/game-worlds.factor @@ -0,0 +1,24 @@ +USING: accessors game-input game-loop kernel ui.gadgets +ui.gadgets.worlds ui.gestures ; +IN: game-worlds + +TUPLE: game-world < world + game-loop ; + +GENERIC: tick-length ( world -- millis ) + +M: game-world draw* + nip draw-world ; + +M: game-world begin-world + dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop + drop + open-game-input ; + +M: game-world end-world + close-game-input + [ [ stop-loop ] when* f ] change-game-loop + drop ; + +M: game-world focusable-child* drop t ; + diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d58aa4ec30..fe105b2e52 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,11 +1,11 @@ -USING: accessors arrays combinators game-input -game-input.scancodes game-loop grouping kernel literals locals +USING: accessors arrays combinators game-input game-loop +game-input.scancodes grouping kernel literals locals math math.constants math.functions math.matrices math.order math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats ; +ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] @@ -15,7 +15,6 @@ CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] -CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] CONSTANT: FRICTION 0.95 @@ -28,11 +27,13 @@ CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player location yaw pitch velocity ; -TUPLE: terrain-world < world +TUPLE: terrain-world < game-world player terrain terrain-segment terrain-texture terrain-program - terrain-vertex-buffer - game-loop ; + terrain-vertex-buffer ; + +M: terrain-world tick-length + drop 1000 30 /i ; : frustum ( dim -- -x x -y y near far ) dup first2 min v/n @@ -171,9 +172,6 @@ M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; -M: terrain-world draw* - nip draw-world ; - : set-heightmap-texture-parameters ( texture -- ) GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri @@ -181,7 +179,7 @@ M: terrain-world draw* GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; -M: terrain-world begin-world +BEFORE: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } require-gl-version-or-extensions GL_DEPTH_TEST glEnable @@ -195,14 +193,10 @@ M: terrain-world begin-world terrain-vertex-shader terrain-pixel-shader >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer - TICK-LENGTH over [ >>game-loop ] keep start-loop - open-game-input drop ; -M: terrain-world end-world - close-game-input +AFTER: terrain-world end-world { - [ game-loop>> stop-loop ] [ terrain-vertex-buffer>> delete-gl-buffer ] [ terrain-program>> delete-gl-program ] [ terrain-texture>> delete-texture ] @@ -224,7 +218,6 @@ M: terrain-world draw-world* ] with-gl-program ] tri gl-error ; -M: terrain-world focusable-child* drop t ; M: terrain-world pref-dim* drop { 640 480 } ; : terrain-window ( -- ) From 4367068ba60d2899f062a03c96f1bf8723863d31 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 14:31:33 -0500 Subject: [PATCH 02/10] save off the tick-slice when draw*-ing a game-world --- extra/game-worlds/game-worlds.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index 864bd28fc1..fa6b326fa9 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -1,14 +1,15 @@ -USING: accessors game-input game-loop kernel ui.gadgets +USING: accessors game-input game-loop kernel math ui.gadgets ui.gadgets.worlds ui.gestures ; IN: game-worlds TUPLE: game-world < world - game-loop ; + game-loop + { tick-slice float initial: 0.0 } ; GENERIC: tick-length ( world -- millis ) M: game-world draw* - nip draw-world ; + swap >>tick-slice draw-world ; M: game-world begin-world dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop From 8cbcb87152cef62bd8719f0f4f41f424de88fc4c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 14:33:17 -0500 Subject: [PATCH 03/10] don't mess with the orphaned nodes when pop-front-ing or pop-back-ing a dlist. add a dlist-filter word that drops off all nodes that don't satisfy a predicate --- basis/dlists/dlists-tests.factor | 5 +++++ basis/dlists/dlists.factor | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 3689680157..8072c93753 100755 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -79,3 +79,8 @@ IN: dlists.tests [ 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 + +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 3d7224ed16..89675c6469 100755 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-next drop + next>> f over set-prev-when ] change-front drop ] keep @@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-prev drop + prev>> f over set-next-when ] change-back drop ] keep @@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; +: dlist-filter ( dlist quot -- dlist ) + over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline + M: dlist clone [ '[ _ push-back ] dlist-each ] keep ; From 4ee4357e75f1af23950e0eb4622c83d5b2cb8ae5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 18:17:30 -0500 Subject: [PATCH 04/10] Fix negative zero smashing with bootstrap --- basis/bootstrap/image/image.factor | 3 +++ core/math/math.factor | 2 ++ 2 files changed, 5 insertions(+) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 55e6a31491..92d75604e0 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? ) M: integer (eql?) = ; +M: float (eql?) + over float? [ fp-bitwise= ] [ 2drop f ] if ; + M: sequence (eql?) over sequence? [ 2dup [ length ] bi@ = diff --git a/core/math/math.factor b/core/math/math.factor index 6a087ec909..da9bc4d1b5 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -81,6 +81,8 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ; UNION: number real complex ; +: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline + GENERIC: fp-special? ( x -- ? ) GENERIC: fp-nan? ( x -- ? ) GENERIC: fp-qnan? ( x -- ? ) From cbb1f1c60b3f224cf8c9e9913818b5afeee4a596 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:15:03 -0500 Subject: [PATCH 05/10] docs for dlist-filter --- basis/dlists/dlists-docs.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 12e39746c7..e210ad35ce 100755 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,6 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } +{ $subsection dlist-filter } { $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } @@ -40,6 +41,11 @@ HELP: dlist-find "This operation is O(n)." } ; +HELP: dlist-filter +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." } +{ $side-effects { "dlist" } } ; + HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } From e4059d8393c81efe4ff7ebdb01e630d492ffbe19 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:15:55 -0500 Subject: [PATCH 06/10] clamp coordinates when doing terrain collision detection past the edge of the segment --- extra/terrain/terrain.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index fe105b2e52..590244ca6a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -138,8 +138,11 @@ M: terrain-world tick-length : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; +: clamp-coords ( coords dim -- coords' ) + [ { 0 0 } vmax ] dip { 2 2 } v- vmin ; + :: pixel-indices ( coords dim -- indices ) - coords vfloor [ >integer ] map :> floor-coords + coords vfloor [ >integer ] map dim clamp-coords :> floor-coords floor-coords first2 dim first * + :> base-index base-index dim first + :> next-row-index From 7584b3075593b95689df75c2d69ebec261157db6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:23:56 -0500 Subject: [PATCH 07/10] "math" help-lint --- core/math/math-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 75370d6cfd..e5f68a511c 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -274,7 +274,7 @@ HELP: fp-nan-payload { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; HELP: -{ $values { "payload" integer } { "float" float } } +{ $values { "payload" integer } { "nan" float } } { $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." } { $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ; From cda3685c4dcd632b4b73412a6d36f22192a75f1e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 20:24:17 -0500 Subject: [PATCH 08/10] Eliminate prettyprinter dependency from UI --- basis/math/rectangles/prettyprint/authors.txt | 1 + basis/math/rectangles/prettyprint/prettyprint.factor | 7 +++++++ basis/math/rectangles/rectangles.factor | 9 +++++---- basis/ui/gadgets/gadgets.factor | 10 +++++----- basis/ui/gadgets/prettyprint/authors.txt | 1 + basis/ui/gadgets/prettyprint/prettyprint.factor | 7 +++++++ 6 files changed, 26 insertions(+), 9 deletions(-) create mode 100644 basis/math/rectangles/prettyprint/authors.txt create mode 100644 basis/math/rectangles/prettyprint/prettyprint.factor create mode 100644 basis/ui/gadgets/prettyprint/authors.txt create mode 100644 basis/ui/gadgets/prettyprint/prettyprint.factor diff --git a/basis/math/rectangles/prettyprint/authors.txt b/basis/math/rectangles/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/math/rectangles/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..c23be50029 --- /dev/null +++ b/basis/math/rectangles/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ; +IN: math.rectangles.prettyprint + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 340eafa37d..c8569dfdb9 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays sequences math math.vectors accessors -parser prettyprint.custom prettyprint.backend ; +parser ; IN: math.rectangles TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; @@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; SYNTAX: RECT: scan-object scan-object parsed ; -M: rect pprint* - \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; - : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -64,3 +61,7 @@ M: rect contains-point? [ [ loc>> ] dip (>>loc) ] [ [ dim>> ] dip (>>dim) ] 2bi ; inline + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index f9f397d46f..5dd1710cdd 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,8 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry locals -prettyprint.backend prettyprint.custom ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -28,9 +27,6 @@ interior boundary model ; -! Don't print gadgets with RECT: syntax -M: gadget pprint* pprint-tuple ; - M: gadget equal? 2drop f ; M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; @@ -397,3 +393,7 @@ M: f request-focus-on 2drop ; : focus-path ( gadget -- seq ) [ focus>> ] follow ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/authors.txt b/basis/ui/gadgets/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/gadgets/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..82a89eda11 --- /dev/null +++ b/basis/ui/gadgets/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ui.gadgets prettyprint.backend prettyprint.custom ; +IN: ui.gadgets.prettyprint + +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; \ No newline at end of file From aa3aa715beac977f8f207e5d090f7b0a03780a0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 20:24:32 -0500 Subject: [PATCH 09/10] Slightly more space-efficient dispatch table representation --- core/generic/single/single.factor | 2 +- vm/dispatch.cpp | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 36a76153f9..8d84b21bf7 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine : build-fast-hash ( methods -- buckets ) >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ compile-engines* >alist >array ] map ; + [ compile-engines* >alist { } join ] map ; M: echelon-dispatch-engine compile-engine dup n>> 0 = [ diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index 847a19d738..4a1411733e 100755 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -8,15 +8,14 @@ cell megamorphic_cache_misses; static cell search_lookup_alist(cell table, cell klass) { - array *pairs = untag(table); - fixnum index = array_capacity(pairs) - 1; + array *elements = untag(table); + fixnum index = array_capacity(elements) - 2; while(index >= 0) { - array *pair = untag(array_nth(pairs,index)); - if(array_nth(pair,0) == klass) - return array_nth(pair,1); + if(array_nth(elements,index) == klass) + return array_nth(elements,index + 1); else - index--; + index -= 2; } return F; From d90bb0f336a214a65053c1657681adc86937d7c3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 10:41:50 -0500 Subject: [PATCH 10/10] cut perlin-noise time in half --- .../math/polynomials/polynomials-docs.factor | 10 +- basis/math/polynomials/polynomials.factor | 12 +- basis/math/vectors/vectors.factor | 10 ++ .../affine-transforms.factor | 2 + extra/noise/noise.factor | 105 ++++++++++-------- 5 files changed, 85 insertions(+), 54 deletions(-) diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index f65c4ecaaf..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; -: polyval ( p x -- p[x] ) - [ dup length ] dip powers v. ; +: polyval ( x p -- p[x] ) + [ length swap powers ] [ nip ] 2bi v. ; + +MACRO: polyval* ( p -- ) + reverse + [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ] + [ first \ drop swap [ ] 2sequence ] bi + prefix \ cleave [ ] 2sequence ; diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 17f6c39f04..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,13 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: 2tetra@ ( p q r s t u v w quot -- ) + dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline + +: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) + [ first lerp ] [ second lerp ] [ third lerp ] tri-curry + [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; + : bilerp ( aa ba ab bb {t,u} -- a_tu ) [ first lerp ] [ second lerp ] bi-curry [ 2bi@ ] [ call ] bi* ; @@ -72,3 +79,6 @@ HINTS: v. { array array } ; HINTS: vlerp { array array array } ; HINTS: vnlerp { array array object } ; + +HINTS: bilerp { object object object object array } ; +HINTS: trilerp { object object object object object object object object array } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 20b73ba678..d1fd602f72 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 [ drop origin>> ] 2tri v+ v+ ; +: ( -- a ) + { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } ; : ( origin -- a ) [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; : ( theta -- transform ) diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index c28768283c..46704eed36 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,61 +1,60 @@ USING: byte-arrays combinators fry images kernel locals math math.affine-transforms math.functions math.order math.polynomials math.vectors random random.mersenne-twister -sequences sequences.product ; +sequences sequences.product hints arrays sequences.private +combinators.short-circuit math.private ; IN: noise : ( -- table ) - 256 iota >byte-array randomize dup append ; + 256 iota >byte-array randomize dup append ; inline : with-seed ( seed quot -- ) [ ] dip with-random ; inline u hash 12 bitand zero? - [ gradients second ] - [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if :> v hash 1 bitand zero? [ u ] [ u neg ] if hash 2 bitand zero? [ v ] [ v neg ] if + ; +HINTS: grad { fixnum float float float } ; + : unit-cube ( point -- cube ) - [ floor >fixnum 256 mod ] map ; + [ floor >fixnum 256 rem ] map ; -:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) - cube first :> x - cube second :> y - cube third :> z - x table nth y + :> a - x 1 + table nth y + :> b +:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) + x table nth-unsafe y fixnum+fast :> a + x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b - a table nth z + :> aa - b table nth z + :> ba - a 1 + table nth z + :> ab - b 1 + table nth z + :> bb + a table nth-unsafe z fixnum+fast :> aa + b table nth-unsafe z fixnum+fast :> ba + a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab + b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb - aa table nth - ba table nth - ab table nth - bb table nth - aa 1 + table nth - ba 1 + table nth - ab 1 + table nth - bb 1 + table nth ; + aa table nth-unsafe + ba table nth-unsafe + ab table nth-unsafe + bb table nth-unsafe + aa 1 fixnum+fast table nth-unsafe + ba 1 fixnum+fast table nth-unsafe + ab 1 fixnum+fast table nth-unsafe + bb 1 fixnum+fast table nth-unsafe ; inline -:: 2tetra@ ( p q r s t u v w quot -- ) - p q quot call - r s quot call - t u quot call - v w quot call - ; inline +HINTS: hashes { byte-array fixnum fixnum fixnum } ; : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; @@ -63,26 +62,33 @@ IN: noise : >image ( bytes dim -- image ) swap [ L f ] dip image boa ; -PRIVATE> - -:: perlin-noise ( table point -- value ) +:: perlin-noise-unsafe ( table point -- value ) point unit-cube :> cube point dup vfloor v- :> gradients gradients fade :> faded - table cube hashes { - [ gradients grad ] - [ gradients { -1.0 0.0 0.0 } v+ grad ] - [ gradients { 0.0 -1.0 0.0 } v+ grad ] - [ gradients { -1.0 -1.0 0.0 } v+ grad ] - [ gradients { 0.0 0.0 -1.0 } v+ grad ] - [ gradients { -1.0 0.0 -1.0 } v+ grad ] - [ gradients { 0.0 -1.0 -1.0 } v+ grad ] - [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + table cube first3 hashes { + [ gradients first3 grad ] + [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ] } spread - [ faded first lerp ] 2tetra@ - [ faded second lerp ] 2bi@ - faded third lerp ; + faded trilerp ; + +ERROR: invalid-perlin-noise-table table ; + +: validate-table ( table -- table ) + dup { [ byte-array? ] [ length 512 >= ] } 1&& + [ invalid-perlin-noise-table ] unless ; + +PRIVATE> + +: perlin-noise ( table point -- value ) + [ validate-table ] dip perlin-noise-unsafe ; inline : normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri @@ -92,7 +98,8 @@ PRIVATE> [ 0.0 max 1.0 min ] map ; : perlin-noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + [ validate-table ] 2dip + [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ; : perlin-noise-byte-map ( table transform dim -- map ) perlin-noise-map normalize-0-1 >byte-map ;