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

extra/automata/ui/ui.factor

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

extra/boids/ui/ui.factor

@@ -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
 

extra/cfdg/cfdg.factor

@@ -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 ;

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 ;
+

extra/golden-section/golden-section.factor

@@ -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 ;
 

extra/lsys/ui/ui.factor

@@ -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
 
 {
 

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

extra/springies/ui/ui.factor

@@ -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

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
+TUPLE: slate < gadget action pdim graft ungraft ;
-       button-down
-       button-up
-       key-down
-       key-up ;
 
 : <slate> ( action -- slate )
-  slate construct-gadget
+  slate new-gadget
-  tuck set-slate-action
+    swap        >>action
-  { 100 100 } over set-slate-dim
+    { 100 100 } >>pdim
-  [ ] over set-slate-graft
+    [ ]         >>graft
-  [ ] over set-slate-ungraft ;
+    [ ]         >>ungraft ;
 
-M: slate pref-dim* ( slate -- dim ) slate-dim ;
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
 
-M: slate draw-gadget* ( slate -- )
+M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
-   origin get swap slate-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 ;