add a clamp word to math.order, use clamp word throughout libraries
parent
86a1b06034
commit
a54c78007b
|
@ -197,7 +197,7 @@ IN: compiler.tree.propagation.tests
|
||||||
{ fixnum byte-array } declare
|
{ fixnum byte-array } declare
|
||||||
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
|
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
|
||||||
[ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
|
[ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
|
||||||
255 min 0 max
|
0 255 clamp
|
||||||
] final-classes
|
] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -210,7 +210,7 @@ IN: compiler.tree.propagation.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ 1.5 } ] [
|
[ V{ 1.5 } ] [
|
||||||
[ /f 1.5 min 1.5 max ] final-literals
|
[ /f 1.5 1.5 clamp ] final-literals
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ 1.5 } ] [
|
[ V{ 1.5 } ] [
|
||||||
|
|
|
@ -23,9 +23,10 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
|
||||||
"Incrementing, decrementing:"
|
"Incrementing, decrementing:"
|
||||||
{ $subsection 1+ }
|
{ $subsection 1+ }
|
||||||
{ $subsection 1- }
|
{ $subsection 1- }
|
||||||
"Minimum, maximum:"
|
"Minimum, maximum, clamping:"
|
||||||
{ $subsection min }
|
{ $subsection min }
|
||||||
{ $subsection max }
|
{ $subsection max }
|
||||||
|
{ $subsection clamp }
|
||||||
"Complex conjugation:"
|
"Complex conjugation:"
|
||||||
{ $subsection conjugate }
|
{ $subsection conjugate }
|
||||||
"Tests:"
|
"Tests:"
|
||||||
|
|
|
@ -26,12 +26,16 @@ M: range hashcode* tuple-hashcode ;
|
||||||
|
|
||||||
INSTANCE: range immutable-sequence
|
INSTANCE: range immutable-sequence
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
|
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
|
||||||
|
|
||||||
: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
|
: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
|
||||||
|
|
||||||
: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
|
: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: [a,b] ( a b -- range ) twiddle <range> ; inline
|
: [a,b] ( a b -- range ) twiddle <range> ; inline
|
||||||
|
|
||||||
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
|
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
|
||||||
|
@ -62,7 +66,7 @@ INSTANCE: range immutable-sequence
|
||||||
dup range-decreasing? first-or-peek ;
|
dup range-decreasing? first-or-peek ;
|
||||||
|
|
||||||
: clamp-to-range ( n range -- n )
|
: clamp-to-range ( n range -- n )
|
||||||
[ range-min max ] [ range-max min ] bi ;
|
[ range-min ] [ range-max ] bi clamp ;
|
||||||
|
|
||||||
: sequence-index-range ( seq -- range )
|
: sequence-index-range ( seq -- range )
|
||||||
length [0,b) ;
|
length [0,b) ;
|
||||||
|
|
|
@ -109,5 +109,4 @@ GENERIC: set-range-min-value ( value model -- )
|
||||||
GENERIC: set-range-max-value ( value model -- )
|
GENERIC: set-range-max-value ( value model -- )
|
||||||
|
|
||||||
: clamp-value ( value range -- newvalue )
|
: clamp-value ( value range -- newvalue )
|
||||||
[ range-min-value max ] keep
|
[ range-min-value ] [ range-max-value* ] bi clamp ;
|
||||||
range-max-value* min ;
|
|
||||||
|
|
|
@ -51,6 +51,10 @@ HELP: min
|
||||||
{ $values { "x" real } { "y" real } { "z" real } }
|
{ $values { "x" real } { "y" real } { "z" real } }
|
||||||
{ $description "Outputs the smallest of two real numbers." } ;
|
{ $description "Outputs the smallest of two real numbers." } ;
|
||||||
|
|
||||||
|
HELP: clamp
|
||||||
|
{ $values { "x" real } { "min" real } { "max" real } { "y" real } }
|
||||||
|
{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
|
||||||
|
|
||||||
HELP: between?
|
HELP: between?
|
||||||
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
|
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
|
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
|
||||||
|
@ -105,6 +109,7 @@ ARTICLE: "math.order" "Linear order protocol"
|
||||||
{ $subsection "order-specifiers" }
|
{ $subsection "order-specifiers" }
|
||||||
"Utilities for comparing objects:"
|
"Utilities for comparing objects:"
|
||||||
{ $subsection after? }
|
{ $subsection after? }
|
||||||
|
{ $subsection after? }
|
||||||
{ $subsection before? }
|
{ $subsection before? }
|
||||||
{ $subsection after=? }
|
{ $subsection after=? }
|
||||||
{ $subsection before=? }
|
{ $subsection before=? }
|
||||||
|
|
|
@ -7,3 +7,6 @@ IN: math.order.tests
|
||||||
[ +eq+ ] [ 4 4 <=> ] unit-test
|
[ +eq+ ] [ 4 4 <=> ] unit-test
|
||||||
[ +gt+ ] [ 4 3 <=> ] unit-test
|
[ +gt+ ] [ 4 3 <=> ] unit-test
|
||||||
|
|
||||||
|
[ 20 ] [ 20 0 100 clamp ] unit-test
|
||||||
|
[ 0 ] [ -20 0 100 clamp ] unit-test
|
||||||
|
[ 100 ] [ 120 0 100 clamp ] unit-test
|
||||||
|
|
|
@ -34,6 +34,7 @@ M: real after=? ( obj1 obj2 -- ? ) >= ;
|
||||||
|
|
||||||
: min ( x y -- z ) [ before? ] most ; inline
|
: min ( x y -- z ) [ before? ] most ; inline
|
||||||
: max ( x y -- z ) [ after? ] most ; inline
|
: max ( x y -- z ) [ after? ] most ; inline
|
||||||
|
: clamp ( x min max -- y ) [ max ] dip min ; inline
|
||||||
|
|
||||||
: between? ( x y z -- ? )
|
: between? ( x y z -- ? )
|
||||||
pick after=? [ after=? ] [ 2drop f ] if ; inline
|
pick after=? [ after=? ] [ 2drop f ] if ; inline
|
||||||
|
|
|
@ -14,8 +14,3 @@ IN: math.compare.tests
|
||||||
[ 0 ] [ 1 3 negmin ] unit-test
|
[ 0 ] [ 1 3 negmin ] unit-test
|
||||||
[ -3 ] [ 1 -3 negmin ] unit-test
|
[ -3 ] [ 1 -3 negmin ] unit-test
|
||||||
[ -1 ] [ -1 3 negmin ] unit-test
|
[ -1 ] [ -1 3 negmin ] unit-test
|
||||||
|
|
||||||
[ 0 ] [ 0 -1 2 clamp ] unit-test
|
|
||||||
[ 1 ] [ 0 1 2 clamp ] unit-test
|
|
||||||
[ 2 ] [ 0 3 2 clamp ] unit-test
|
|
||||||
|
|
||||||
|
|
|
@ -14,6 +14,3 @@ IN: math.compare
|
||||||
|
|
||||||
: negmin ( a b -- x )
|
: negmin ( a b -- x )
|
||||||
0 min min ;
|
0 min min ;
|
||||||
|
|
||||||
: clamp ( a value b -- x )
|
|
||||||
min max ;
|
|
||||||
|
|
|
@ -88,7 +88,7 @@ M: terrain-world tick-length
|
||||||
yaw>> 0.0
|
yaw>> 0.0
|
||||||
${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
|
${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
|
||||||
: clamp-pitch ( pitch -- pitch' )
|
: clamp-pitch ( pitch -- pitch' )
|
||||||
90.0 min -90.0 max ;
|
-90.0 90.0 clamp ;
|
||||||
|
|
||||||
: walk-forward ( player -- )
|
: walk-forward ( player -- )
|
||||||
dup forward-vector [ v+ ] curry change-velocity drop ;
|
dup forward-vector [ v+ ] curry change-velocity drop ;
|
||||||
|
|
Loading…
Reference in New Issue