Fix move and resize window bugs in Factory

diff --git a/contrib/factory/factory.factor b/contrib/factory/factory.factor
index 5a31297bc2c64826d109ded725ff6c576c1c46c5..e88161636e2508f44a5828f9ce2ed5163144ab6f 100644 (file)
--- a/contrib/factory/factory.factor
+++ b/contrib/factory/factory.factor
@@ -1,6 +1,6 @@
 USING: kernel alien compiler namespaces generic math sequences hashtables io
 arrays words prettyprint concurrency process
-rectangle x11 x concurrent-widgets ;
+vars rectangle x11 x concurrent-widgets ;
 
 IN: factory
 
@@ -49,61 +49,90 @@ create-gc dup
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: MouseMask ( -- mask )
-[ ButtonPressMask ButtonReleaseMask PointerMotionMask ]
-0 [ execute bitor ] reduce ;
+VARS: event frame push position ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: drag-mouse-loop ( push last quot -- push release )
-MouseMask mask-event XAnyEvent-type            ! push last quot type
-{ { [ dup MotionNotify = ]
-    [ drop 3dup call nip mouse-sensor swap drag-mouse-loop ] }
-{ [ dup ButtonRelease = ]
-  [ drop 3dup nip f swap call 2drop
-    mouse-sensor ungrab-server CurrentTime ungrab-pointer flush-dpy ] }
-{ [ t ]
-  [ drop "drag-mouse-loop ignoring event" print flush drag-mouse-loop ] }
-} cond ;
+: event-type ( -- type ) event> XAnyEvent-type ;
 
-: drag-mouse ( quot -- push release )
-MouseMask grab-pointer grab-server mouse-sensor f rot drag-mouse-loop ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: drag-mouse% [ drag-mouse ] with-window-object ;
+: drag-offset ( -- offset ) position> push> v- ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: ((draw-move-outline)) ( a b - )
-swap v- window-position v+ window-size <rect> root get draw-rect+ ;
+: draw-rubber-band ( <rect> -- )
+root get [ drag-gc get [ draw-rect ] with-gcontext ] with-win ;
 
-: (draw-move-outline) ( push last -- )
-dupd dup [ ((draw-move-outline)) ] [ 2drop ] if
-mouse-sensor ((draw-move-outline)) flush-dpy ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! drag-move-frame
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: draw-move-outline ( push last -- )
-drag-gc get [ (draw-move-outline) ] with-gcontext ;
+: draw-frame-outline ( -- )
+drag-offset frame> window-position% v+ frame> window-size% <rect>
+draw-rubber-band ;
 
-: drag-move-window ( -- )
-[ draw-move-outline ] drag-mouse swap v- window-position v+ move-window ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: drag-move-window% [ drag-move-window raise-window ] with-window-object ;
+: drag-move-frame-loop ( -- )
+next-event >event
+{ { [ event-type MotionNotify = ]
+    [ draw-frame-outline
+      event> XMotionEvent-root-position >position
+      draw-frame-outline
+      drag-move-frame-loop ] }
+  { [ event-type ButtonRelease = ]
+    [ draw-frame-outline
+      drag-offset frame> window-position% v+   frame> move-window% ] }
+  { [ t ]
+    [ "[drag-move-frame-loop] Ignoring event type: " write
+      event-type event-type>name write terpri flush
+      drag-move-frame-loop ] } }
+cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: ((draw-resize-outline)) ( bottom-right -- )
-window-position v- window-position swap <rect> root get draw-rect+ ;
+: drag-move-frame ( event <wm-frame> -- )
+[ >frame >event
+  event> XButtonEvent-root-position >push
+  event> XButtonEvent-root-position >position
+  draw-frame-outline
+  drag-move-frame-loop ]
+with-scope ;
 
-: (draw-resize-outline) ( push last -- )
-nip dup [ ((draw-resize-outline)) ] [ drop ] if
-mouse-sensor ((draw-resize-outline)) flush-dpy ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! drag-size-frame
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-size-outline ( -- )
+frame> window-position% position> over v- <rect> draw-rubber-band ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: draw-resize-outline ( push last -- )
-drag-gc get [ (draw-resize-outline) ] with-gcontext ;
+: drag-size-frame-loop ( -- )
+next-event >event
+{ { [ event-type MotionNotify = ]
+    [ draw-size-outline
+      event> XMotionEvent-root-position >position
+      draw-size-outline
+      drag-size-frame-loop ] }
+  { [ event-type ButtonRelease = ]
+    [ draw-size-outline
+      position> frame> window-position% v- frame> resize-window%
+      frame> layout-frame ] }
+  { [ t ]
+    [ "[drag-size-frame-loop] ignoring event" print flush
+      drag-size-frame-loop ] } }
+cond ;
 
-: drag-resize-window ( -- )
-[ draw-resize-outline ] drag-mouse nip window-position v- resize-window ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: drag-resize-window% [ drag-resize-window ] with-window-object ;
+: drag-size-frame ( event <wm-frame> -- )
+[ >frame >event
+  event> XButtonEvent-root-position >position
+  draw-size-outline
+  drag-size-frame-loop ]
+with-scope ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -122,32 +151,24 @@ GENERIC: execute-size-request
 
 TUPLE: wm-root ;
 
-: create-wm-root ( window -- )
-  >r dpy get r> <window>                       ! <window>
-  <wm-root>                                    ! <window> <wm-root>
-  [ set-delegate ] keep                                ! <wm-root>
-  [ add-to-window-table ] keep                 ! <wm-root>
-
-  [ SubstructureRedirectMask
-    SubstructureNotifyMask
-    ButtonPressMask
-    ButtonReleaseMask
-    KeyPressMask
-    KeyReleaseMask ] 0 [ execute bitor ] reduce        ! <wm-frame> mask
+: wm-root-mask ( -- mask )
+[ SubstructureRedirectMask
+  SubstructureNotifyMask
+  ButtonPressMask
+  ButtonReleaseMask
+  KeyPressMask
+  KeyReleaseMask ] bitmask ;
 
-  over select-input% ;                         ! <wm-frame>
+: create-wm-root ( window-id -- <wm-root> )
+dpy get swap <window> <wm-root> tuck set-delegate dup add-to-window-table
+wm-root-mask over select-input% ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! M: wm-root handle-map-request-event
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : id>obj ( id -- obj )
-  dup                  ! id id
-  window-table get hash        ! id obj-or-f
-  dup
-  [ swap drop ]
-  [ drop >r dpy get r> <window> ]
-  if ;
+dup window-table get hash dup [ nip ] [ drop dpy get swap <window> ] if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -291,33 +312,31 @@ M: wm-root handle-button-press-event ( event wm-root -- )
 : True 1 ;
 : False 0 ;
 
-SYMBOL: f1-keycode   67 f1-keycode set-global
-SYMBOL: f2-keycode   68 f2-keycode set-global
-SYMBOL: f3-keycode   69 f3-keycode set-global
-SYMBOL: f4-keycode   70 f4-keycode set-global
+: f1-keycode ( -- code ) 67 ;
+: f2-keycode ( -- code ) 68 ;
+: f3-keycode ( -- code ) 69 ;
+: f4-keycode ( -- code ) 70 ;
 
 : grab-keys ( -- )
-f1-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key
-f2-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key
-f3-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key
-f4-keycode get Mod1Mask False GrabModeAsync GrabModeAsync grab-key ;
+f1-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
+f2-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
+f3-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key
+f4-keycode Mod1Mask False GrabModeAsync GrabModeAsync grab-key ;
 
 M: wm-root handle-key-press-event ( event wm-root -- )
 drop
-{ { [ dup XKeyEvent-keycode f1-keycode get = ] [ workspace-1 get switch-to ] }
-  { [ dup XKeyEvent-keycode f2-keycode get = ] [ workspace-2 get switch-to ] }
-  { [ dup XKeyEvent-keycode f3-keycode get = ] [ workspace-3 get switch-to ] }
-  { [ dup XKeyEvent-keycode f4-keycode get = ] [ workspace-4 get switch-to ] }
+{ { [ dup XKeyEvent-keycode f1-keycode = ] [ workspace-1 get switch-to ] }
+  { [ dup XKeyEvent-keycode f2-keycode = ] [ workspace-2 get switch-to ] }
+  { [ dup XKeyEvent-keycode f3-keycode = ] [ workspace-3 get switch-to ] }
+  { [ dup XKeyEvent-keycode f4-keycode = ] [ workspace-4 get switch-to ] }
   { [ t ] [ "wm-root ignoring key press" print drop ] } } cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 TUPLE: wm-child ;
 
-: create-wm-child ( id -- <wm-child> )
-  >r dpy get r> <window> <wm-child>            ! <window> <wm-child>
-  [ set-delegate ] keep
-  [ add-to-window-table ] keep ;
+: create-wm-child ( window-id -- <wm-child> )
+dpy get swap <window> <wm-child> tuck set-delegate dup add-to-window-table ;
 
 M: wm-child handle-property-event ( event <wm-child> -- )
   "A <wm-child> received a property event" print flush
@@ -330,27 +349,24 @@ TUPLE: wm-frame child ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: create-wm-frame ( child -- <wm-frame> )
-  >r create-window-object r>                   ! <window> child
-  <wm-frame>                                   ! <window> <wm-frame>
-  [ set-delegate ] keep                                ! <wm-frame>
-  [ add-to-window-table ] keep                 ! <wm-frame>
-  
-  [ SubstructureRedirectMask
-    SubstructureNotifyMask
-    ExposureMask
-    ButtonPressMask
-    ButtonReleaseMask
-    EnterWindowMask ] 0 [ execute bitor ] reduce       ! <wm-frame> mask
+: wm-frame-mask ( -- mask )
+[ SubstructureRedirectMask
+  SubstructureNotifyMask
+  ExposureMask
+  ButtonPressMask
+  ButtonReleaseMask
+  PointerMotionMask
+  EnterWindowMask ] bitmask ;
 
-  over select-input% ;                         ! <wm-frame>
+: create-wm-frame ( <wm-child> -- <wm-frame> )
+<wm-frame> create-window-object over set-delegate dup add-to-window-table
+wm-frame-mask over select-input% ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : update-title ( <wm-frame> -- )
 dup clear-window%
-{ 5 1 } swap dup wm-frame-child fetch-name% swap
-[ draw-string-top-left ] with-window-object ;
+{ 5 1 } swap dup wm-frame-child fetch-name% swap draw-string-top-left% ;
 
 : manage-window ( window -- )
   flush-dpy
@@ -402,11 +418,10 @@ dup clear-window%
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : destroy-window-event-match? ( event <wm-frame> -- ? )
-  window-id swap XDestroyWindowEvent-window = ;
+window-id swap XDestroyWindowEvent-window = ;
 
 M: wm-frame handle-destroy-window-event ( event <wm-frame> -- )
-  2dup destroy-window-event-match?
-  [ destroy-window% drop ] [ drop drop ] if ;
+2dup destroy-window-event-match? [ destroy-window% drop ] [ 2drop ] if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -420,7 +435,7 @@ M: wm-frame handle-map-request-event ( event <wm-frame> -- )
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : map-event-match? ( event <wm-frame> -- ? )
-  window-id swap XMapEvent-window = ;
+window-id swap XMapEvent-window = ;
 
 M: wm-frame handle-map-event ( event <wm-frame> -- )
   2dup map-event-match?
@@ -491,14 +506,10 @@ M: wm-frame handle-unmap-event ( event frame )
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: drag-move-frame ( frame -- ) drag-move-window% ;
-
-: drag-resize-frame ( frame -- ) dup drag-resize-window% layout-frame ;
-
 M: wm-frame handle-button-press-event ( event frame )
   over XButtonEvent-button                             ! event frame button
-  { { [ dup Button1 = ] [ drop nip drag-move-frame ] }
-    { [ dup Button2 = ] [ drop nip drag-resize-frame ] }
+  { { [ dup Button1 = ] [ drop drag-move-frame ] }
+    { [ dup Button2 = ] [ drop drag-size-frame ] }
     { [ dup Button3 = ] [ drop nip unmap-window% ] }
     { [ t ] [ drop drop drop ] } }
   cond ;
@@ -656,3 +667,7 @@ SYMBOL: window-list
   setup-workspace-menu
   manage-existing-windows
   [ concurrent-event-loop ] spawn ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: shells USE: listener : factory f start-factory listener ;
\ No newline at end of file

diff --git a/contrib/factory/load.factor b/contrib/factory/load.factor
index 8c0aa2ff8dcaf2f84a26b48275ca8d98d690681e..69f8a477f47dd953a15f081785802449fac3624b 100644 (file)
--- a/contrib/factory/load.factor
+++ b/contrib/factory/load.factor
@@ -1,3 +1,3 @@
-REQUIRES: process concurrency x11 ;
+REQUIRES: process concurrency x11 vars ;
 
 PROVIDE: factory { "factory.factor" } ;