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