unmaintained: fix accessors (>>foo) should be foo<<.
parent
798f6445bd
commit
e9cdfcb03c
|
@ -148,10 +148,10 @@ VAR: present-space
|
|||
view4> relayout-1 ;
|
||||
|
||||
: update-model-projections ( -- )
|
||||
0 model-projection <model> view1> (>>model)
|
||||
1 model-projection <model> view2> (>>model)
|
||||
2 model-projection <model> view3> (>>model)
|
||||
3 model-projection <model> view4> (>>model) ;
|
||||
0 model-projection <model> view1> model<<
|
||||
1 model-projection <model> view2> model<<
|
||||
2 model-projection <model> view3> model<<
|
||||
3 model-projection <model> view4> model<< ;
|
||||
|
||||
: camera-action ( quot -- quot )
|
||||
'[ drop _ observer3d>
|
||||
|
|
|
@ -32,10 +32,10 @@ TUPLE: observer < turtle projection-mode collision-mode ;
|
|||
|
||||
|
||||
: turtle-pos> ( -- val ) self> pos>> ;
|
||||
: >turtle-pos ( val -- ) self> (>>pos) ;
|
||||
: >turtle-pos ( val -- ) self> pos<< ;
|
||||
|
||||
: turtle-ori> ( -- val ) self> ori>> ;
|
||||
: >turtle-ori ( val -- ) self> (>>ori) ;
|
||||
: >turtle-ori ( val -- ) self> ori<< ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -263,7 +263,7 @@ TUPLE: <L-system> < gadget
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
|
||||
:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET pedestal<< ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -357,7 +357,7 @@ TUPLE: <L-system> < gadget
|
|||
L-SYSTEM string>> L-SYSTEM axiom>> or
|
||||
L-SYSTEM rules>>
|
||||
iterate-string
|
||||
L-SYSTEM (>>string) ;
|
||||
L-SYSTEM string<< ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -422,7 +422,7 @@ M:: <L-system> graft* ( L-SYSTEM -- )
|
|||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
1 glGenLists L-SYSTEM (>>display-list) ;
|
||||
1 glGenLists L-SYSTEM display-list<< ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -508,4 +508,4 @@ ARTICLE: "L-system" "L-system"
|
|||
{ "q" "Roll left" }
|
||||
{ "w" "Roll right" } } ;
|
||||
|
||||
ABOUT: "L-system"
|
||||
ABOUT: "L-system"
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: alien.marshall.structs
|
|||
define-struct-accessor ;
|
||||
|
||||
: define-struct-setter ( class name word type -- )
|
||||
[ "(>>" prepend ")" append ] 2dip
|
||||
[ "<<" append ] 2dip
|
||||
marshaller [ underlying>> ] \ bi* roll 4array >quotation
|
||||
define-struct-accessor ;
|
||||
|
||||
|
|
|
@ -473,7 +473,7 @@ M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
|
|||
v-
|
||||
first2
|
||||
fatan2
|
||||
BUBBLE-CHAMBER (>>collision-theta)
|
||||
BUBBLE-CHAMBER collision-theta<<
|
||||
BUBBLE-CHAMBER ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
@ -59,7 +59,7 @@ TUPLE: <entry> time data ;
|
|||
{
|
||||
{ [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
|
||||
{ [ ENT expired? ] [ RR cache-delete RR cache-add ] }
|
||||
{ [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
|
||||
{ [ t ] [ TIME ENT time<< RDATA ENT data>> adjoin ] }
|
||||
}
|
||||
cond
|
||||
] ;
|
||||
] ;
|
||||
|
|
|
@ -46,7 +46,7 @@ ERROR: unsupported-rotation degrees ;
|
|||
: normalize-degree ( n -- n' ) 360 rem ;
|
||||
|
||||
: processing-effect ( image quot -- image' )
|
||||
'[ image>pixel-rows @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
|
||||
'[ image>pixel-rows @ flatten-table ] [ bitmap<< ] [ ] tri ; inline
|
||||
|
||||
:: rotate' ( image n -- image )
|
||||
n normalize-degree :> n'
|
||||
|
|
|
@ -235,7 +235,7 @@ M: irc-tab pref-dim*
|
|||
<irc-client>
|
||||
{ [ [ <irc-server-chat> ] dip attach-chat ]
|
||||
[ chats>> +server-chat+ swap at <irc-server-tab> dup
|
||||
"Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
|
||||
"Server" associate ui-window new-tabbed [ swap window<< ] keep ]
|
||||
[ >>client ]
|
||||
[ connect-irc ] } cleave ;
|
||||
|
||||
|
|
|
@ -46,7 +46,7 @@ M: fold-model model-activated drop ;
|
|||
TUPLE: updater-model < multi-model values updates ;
|
||||
M: updater-model (model-changed) [ tuck updates>> =
|
||||
[ [ values>> value>> ] keep set-model ]
|
||||
[ drop ] if ] keep f swap (>>value) ;
|
||||
[ drop ] if ] keep f swap value<< ;
|
||||
: updates ( values updates -- model ) [ 2array updater-model <multi-model> ] 2keep
|
||||
[ >>values ] [ >>updates ] bi* ;
|
||||
|
||||
|
|
|
@ -13,7 +13,7 @@ C: <ori> ori
|
|||
|
||||
: ori> ( -- val ) self> val>> ;
|
||||
|
||||
: >ori ( val -- ) self> (>>val) ;
|
||||
: >ori ( val -- ) self> val<< ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -14,10 +14,10 @@ CONSULT: assoc-protocol lex-hash hash>> ;
|
|||
v CHAR: \n n last-index -1 or 1 + -
|
||||
n [ CHAR: \n = ] count 1 +
|
||||
] ;
|
||||
|
||||
|
||||
: store-pos ( v a -- )
|
||||
input of prepare-pos
|
||||
lexer get [ (>>line) ] keep (>>column) ;
|
||||
lexer get [ line<< ] keep column<< ;
|
||||
|
||||
M: lex-hash set-at
|
||||
swap {
|
||||
|
|
|
@ -145,7 +145,7 @@ M:: <pong> draw-gadget* ( PONG -- )
|
|||
bounce-off-wall? [ ( -- ? )
|
||||
BALL FIELD in-between-horizontally? not ]
|
||||
|
||||
stop-game [ ( -- ) t GADGET (>>paused) ] |
|
||||
stop-game [ ( -- ) t GADGET paused<< ] |
|
||||
|
||||
BALL FIELD in-bounds?
|
||||
[
|
||||
|
@ -173,7 +173,7 @@ M:: <pong> draw-gadget* ( PONG -- )
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-pong-thread ( GADGET -- )
|
||||
f GADGET (>>paused)
|
||||
f GADGET paused<<
|
||||
[
|
||||
[
|
||||
GADGET paused>>
|
||||
|
@ -191,4 +191,4 @@ M:: <pong> draw-gadget* ( PONG -- )
|
|||
|
||||
: pong-main ( -- ) [ pong-window ] with-ui ;
|
||||
|
||||
MAIN: pong-window
|
||||
MAIN: pong-window
|
||||
|
|
|
@ -12,7 +12,7 @@ C: <pos> pos
|
|||
|
||||
: pos> ( -- val ) self> val>> ;
|
||||
|
||||
: >pos ( val -- ) self> (>>val) ;
|
||||
: >pos ( val -- ) self> val<< ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ TUPLE: model-btn < button hook value ;
|
|||
: <model-btn> ( gadget -- button ) [
|
||||
[ dup hook>> [ call( button -- ) ] [ drop ] if* ]
|
||||
[ [ [ value>> ] [ ] bi or ] keep set-control-value ]
|
||||
[ model>> f swap (>>value) ] tri
|
||||
[ model>> f swap value<< ] tri
|
||||
] model-btn new-button f <basic> >>model ;
|
||||
: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
|
||||
|
||||
|
|
|
@ -73,7 +73,7 @@ M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadg
|
|||
GENERIC# add-gadget-at 1 ( item location -- )
|
||||
M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
|
||||
M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
|
||||
[ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
|
||||
[ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip model<< ] if ] if ;
|
||||
: track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
|
||||
: (track-add-at) ( parent item n size -- ) swap [ <layout> ] dip (add-gadget-at) ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue