diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 78f1074eb8..808e476ffa 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -83,7 +83,7 @@ DEFER: automata-window @top grid-add C[ display ] - { 400 400 } >>dim + { 400 400 } >>pdim dup >slate @center grid-add diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index f45b1cc0ff..fff0e0d33b 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ; C[ display ] >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 diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 63fd55a550..2dfa7fae8f 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -204,7 +204,7 @@ VAR: start-shape : cfdg-window* ( -- ) [ display ] closed-quot - { 500 500 } over set-slate-dim + { 500 500 } over set-slate-pdim dup "CFDG" open-window ; : cfdg-window ( -- ) [ cfdg-window* ] with-ui ; \ No newline at end of file diff --git a/extra/display-stack/display-stack.factor b/extra/display-stack/display-stack.factor new file mode 100644 index 0000000000..8da252f294 --- /dev/null +++ b/extra/display-stack/display-stack.factor @@ -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 ; + diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index ef6f1ca4c2..354d4d9116 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -57,7 +57,7 @@ IN: golden-section : golden-section-window ( -- ) [ [ display ] - { 600 600 } over set-slate-dim + { 600 600 } over set-slate-pdim "Golden Section" open-window ] with-ui ; diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index f7ec181f61..6fd7b4bd40 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -158,7 +158,7 @@ DEFER: empty-model : lsys-viewer ( -- ) [ ] >slate -{ 400 400 } clone slate> set-slate-dim +{ 400 400 } clone slate> set-slate-pdim { diff --git a/extra/self/slots/slots.factor b/extra/self/slots/slots.factor new file mode 100644 index 0000000000..b07641a062 --- /dev/null +++ b/extra/self/slots/slots.factor @@ -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 \ No newline at end of file diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 365632e974..f2248ba6f2 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -51,7 +51,7 @@ DEFER: maybe-loop : springies-window* ( -- ) C[ display ] >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 diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor index ab2abeec5b..2ef740e580 100644 --- a/extra/ui/gadgets/slate/slate.factor +++ b/extra/ui/gadgets/slate/slate.factor @@ -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 ; : ( 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 ; \ No newline at end of file