steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-07-17 19:39:52 -05:00
parent 86221a23d7 c4665903ae
commit ce0190a997
9 changed files with 87 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/automata/ui/ui.factor
View File

@ -83,7 +83,7 @@ DEFER: automata-window
@top grid-add
C[ display ] <slate>
{ 400 400 } >>dim
{ 400 400 } >>pdim
dup >slate
@center grid-add

2
extra/boids/ui/ui.factor
View File

@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
C[ display ] <slate> >slate
t slate> set-gadget-clipped?
{ 600 400 } slate> set-slate-dim
{ 600 400 } slate> set-slate-pdim
C[ [ run ] in-thread ] slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft

2
extra/cfdg/cfdg.factor
View File

@ -204,7 +204,7 @@ VAR: start-shape
: cfdg-window* ( -- )
[ display ] closed-quot <slate>
{ 500 500 } over set-slate-dim
{ 500 500 } over set-slate-pdim
dup "CFDG" open-window ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;

43
extra/display-stack/display-stack.factor Normal file
View File

@ -0,0 +1,43 @@
USING: kernel namespaces sequences math
listener io prettyprint sequences.lib fry ;
IN: display-stack
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: watched-variables
: watch-var ( sym -- ) watched-variables get push ;
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
: unwatch-var ( sym -- ) watched-variables get delete ;
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
: print-watched-variables ( -- )
watched-variables get length 0 >
[
"----------" print
watched-variables get
watched-variables get [ unparse ] map longest length 2 +
'[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
each
]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: display-stack ( -- )
V{ } clone watched-variables set
[
print-watched-variables
"----------" print
datastack [ . ] each
"----------" print
retainstack reverse [ . ] each
]
listener-hook set ;

2
extra/golden-section/golden-section.factor
View File

@ -57,7 +57,7 @@ IN: golden-section
: golden-section-window ( -- )
[
[ display ] <slate>
{ 600 600 } over set-slate-dim
{ 600 600 } over set-slate-pdim
"Golden Section" open-window
] with-ui ;

2
extra/lsys/ui/ui.factor
View File

@ -158,7 +158,7 @@ DEFER: empty-model
: lsys-viewer ( -- )
[ ] <slate> >slate
{ 400 400 } clone slate> set-slate-dim
{ 400 400 } clone slate> set-slate-pdim
{

27
extra/self/slots/slots.factor Normal file
View File

@ -0,0 +1,27 @@
USING: kernel words lexer parser sequences accessors self ;
IN: self.slots
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-reader ( slot -- )
[ "->" append current-vocab create dup set-word ]
[ ">>" append search [ self> ] swap suffix ] bi
(( -- value )) define-declared ;
: define-self-slot-writer ( slot -- )
[ "->" prepend current-vocab create dup set-word ]
[ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
(( value -- )) define-declared ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-accessors ( class -- )
"slots" word-prop
[ name>> ] map
[ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing

2
extra/springies/ui/ui.factor
View File

@ -51,7 +51,7 @@ DEFER: maybe-loop
: springies-window* ( -- )
C[ display ] <slate> >slate
{ 800 600 } slate> set-slate-dim
{ 800 600 } slate> set-slate-pdim
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft

123
extra/ui/gadgets/slate/slate.factor
View File

@ -1,122 +1,21 @@
USING: kernel namespaces opengl ui.render ui.gadgets ;
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
IN: ui.gadgets.slate
TUPLE: slate action dim graft ungraft
button-down
button-up
key-down
key-up ;
TUPLE: slate < gadget action pdim graft ungraft ;
: <slate> ( action -- slate )
slate construct-gadget
tuck set-slate-action
{ 100 100 } over set-slate-dim
[ ] over set-slate-graft
[ ] over set-slate-ungraft ;
slate new-gadget
swap >>action
{ 100 100 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
M: slate pref-dim* ( slate -- dim ) slate-dim ;
M: slate pref-dim* ( slate -- dim ) pdim>> ;
M: slate draw-gadget* ( slate -- )
origin get swap slate-action with-translation ;
M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
M: slate graft* ( slate -- ) slate-graft call ;
M: slate graft* ( slate -- ) graft>> call ;
M: slate ungraft* ( slate -- ) ungraft>> call ;
M: slate ungraft* ( slate -- ) slate-ungraft call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: key-pressed-value
: key-pressed? ( -- ? ) key-pressed-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: mouse-pressed-value
: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: key-value
: key ( -- key ) key-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: button-value
: button ( -- val ) button-value get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: combinators ui.gestures accessors ;
! M: slate handle-gesture* ( gadget gesture delegate -- ? )
! drop nip
! {
! {
! [ dup key-down? ]
! [
! key-down-sym key-value set
! key-pressed-value on
! t
! ]
! }
! { [ dup key-up? ] [ drop key-pressed-value off t ] }
! {
! [ dup button-down? ]
! [
! button-down-# mouse-button-value set
! mouse-pressed-value on
! t
! ]
! }
! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
! { [ t ] [ drop t ] }
! }
! cond ;
M: slate handle-gesture* ( gadget gesture delegate -- ? )
rot drop swap ! delegate gesture
{
{
[ dup key-down? ]
[
key-down-sym key-value set
key-pressed-value on
key-down>> dup [ call ] [ drop ] if
t
]
}
{
[ dup key-up? ]
[
key-pressed-value off
drop
key-up>> dup [ call ] [ drop ] if
t
] }
{
[ dup button-down? ]
[
button-down-# button-value set
mouse-pressed-value on
button-down>> dup [ call ] [ drop ] if
t
]
}
{
[ dup button-up? ]
[
mouse-pressed-value off
drop
button-up>> dup [ call ] [ drop ] if
t
]
}
{ [ t ] [ 2drop t ] }
}
cond ;