bi, is really a better name than bi+. Add analogous bi*, and tri*, words along with unit tests
							parent
							
								
									d2d5dba6a8
								
							
						
					
					
						commit
						d6db9897fa
					
				| 
						 | 
				
			
			@ -2,6 +2,12 @@ USING: combinators.lib kernel math random sequences tools.test continuations
 | 
			
		|||
    arrays vectors ;
 | 
			
		||||
IN: combinators.lib.tests
 | 
			
		||||
 | 
			
		||||
[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
 | 
			
		||||
[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
 | 
			
		||||
[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
 | 
			
		||||
 | 
			
		||||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
 | 
			
		||||
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -12,11 +12,16 @@ IN: combinators.lib
 | 
			
		|||
! Currying cleave combinators
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
 | 
			
		||||
: bi+ ( obj quot quot -- quot' quot' )
 | 
			
		||||
: bi, ( obj quot quot -- quot' quot' )
 | 
			
		||||
    [ [ curry ] curry ] bi@ bi ; inline
 | 
			
		||||
: tri+ ( obj quot quot quot -- quot' quot' quot' )
 | 
			
		||||
: tri, ( obj quot quot quot -- quot' quot' quot' )
 | 
			
		||||
    [ [ curry ] curry ] tri@ tri ; inline
 | 
			
		||||
 | 
			
		||||
: bi*, ( obj obj quot quot -- quot' quot' )
 | 
			
		||||
    [ [ curry ] curry ] bi@ bi* ; inline
 | 
			
		||||
: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
 | 
			
		||||
    [ [ curry ] curry ] tri@ tri* ; inline
 | 
			
		||||
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
! Generalized versions of core combinators
 | 
			
		||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -46,7 +46,7 @@ HOOK: instance-id game-input-backend ( controller -- id )
 | 
			
		|||
: find-controller-instance ( product-id instance-id -- controller/f )
 | 
			
		||||
    get-controllers [
 | 
			
		||||
        [ product-id  = ]
 | 
			
		||||
        [ instance-id = ] bi+ bi* and
 | 
			
		||||
        [ instance-id = ] bi, bi* and
 | 
			
		||||
    ] 2with find nip ;
 | 
			
		||||
 | 
			
		||||
HOOK: read-controller game-input-backend ( controller -- controller-state )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -53,7 +53,7 @@ M: axis-gadget pref-dim* drop SIZE ;
 | 
			
		|||
: move-axis ( gadget x y z -- )
 | 
			
		||||
    (xyz>loc) rot
 | 
			
		||||
    [ indicator>>   (>>loc) ]
 | 
			
		||||
    [ z-indicator>> (>>loc) ] bi+ bi* ;
 | 
			
		||||
    [ z-indicator>> (>>loc) ] bi, bi* ;
 | 
			
		||||
 | 
			
		||||
: move-pov ( gadget pov -- )
 | 
			
		||||
    swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
 | 
			
		||||
| 
						 | 
				
			
			@ -82,10 +82,10 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
 | 
			
		|||
    [ >>controller ] [ product-string <label> add-gadget ] bi ;
 | 
			
		||||
 | 
			
		||||
: add-axis-gadget ( gadget shelf -- gadget shelf )
 | 
			
		||||
    <axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi+ bi* ;
 | 
			
		||||
    <axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi, bi* ;
 | 
			
		||||
 | 
			
		||||
: add-raxis-gadget ( gadget shelf -- gadget shelf )
 | 
			
		||||
    <axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi+ bi* ;
 | 
			
		||||
    <axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi, bi* ;
 | 
			
		||||
 | 
			
		||||
:: (add-button-gadgets) ( gadget shelf -- )
 | 
			
		||||
    gadget controller>> read-controller buttons>> length [
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue