extra/x/widgets/wm/frame/frame.factor

   1
   2 USING: kernel io combinators namespaces quotations arrays sequences
   3        math math.vectors
   4        x11.xlib x11.constants
   5        mortar mortar.sugar slot-accessors
   6        geom.rect
   7        math.bitwise
   8        x x.gc x.widgets
   9        x.widgets.button
  10        x.widgets.wm.child
  11        x.widgets.wm.frame.drag.move
  12        x.widgets.wm.frame.drag.size ;
  13
  14 IN: x.widgets.wm.frame
  15
  16 SYMBOL: <wm-frame>
  17
  18 <wm-frame> <widget> { "child" "gc" "last-state" } accessors define-simple-class
  19
  20 <wm-frame> "create" !( id <wm-frame> -- wm-frame ) [
  21   new-empty
  22   swap <wm-child> new* >>child
  23   <gc> new* "white" <-- set-foreground >>gc
  24
  25   {
  26     SubstructureRedirectMask
  27     ExposureMask
  28     ButtonPressMask
  29     ButtonReleaseMask
  30     ButtonMotionMask
  31     EnterWindowMask
  32     ! experimental masks
  33     SubstructureNotifyMask
  34   } flags
  35   >>mask
  36
  37   <- init-widget
  38   "cornflowerblue" <-- set-background
  39   dup $child <- position <-- move
  40   dup $child over <-- reparent drop
  41   <- position-child
  42   <- fit-to-child
  43   <- make-frame-button
  44
  45   <- map-subwindows
  46   <- map
  47 ] add-class-method
  48
  49 SYMBOL: WM_PROTOCOLS
  50 SYMBOL: WM_DELETE_WINDOW
  51
  52 : init-atoms ( -- )
  53 "WM_PROTOCOLS" 0 intern-atom WM_PROTOCOLS set
  54 "WM_DELETE_WINDOW" 0 intern-atom WM_DELETE_WINDOW set ;
  55
  56 <wm-frame> {
  57
  58 "fit-to-child" !( wm-frame -- wm-frame )
  59   [ dup $child <- size { 10 20 } v+ <-- resize ]
  60
  61 "position-child" !( wm-frame -- wm-frame )
  62   [ dup $child { 5 15 } <-- move drop ]
  63
  64 "set-child-size" !( wm-frame size -- frame )
  65   [ >r dup $child r> <-- resize drop <- fit-to-child ]
  66
  67 "set-child-width" !( wm-frame width -- frame )
  68   [ >r dup $child r> <- set-width drop <- fit-to-child ]
  69
  70 "set-child-height" !( wm-frame height -- frame )
  71   [ >r dup $child r> <- set-height drop <- fit-to-child ]
  72
  73 "adjust-child" !( wm-frame -- wm-frame )
  74   [ dup $child over <- size { 10 20 } v- <-- resize drop ]
  75
  76 "update-title" !( wm-frame -- wm-frame )
  77   [ <- clear
  78     dup >r
  79     ! dup $gc { 5 1 } pick $child <- fetch-name <--- draw-string/top-left
  80     dup $gc { 5 11 } pick $child <- fetch-name <---- draw-string
  81     r> ]
  82
  83 "delete-child" !( wm-frame -- wm-frame ) [
  84   dup $child WM_PROTOCOLS get WM_DELETE_WINDOW get <--- send-client-message
  85   drop ]
  86
  87 "drag-move" !( event wm-frame -- ) [ <wm-frame-drag-move> new* ]
  88
  89 "drag-size" !( event wm-frame -- ) [ <wm-frame-drag-size> new* ]
  90
  91 "make-frame-button" !( frame -- frame ) [
  92 <button> new*
  93   over <-- reparent
  94   "" >>text
  95   over [ <- unmap drop ]        curry >>action-1
  96   over [ <- delete-child drop ] curry >>action-3
  97   { 9 9 } <-- resize
  98   NorthEastGravity <-- set-gravity
  99   "white" <-- set-background
 100   over <- width 9 -  5 -  3 2array <-- move
 101   drop ]
 102
 103 ! !!!!!!!!!! Event handlers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 104
 105 "handle-enter-window" !( event wm-frame -- )
 106   [ nip $child RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
 107
 108 "handle-expose" !( event wm-frame -- ) [ nip <- clear <- update-title drop ]
 109
 110 "handle-button-press" !( event wm-frame -- ) [
 111   over XButtonEvent-button
 112   { { [ dup Button1 = ] [ drop <- drag-move ] }
 113     { [ dup Button2 = ] [ drop <- drag-size ] }
 114     { [ t ] [ 3drop ] } }
 115   cond ]
 116
 117 "handle-map" !( event wm-frame -- )
 118   [ "<wm-frame> handle-map :: ignoring values" print flush 2drop ]
 119
 120 "handle-unmap" !( event wm-frame -- ) [ nip <- unmap drop ]
 121
 122 "handle-destroy-window" !( event wm-frame -- ) [
 123   nip dup $child <- remove-from-window-table drop
 124   <- remove-from-window-table <- destroy ]
 125
 126 "handle-configure-request" !( event frame -- ) [
 127   { { [ over dup CWX? swap CWY? and ]
 128       [ over XConfigureRequestEvent-position <-- move ] }
 129     { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
 130     { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
 131     { [ t ] [ "<wm-frame> handle-configure-request :: move not requested"
 132               print flush ] } }
 133   cond
 134
 135   { { [ over dup CWWidth? swap CWHeight? and ]
 136       [ over XConfigureRequestEvent-size <-- set-child-size ] }
 137     { [ over CWWidth? ]
 138       [ over XConfigureRequestEvent-width <-- set-child-width ] }
 139     { [ over CWHeight? ]
 140       [ over XConfigureRequestEvent-height <-- set-child-height ] }
 141     { [ t ]
 142       [ "<wm-frame> handle-configure-request :: resize not requested"
 143         print flush ] } }
 144   cond
 145   2drop ]
 146
 147 } add-methods
 148
 149 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 150
 151 : wm-frame-maximize ( wm-frame -- wm-frame )
 152 <- save-state
 153 { 0 0 } <-- move
 154 dup $dpy $default-root <- size
 155   <-- resize
 156 <- adjust-child
 157 <- raise ;
 158
 159 : wm-frame-maximize-vertical ( wm-frame -- wm-frame )
 160 0 <-- set-y
 161 dup $dpy $default-root <- height
 162   <-- set-height
 163 <- adjust-child ;
 164
 165 <wm-frame> "save-state" !( wm-frame -- wm-frame ) [
 166   dup <- position
 167   over <- size
 168     <rect> new
 169   >>last-state
 170 ] add-method
 171
 172 <wm-frame> "restore-state" !( wm-frame -- wm-frame ) [
 173   dup $last-state $pos <-- move
 174   dup $last-state $dim <-- resize
 175   <- adjust-child
 176 ] add-method
 177
 178 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 179