libs/xog/xog-base-window-impl.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; X11 OOF GUI -- BaseWindow class implementation
   7 ;; (included from "xog-base-window.f")
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;; we need locals for rounded rect drawing methods
  10 use-libs: locals x11
  11
  12 also x11 also xconst
  13
  14 false value (basewin-debug-show-events?)
  15
  16 false constant xog-window-debug-child-delete?
  17 false constant xog-window-debug-child-create?
  18 false constant xog-window-debug-dispatch?
  19 false constant xog-window-debug-kbfocus?
  20
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; destroy all windows when X11 display is closed
  24 ;;
  25 ..: (xog-dpy-before-close)  ( -- )
  26   BaseWindow ::invoke BaseWindow (display-closing)
  27 ;..
  28
  29
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 BaseWindow method: (debug-id.)  ( -- )
  32   ." <" class-name type ." :" self .hex8 ." :" winid .hex8 ." :" get-caption safe-type ." >"
  33 ;
  34
  35 BaseWindow method: (debug-dump-children)  ( indent -- )
  36   dup spaces (debug-id.) cr
  37   first-child begin ?dup while
  38   over 2+ over invoke (debug-dump-children) invoke next-sibling repeat
  39   drop
  40 ;
  41
  42
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;; global window list management
  45 ;;
  46 BaseWindow method: (register)  ( -- )
  47   (winlist-tail) to (prev-win) self to (winlist-tail)
  48     \ ." registered window " win . ." self=0x" self .hex8 ."  winlist-tail=0x" (winlist-tail) .hex8 cr
  49 ;
  50
  51 BaseWindow method: (unregister)  ( -- )
  52   (winlist-tail) self = if
  53     (prev-win) to (winlist-tail)
  54   else
  55     ;; find next window
  56     (winlist-tail) begin dup invoke (prev-win) dup while dup self = not-while nip repeat
  57     not-?abort" cannot find previous window"
  58     (prev-win) swap var^ (prev-win) !
  59   endif
  60 ;
  61
  62 BaseWindow method: find-by-wid  ( wid -- ptr//0 )
  63   dup ifnot exit endif  ;; just in case
  64   (winlist-tail) begin dup while 2dup invoke winid = not-while invoke (prev-win) repeat nip
  65 ;
  66
  67
  68 ;; destroy all windows when X11 display is closed
  69 BaseWindow method: (display-closing)  ( -- )
  70     \ ." killing all windows...\n"
  71   begin (winlist-tail) ?dup while (winlist-tail) invoke (destroy) repeat
  72 ;
  73
  74
  75 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76 ;; find window and dispatch the event
  77 ;;
  78 ;; this calls parent sink, then does self
  79 BaseWindow method: (dispatch-event-sink)  ( event -- )
  80   to (event)
  81   [ xog-window-debug-dispatch? ] [IF]
  82     ."   going up; curr is " (debug-id.) cr
  83   [ENDIF]
  84   parent ?dup if (event) swap invoke (dispatch-event-sink) endif
  85   [ xog-window-debug-dispatch? ] [IF]
  86     ."   calling \`(sink-event)\`; curr is " (debug-id.) cr
  87   [ENDIF]
  88   (event) @ if (sink-event) endif
  89   0 to (event)
  90 ;
  91
  92 BaseWindow method: (dispatch-event-internal)  ( event -- )
  93   to (event)
  94   ;; sink
  95   parent ?dup if (event) swap invoke (dispatch-event-sink) endif
  96   ;; destination
  97   [ xog-window-debug-dispatch? ] [IF]
  98     ."   calling \`(process-event)\`; curr is " (debug-id.) cr
  99   [ENDIF]
 100   (event) @ ifnot exit endif (process-event)
 101   ;; bubble
 102   parent begin dup while (event) @ while
 103     [ xog-window-debug-dispatch? ] [IF]
 104       ."   calling \`(bubble-event)\`; curr is " dup invoke (debug-id.) cr
 105     [ENDIF]
 106     (event) over var^ (event) !  ;; hack: set (event) in current instptr
 107     dup invoke (bubble-event)
 108     dup var^ (event) 0!  ;; and clear it, why not
 109   invoke parent repeat drop
 110 ;
 111
 112 BaseWindow method: dispatch-event  ( event -- dispatch-success-flag )
 113   dup XAnyEvent display @ xog-dpy = ifnot drop false exit endif
 114   dup XAnyEvent window @ find-by-wid dup if
 115     [ xog-window-debug-dispatch? ] [IF]
 116       endcr ." *********** dispatching winid " over XAnyEvent window @ .hex8 ."  to " dup invoke (debug-id.) cr
 117       ."   EVENT: type=" over @ . over @ get-x11-event-type-name type cr
 118     [ENDIF]
 119     invoke (dispatch-event-internal) true
 120   else
 121     [ xog-window-debug-dispatch? ] [IF]
 122       endcr ." cannot dispatch winid " over XAnyEvent window @ .hex8 cr
 123       ."   EVENT: type=" over @ . over @ get-x11-event-type-name type cr
 124     [ENDIF]
 125     nip
 126   endif
 127 ;
 128
 129
 130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 ;; various helper methods
 132 ;;
 133
 134 BaseWindow method: prev-sibling ( -- childobj // 0 )
 135   parent dup if
 136     invoke first-child 0 swap begin ( prev curr ) dup while
 137       dup self = if drop exit endif
 138     nip dup invoke next-sibling repeat nip
 139   endif
 140 ;
 141
 142 BaseWindow method: top-parent  ( -- obj )
 143   parent ?dup if invoke top-parent else self endif
 144 ;
 145
 146
 147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 148 ;; children list management
 149 ;;
 150
 151 ;; simple assign, no checks, no nothing
 152 BaseWindow method: (focused-child!)  ( childobj -- )  to focused-child ;
 153
 154
 155 BaseWindow method: (remove-child)  ( childobj -- )
 156   \ ?dup ifnot exit endif
 157   dup not-?abort" cannot orphan already orphan window"
 158   dup invoke parent self <> ?abort" cannot orphan alien window"
 159   dup focused-child = if 0 to focused-child endif  ;; just in case
 160   dup invoke prev-sibling  ( childobj prevchildobj/0 )
 161   over var^ parent 0!  ;; orphan it
 162   ?dup if over invoke next-sibling swap var^ next-sibling !  ;; remove from the list
 163   else dup invoke next-sibling to first-child endif  ;; first one
 164   var^ next-sibling 0!
 165 ;
 166
 167
 168 BaseWindow method: (append-child)  ( childobj -- )
 169   ?dup ifnot exit endif
 170   dup invoke parent ?abort" cannot parent already parented window"
 171   dup invoke next-sibling ?abort" cannot parent already parented window"
 172   self over var^ parent !  ;; adopt it
 173   first-child ?dup if
 174     begin dup invoke next-sibling ?dup while nip repeat
 175     var^ next-sibling !
 176   else to first-child endif  ;; first child
 177 ;
 178
 179 BaseWindow method: append-child  ( childobj -- )
 180   dup (append-child)
 181   focused-child ifnot dup invoke can-focus? if dup to focused-child endif endif drop
 182 ;
 183
 184
 185 ;; called from MapNotify
 186 BaseWindow method: (map-children)  ( -- )
 187   is-valid? ifnot exit endif
 188   first-child begin ?dup while
 189     dup invoke visible? over invoke mapped? or if
 190       [ xog-window-debug-child-create? ] [IF]
 191         endcr ." mapchild: " dup invoke (debug-id.) cr
 192       [ENDIF]
 193       dup var^ mapped? 0!
 194       dup var^ visible? 1!
 195       dup invoke (map-children)
 196     endif
 197   invoke next-sibling repeat
 198 ;
 199
 200
 201 BaseWindow method: (create-children)  ( -- )
 202   is-valid? ifnot exit endif
 203   first-child begin ?dup while
 204     dup invoke visible? over invoke mapped? or if
 205       [ xog-window-debug-child-create? ] [IF]
 206         endcr ." createchild: " dup invoke (debug-id.) cr
 207       [ENDIF]
 208       self over invoke create-ex not-?abort" cannot create child window"
 209     endif
 210   invoke next-sibling repeat
 211 ;
 212
 213
 214 BaseWindow method: (focus-child)  ( -- )
 215   focused-child ?dup if
 216       \ endcr ." ---self " (debug-id.) ."  is going to focus child " dup invoke (debug-id.) cr
 217     invoke (focus-child)
 218   else
 219       \ endcr ." ***FOCUSING: " (debug-id.) cr
 220     focus
 221   endif
 222 ;
 223
 224
 225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 226 ;; children traversal
 227 ;;
 228
 229 ;; this does depth-first traversal
 230 ;; cfa: ( -- stopflag )
 231 ;; self is set to the corresponding window
 232 BaseWindow method: foreach-child  ( cfa -- exitcode )
 233   first-child begin ?dup while  ( cfa childobj )
 234     2dup 2>r invoke foreach-child ?dup if 2rdrop exit endif
 235   2r> invoke next-sibling repeat
 236   execute-tail  ;; self is last
 237 ;
 238
 239
 240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 241 ;; default window class and title
 242 ;;
 243 BaseWindow method: (get-class)  ( -- addr count )  " UrForth BaseWindow" ;
 244 BaseWindow method: get-caption  ( -- addr count )  " UrForth Window" ;
 245
 246
 247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 248 ;; send various internal events
 249 ;;
 250 BaseWindow method: (send-close-event)  ( -- )
 251   XEvent @sizeof ralloca >r
 252   r@ XEvent @sizeof erase
 253   ClientMessage r@ XClientMessageEvent type !
 254   r@ XClientMessageEvent send_event 1!
 255   winid r@ XClientMessageEvent window !
 256   XOF_INTERNAL_CLOSE r@ XClientMessageEvent message_type !
 257   32 r@ XClientMessageEvent format !
 258   r@ 0 true winid xog-dpy XSendEvent drop
 259   rdrop XEvent @sizeof rdealloca
 260 ;
 261
 262
 263 BaseWindow method: (send-expose-event)  ( -- )
 264   XEvent @sizeof ralloca >r
 265   r@ XEvent @sizeof erase
 266   Expose r@ XExposeEvent type !
 267   r@ XExposeEvent send_event 1!
 268   winid r@ XExposeEvent window !
 269   r@ XExposeEvent x 0!
 270   r@ XExposeEvent y 0!
 271   width r@ XExposeEvent width !
 272   height r@ XExposeEvent height !
 273   r@ 0 true winid xog-dpy XSendEvent drop
 274   rdrop XEvent @sizeof rdealloca
 275 ;
 276
 277
 278 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 279 ;; reset all internal fields
 280 ;;
 281 BaseWindow method: init  ( -- )
 282   0 to (prev-win)
 283
 284   0 to parent
 285   0 to next-sibling
 286   0 to first-child
 287   0 to focused-child
 288
 289   0 to min-width 0 to min-height
 290   0 to max-width 0 to max-height
 291   false to motion-events?
 292   true to (can-focus?)
 293
 294   0 to posx 0 to posy
 295   512 to width 256 to height
 296
 297   0 to winid 0 to wingc 0 to winpixmap
 298   false to visible?
 299   false to invalidate-sent?
 300   false to close-sent?
 301   false to mapped?
 302   false to focused?
 303   true to dirty?
 304   true to double-buffered?
 305   true to (first-paint?)
 306
 307   0 to current-fg-color 0 to current-bg-color
 308 ;
 309
 310
 311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 312 ;; low-level window methods
 313 ;;
 314 BaseWindow method: (get-keysym)  ( event -- keysym )
 315   0 swap XKeyEvent keycode @ xog-dpy XKeycodeToKeysym
 316 ;
 317
 318 BaseWindow method: (destroy-cleanup)  ( -- )
 319   (deinit-gc) (deinit-pixmap) (unregister) on-destroyed init
 320 ;
 321
 322 BaseWindow method: (init-gc)  ( -- )
 323   0 0 my-drawable xog-dpy XCreateGC to wingc drop  ;; "drop" due to "..."
 324   set-line-solid
 325   ;; invalidate colors
 326   xog-black-color 1+ to current-bg-color
 327   xog-white-color 1+ to current-fg-color
 328   ;; background is black, foreground is white
 329   xog-black-color set-bg-color
 330   xog-white-color set-color
 331 ;
 332
 333 BaseWindow method: (deinit-gc)  ( -- )
 334   wingc ?dup if xog-dpy XFreeGC 0 to wingc endif
 335 ;
 336
 337 BaseWindow method: (init-pixmap)  ( -- )
 338   (deinit-pixmap) xog-dpy if
 339     xog-dpy DefaultScreen xog-dpy XDefaultDepth height 1 max width 1 max winid xog-dpy XCreatePixmap
 340     to winpixmap dirty!
 341   endif
 342 ;
 343
 344 BaseWindow method: (deinit-pixmap)  ( -- )
 345   winpixmap if xog-dpy if winpixmap xog-dpy XFreePixmap endif 0 to winpixmap endif
 346 ;
 347
 348 BaseWindow method: (set-xhints)  ( -- )
 349   (get-class) ensure-asciiz >r
 350   ;; class hints
 351   XClassHint @sizeof ralloca >r
 352   r@ XClassHint @sizeof erase
 353   dup r@ XClassHint res_name ! r@ XClassHint res_class !
 354   r@  ;; class hints address
 355   ;; WM hints
 356   XWMHints @sizeof ralloca >r
 357   r@ XWMHints @sizeof erase
 358   InputHint r@ XWMHints flags !
 359   true r@ XWMHints input !
 360   r@  ;; WM hints address
 361   ;; size hints
 362   XSizeHints @sizeof ralloca >r
 363   r@ XSizeHints @sizeof erase
 364   min-width 0 max min-height 0 max or if
 365     PMinSize r@ XSizeHints flags or!
 366     min-width r@ XSizeHints min_width !
 367     min-height r@ XSizeHints min_height !
 368   endif
 369   max-width 0 max max-height 0 max or if
 370     PMaxSize r@ XSizeHints flags or!
 371     max-width r@ XSizeHints max_width !
 372     max-height r@ XSizeHints max_height !
 373   endif
 374   r@  ;; size hints address
 375   0 0 0 0  ;; argc, argv, iconname windowname
 376   winid xog-dpy XSetWMProperties drop
 377   ;; free structures
 378   rdrop XSizeHints @sizeof rdealloca
 379   rdrop XWMHints @sizeof rdealloca
 380   rdrop XClassHint @sizeof rdealloca
 381   r> free-asciiz
 382 ;
 383
 384
 385 ;; destroy child windows, and this window
 386 BaseWindow method: (destroy)  ( -- )
 387   [ xog-window-debug-child-delete? ] [IF]
 388     endcr ." removing chldren of " (debug-id.) cr
 389   [ENDIF]
 390   ;; destroy children
 391   begin first-child ?dup while invoke (destroy) repeat
 392   ;; remove ourself from the parent list
 393   parent ?dup if
 394     [ xog-window-debug-child-delete? ] [IF]
 395       endcr ." removing " (debug-id.) ."  from the parent\n"
 396       ."  parent is " dup invoke (debug-id.) cr
 397     [ENDIF]
 398     self swap invoke (remove-child)
 399   endif
 400   [ xog-window-debug-child-delete? ] [IF]
 401     endcr ." removing " (debug-id.) ."  from the parent\n"
 402   [ENDIF]
 403   xog-dpy if
 404     winid ?dup if
 405       [ xog-window-debug-child-delete? ] [IF]
 406         endcr ." destroying xwin of " (debug-id.) cr
 407       [ENDIF]
 408       xog-dpy XDestroyWindow drop
 409     endif
 410   endif
 411   winid if
 412     [ xog-window-debug-child-delete? ] [IF]
 413       endcr ." calling \`(destroy-cleanup)\` of " (debug-id.) cr
 414     [ENDIF]
 415     0 to winid (destroy-cleanup)
 416   endif
 417 ;
 418
 419
 420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 421 ;; high-level window creation
 422 ;;
 423 BaseWindow method: create-ex  ( parentobj -- successflag )
 424   xog-dpy 0= winid 0<> or if drop false exit endif
 425   ;; check for valid parent
 426   dup if
 427     dup invoke winid ifnot drop false exit endif
 428     parent ?dup if over <> if drop false exit endif endif
 429   endif
 430   >r  ;; save parent object
 431   ;; XCreateSimpleWindow arguments
 432   bg-color         ;; background color
 433   xog-black-color  ;; border color
 434   0                ;; border width
 435   ;; position (we cannot create windows with zero dimensions)
 436   height 1 max dup to height
 437   width 1 max dup to width
 438   posy posx  ;; h w y x
 439     [ xog-window-debug-child-create? ] [IF]
 440       endcr ." creating " (debug-id.) 2dup ."  x=" . ." y=" . 2over ." w=" . ." h=" . cr
 441     [ENDIF]
 442   r@ if r@ invoke winid else xog-dpy XDefaultRootWindow endif  ;; parent
 443   xog-dpy XCreateSimpleWindow dup to winid ifnot rdrop false exit endif  ;; oops, cannot create a window
 444   ;; register in global window list
 445   (register)
 446   r> ?dup ifnot
 447     ;; set title
 448     get-caption 0 255 clamp
 449     ensure-asciiz >r winid xog-dpy XStoreName r> free-asciiz
 450     ;; set WM protocols (only for top-level windows)
 451     WM_TAKE_FOCUS >r WM_DELETE_WINDOW >r
 452     2 rp@ winid xog-dpy XSetWMProtocols drop 2rdrop
 453     ;; set NETWM type
 454     NET_WM_WINDOW_TYPE_NORMAL >r
 455     1 rp@ 0 ( PropModeReplace) 32 ( bits) XA_ATOM NET_WM_WINDOW_TYPE winid xog-dpy XChangeProperty drop rdrop
 456   else
 457     ;; append to parent (this also sets "parent" field)
 458     parent if drop else self swap invoke (append-child) endif
 459   endif
 460   ;; set input mask
 461   [ NoEventMask
 462     KeyPressMask or
 463     KeyReleaseMask or
 464     ButtonPressMask or
 465     ButtonReleaseMask or
 466     \ EnterWindowMask or
 467     \ LeaveWindowMask or
 468     \ PointerMotionMask or
 469     \ PointerMotionHintMask or
 470     \ Button1MotionMask or
 471     \ Button2MotionMask or
 472     \ Button3MotionMask or
 473     \ Button4MotionMask or
 474     \ Button5MotionMask or
 475     \ ButtonMotionMask or
 476     \ KeymapStateMask or
 477     ExposureMask or
 478     VisibilityChangeMask or
 479     StructureNotifyMask or
 480     \ ResizeRedirectMask or
 481     \ SubstructureNotifyMask or
 482     \ SubstructureRedirectMask or
 483     FocusChangeMask or
 484     PropertyChangeMask or
 485     \ ColormapChangeMask or
 486     \ OwnerGrabButtonMask or
 487   ] literal motion-events? if PointerMotionMask or endif
 488   winid xog-dpy XSelectInput
 489   parent ifnot (set-xhints) endif
 490   ;; create pixmap
 491   double-buffered? if
 492     (init-pixmap)
 493     ;; replace window background with empty one-pixel pixmap
 494     winpixmap if
 495       (*
 496       xog-dpy DefaultScreen xog-dpy XDefaultDepth 1 1 winid xog-dpy XCreatePixmap
 497       dup winid xog-dpy XSetWindowBackgroundPixmap drop
 498       xog-dpy XFreePixmap
 499       *)
 500       None winid xog-dpy XSetWindowBackgroundPixmap drop
 501     endif
 502   endif
 503   (init-gc)
 504   (create-children)
 505   on-created
 506   parent visible? logand if false to visible? false to mapped? show true to visible? endif  ;; always map children
 507   dirty! true  ;; done
 508 ;
 509
 510 BaseWindow method: create  ( -- )  0 create-ex not-?abort" cannot create X11 window" ;
 511
 512
 513 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 514 ;; getters
 515 ;;
 516 BaseWindow method: is-valid?  ( -- flag )  winid notnot ;
 517 BaseWindow method: can-focus?  ( -- flag )  (can-focus?) ;
 518 BaseWindow method: bg-color  ( -- color )  xog-black-color ;
 519
 520 BaseWindow method: dirty!  ( -- )  true to dirty? ;
 521 BaseWindow method: non-dirty!  ( -- )  false to dirty? ;
 522
 523 ;; returns either window, or a pixmap
 524 ;; checks both "double-buffered?" and "winpixmap"
 525 BaseWindow method: my-drawable  ( -- drw )
 526   double-buffered? winpixmap logand if winpixmap else winid endif
 527 ;
 528
 529 BaseWindow method: realize-part  ( x y w h -- )
 530   winid double-buffered? logand winpixmap logand if
 531     over 0> over 0> and if
 532       swap 2swap swap 2swap 2over  ( y x h w y x )
 533       wingc winid winpixmap xog-dpy XCopyArea
 534       exit
 535     endif
 536   endif 2drop 2drop
 537 ;
 538
 539 ;; call this when you finish painting, to copy window pixmap to the screen
 540 BaseWindow method: realize  ( -- )
 541   winid double-buffered? logand winpixmap logand if
 542     0 0  ;; desty, destx
 543     height width
 544     0 0  ;; srcy, srcx
 545     wingc winid winpixmap xog-dpy XCopyArea
 546   endif
 547 ;
 548
 549
 550 BaseWindow method: (need-focus?)  ( -- flag )
 551   parent if  ;; has parent
 552     parent invoke focused-child self = if  ;; parent focused child is this one
 553       parent invoke (need-focus?) exit
 554     endif
 555   endif false
 556 ;
 557
 558
 559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 560 ;; X11 event handlers
 561 ;;
 562 BaseWindow method: KeyPress-Handler  ( -- )  (event) (get-keysym) on-keydown ;
 563 BaseWindow method: KeyRelease-Handler  ( -- )  (event) (get-keysym) on-keyup ;
 564 BaseWindow method: ButtonPress-Handler  ( -- )  (event) XButtonEvent button @ on-button-down ;
 565 BaseWindow method: ButtonRelease-Handler  ( -- )  (event) XButtonEvent button @ on-button-up ;
 566 BaseWindow method: MotionNotify-Handler  ( -- )  ;
 567 BaseWindow method: EnterNotify-Handler  ( -- )  ;
 568 BaseWindow method: LeaveNotify-Handler  ( -- )  ;
 569 BaseWindow method: KeymapNotify-Handler  ( -- )  ;
 570 BaseWindow method: GraphicsExpose-Handler  ( -- )  ;
 571 BaseWindow method: NoExpose-Handler  ( -- )  ;
 572 BaseWindow method: VisibilityNotify-Handler  ( -- )  (event) XVisibilityEvent state @ VisibilityFullyObscured <> on-visibility ;
 573 BaseWindow method: CreateNotify-Handler  ( -- )  ;
 574 BaseWindow method: DestroyNotify-Handler  ( -- )  0 to winid (destroy-cleanup) ;
 575 BaseWindow method: MapRequest-Handler  ( -- )  ;
 576 BaseWindow method: ReparentNotify-Handler  ( -- )  ;
 577 BaseWindow method: ConfigureRequest-Handler  ( -- )  ;
 578 BaseWindow method: GravityNotify-Handler  ( -- )  ;
 579 BaseWindow method: ResizeRequest-Handler  ( -- )  ;
 580 BaseWindow method: CirculateNotify-Handler  ( -- )  ;
 581 BaseWindow method: CirculateRequest-Handler  ( -- )  ;
 582 \ BaseWindow method: PropertyNotify-Handler  ( -- )  ;
 583 BaseWindow method: SelectionClear-Handler  ( -- )  ;
 584 BaseWindow method: SelectionRequest-Handler  ( -- )  ;
 585 BaseWindow method: SelectionNotify-Handler  ( -- )  ;
 586 BaseWindow method: ColormapNotify-Handler  ( -- )  ;
 587 BaseWindow method: MappingNotify-Handler  ( -- )  ;
 588 BaseWindow method: GenericEvent-Handler  ( -- )  ;
 589 BaseWindow method: UnknownEvent-Handler  ( -- )  ;
 590
 591 BaseWindow method: FocusIn-Handler  ( -- )
 592   (event) XFocusChangeEvent detail @  \ dup . cr
 593   dup NotifyNonlinear = if drop NotifyAncestor endif
 594   case
 595     NotifyAncestor of on-focus true to focused? endof
 596     NotifyPointer of focus endof
 597   endcase
 598   parent ifnot
 599       \ endcr ." going to focus a child...\n"
 600     (focus-child)
 601   else
 602     self parent begin dup while  ( child parent )
 603         \ endcr ." +++child " over invoke (debug-id.) ."  is focused child for " dup invoke (debug-id.) cr
 604       2dup invoke (focused-child!)
 605     nip dup invoke parent repeat 2drop
 606   endif
 607 ;
 608
 609 BaseWindow method: FocusOut-Handler  ( -- )
 610   (event) XFocusChangeEvent detail @  \ dup . cr
 611   dup NotifyNonlinear = if drop NotifyAncestor endif
 612   NotifyAncestor = if on-blur false to focused? endif
 613 ;
 614
 615 BaseWindow method: MapNotify-Handler  ( -- )  true to (first-paint?) true to visible? (map-children) on-show ;
 616 BaseWindow method: UnmapNotify-Handler  ( -- )  true to (first-paint?) false to visible? on-hide ;
 617
 618 BaseWindow method: Expose-Handler  ( -- )
 619   false to invalidate-sent?
 620   (event) dup >r XExposeEvent x @ r@ XExposeEvent y @
 621   r@ XExposeEvent width @ dup -0if drop width endif
 622   r@ XExposeEvent height @ dup -0if drop height endif
 623   (first-paint?) if dirty!
 624     false to (first-paint?)
 625     2drop 2drop 0 0 width height 0  ;; paint the whole thing
 626   else
 627     r@ XExposeEvent count @
 628   endif
 629   winid double-buffered? logand winpixmap logand ifnot dirty! endif
 630   on-draw-part
 631   r@ XExposeEvent x @ r@ XExposeEvent y @
 632   r@ XExposeEvent width @ dup -0if drop width endif
 633   r@ XExposeEvent height @ dup -0if drop height endif
 634     \ endcr ." Expose: x=" 2over swap . ." y=" . ." w=" 2dup swap . ." h=" . ." count=" r@ XExposeEvent count @ . cr
 635   realize-part
 636   rdrop
 637 ;
 638
 639 BaseWindow method: ConfigureNotify-Handler  ( -- )
 640   (event) dup XConfigureEvent width @
 641   swap XConfigureEvent height @
 642   2dup height = swap width = and ifnot
 643     width height  ;; old size
 644     2swap to height to width  ;; set new size
 645     winpixmap if (deinit-pixmap) (init-pixmap) else dirty! endif
 646     on-resize
 647     (send-expose-event)
 648   else 2drop endif
 649 ;
 650
 651 BaseWindow method: ClientMessage-Handler  ( -- )
 652   (event) XClientMessageEvent message_type @ case
 653     WM_PROTOCOLS of
 654       (event) XClientMessageEvent data @ case
 655         WM_DELETE_WINDOW of on-close-query if close endif endof
 656         ;; this is rarely used (at least FluxBox doesn't send it)
 657         WM_TAKE_FOCUS of (event) XClientMessageEvent data cell+ @ (debug-id.) ."  WM_TAKE_FOCUS: " . cr endof
 658       endcase
 659     endof
 660     XOF_INTERNAL_CLOSE of (destroy) endof
 661     \ WM_CHANGE_STATE of (event) XClientMessageEvent data @ on-state-change endof
 662   endcase
 663 ;
 664
 665 BaseWindow method: PropertyNotify-Handler-WM_STATE  ( -- )
 666   5 cells ralloca >r
 667   r@ 5 cells erase
 668   r@ ( prop_return) r@ cell+ ( bytes_after_return)
 669   r@ 2 +cells ( nitems_return)
 670   r@ 3 +cells ( actual_format_return)
 671   r@ 4 +cells ( actual_type_return)
 672   AnyPropertyType false 1 0 WM_STATE winid xog-dpy XGetWindowProperty ifnot
 673     r@ @ @ on-state-change
 674     r@ @ XFree
 675   endif
 676   rdrop 5 cells rdealloca
 677 ;
 678
 679 BaseWindow method: PropertyNotify-Handler  ( -- )
 680   (event) XPropertyEvent atom @ xog-dpy XGetAtomName >r
 681   endcr (debug-id.) ."  PROPERTY \`" r@ zcount type ." \` is "
 682   (event) XPropertyEvent state @ PropertyDelete = if ." deleted" else ." set" endif
 683   cr r> XFree
 684
 685   (event) XPropertyEvent state @ PropertyNewValue = if
 686     (event) XPropertyEvent atom @ case
 687       WM_STATE of PropertyNotify-Handler-WM_STATE endof
 688     endcase
 689   endif
 690 ;
 691
 692
 693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 694 ;; X11 event processor
 695 ;; calls "*-Handler" by name
 696 ;;
 697
 698 ;; call this to stop event propagation
 699 BaseWindow method: event-eat  ( -- )  (event) ?dup if 0! endif ;
 700
 701 ;; this is called with KeyPress event
 702 BaseWindow method: check-hotkey  ( keyevent -- boolflag )  drop false ;
 703
 704
 705 ;; can be called in any event handler, does all the checks it needs
 706 BaseWindow method: (kb-broadcast-hotkey)  ( -- )
 707   parent if exit endif  ;; only top-level window does this
 708   (event) ?dup ifnot exit endif
 709   dup @ KeyPress = ifnot drop exit endif
 710   [:  ( keyevent -- stopflag )
 711     dup (self@) BaseWindow:: check-hotkey
 712   ;] foreach-child 2drop
 713 ;
 714
 715
 716 BaseWindow method: (is-kb-focus-forward-event?)  ( event -- flag )
 717   dup if dup @ KeyPress = if (get-keysym) XK_Tab = else drop false endif endif
 718 ;
 719
 720 BaseWindow method: (gain-focus)  ( -- successflag )
 721   can-focus? if
 722     first-child begin dup while
 723       dup invoke (gain-focus) if drop true break endif
 724     invoke next-sibling repeat
 725     ?dup ifnot focus true endif
 726   else false endif
 727 ;
 728
 729
 730 BaseWindow method: (kb-focus-first)  ( -- successflag )
 731   [ xog-window-debug-kbfocus? ] [IF]
 732     ." FFIRST " (debug-id.) cr
 733   [ENDIF]
 734   (gain-focus)
 735 ;
 736
 737 BaseWindow method: (kb-focus-forward)  ( -- successflag )
 738   [ xog-window-debug-kbfocus? ] [IF]
 739     endcr ." FFORWARD at " (debug-id.)
 740     next-sibling if ."  with next sibling as " next-sibling invoke (debug-id.) endif
 741     cr
 742   [ENDIF]
 743   next-sibling begin dup while
 744     dup invoke (gain-focus) if drop true break endif
 745   invoke next-sibling repeat
 746 ;
 747
 748 BaseWindow method: (check-do-kb-focus)  ( -- )
 749   (event) (is-kb-focus-forward-event?) if
 750     (kb-focus-forward) if event-eat
 751     else parent ifnot (kb-focus-first) if event-eat endif endif
 752     endif
 753   endif
 754 ;
 755
 756 BaseWindow method: (sink-event)  ( -- )
 757   (basewin-debug-show-events?) if
 758     ." SINK EVENT: destwinid=" (event) XAnyEvent window @ .hex8 ."  type=" (event) @ . (event) @ get-x11-event-type-name type cr
 759   endif
 760 ;
 761
 762 BaseWindow method: (bubble-event)  ( -- )
 763   (basewin-debug-show-events?) if
 764     ." BUBBLE EVENT: destwinid=" (event) XAnyEvent window @ .hex8 ."  type=" (event) @ . (event) @ get-x11-event-type-name type cr
 765   endif
 766   (check-do-kb-focus)
 767   (kb-broadcast-hotkey)
 768 ;
 769
 770 BaseWindow method: (process-event)  ( -- )
 771   (basewin-debug-show-events?) if
 772     ." HANDLE EVENT: winid=" (event) XAnyEvent window @ .hex8 ."  type=" (event) @ . (event) @ get-x11-event-type-name type cr
 773   endif
 774   sp@ >r
 775   (event) @ get-x11-event-handler-name dispatch-str
 776   r> (xog-fix-stack)
 777   (check-do-kb-focus)
 778   (kb-broadcast-hotkey)
 779 ;
 780
 781
 782 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 783 ;; high-level window control methods
 784 ;;
 785 BaseWindow method: close  ( -- )
 786   is-valid? if close-sent? ifnot true to close-sent? (send-close-event) endif endif
 787 ;
 788
 789 BaseWindow method: weak-invalidate  ( -- )
 790   is-valid? if invalidate-sent? ifnot true to invalidate-sent? (send-expose-event) endif endif
 791 ;
 792
 793 BaseWindow method: invalidate  ( -- )
 794   is-valid? if dirty! weak-invalidate endif
 795 ;
 796
 797 BaseWindow method: sync  ( -- )
 798   xog-dpy if false xog-dpy XSync endif
 799 ;
 800
 801 BaseWindow method: flush  ( -- )
 802   xog-dpy if xog-dpy XFlush endif
 803 ;
 804
 805 BaseWindow method: show  ( -- )
 806   is-valid? if mapped? ifnot true to mapped? winid xog-dpy XMapWindow endif endif
 807 ;
 808
 809 BaseWindow method: hide  ( -- )
 810   is-valid? if mapped? if false to mapped? false to visible? winid xog-dpy XUnmapWindow endif endif
 811 ;
 812
 813 BaseWindow method: focus  ( -- )
 814   visible? if is-valid? if CurrentTime RevertToParent winid xog-dpy XSetInputFocus endif endif
 815 ;
 816
 817 BaseWindow method: set-min-size  ( minwidth minheight -- )
 818   0 max to min-height  0 max to min-width  is-valid? if (set-xhints) endif
 819 ;
 820
 821 BaseWindow method: set-max-size  ( maxwidth maxheight -- )
 822   0 max to max-height  0 max to max-width  is-valid? if (set-xhints) endif
 823 ;
 824
 825 BaseWindow method: set-pos  ( x y -- )
 826   over posx - over posy - or if
 827     to posy to posx is-valid? if posy posx winid xog-dpy XMoveWindow endif
 828   else 2drop endif
 829 ;
 830
 831 BaseWindow method: set-size  ( width height -- )
 832   1 max swap 1 max
 833   over height - over width - or if
 834     to width to height is-valid? if height width winid xog-dpy XResizeWindow endif
 835   else 2drop endif
 836 ;
 837
 838
 839 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 840 ;; high-level event handlers
 841 ;;
 842 BaseWindow method: on-created  ( -- )  ;
 843 BaseWindow method: on-destroyed  ( -- )  ;
 844 BaseWindow method: on-visibility  ( visible-flag -- )  drop ;
 845 BaseWindow method: on-show  ( -- )  ;
 846 BaseWindow method: on-hide  ( -- )  ;
 847 BaseWindow method: on-focus  ( -- )  ;
 848 BaseWindow method: on-blur  ( -- )  ;
 849 BaseWindow method: on-draw-part  ( x y width height count -- )  >r 2drop 2drop r> ifnot on-draw endif ;
 850 BaseWindow method: on-draw  ( -- )  ;
 851 BaseWindow method: on-resize ( oldwidth oldheight -- )  2drop ;
 852 BaseWindow method: on-keydown  ( keysym -- )  drop ;
 853 BaseWindow method: on-keyup  ( keysym -- )  drop ;
 854 BaseWindow method: on-button-down  ( bnum -- )  drop ;
 855 BaseWindow method: on-button-up  ( bnum -- )  drop ;
 856 BaseWindow method: on-close-query  ( -- allow-close-flag )  true ;
 857 BaseWindow method: on-state-change  ( newstate -- )  drop ;
 858
 859
 860 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 861 ;; simple drawing
 862 ;;
 863 BaseWindow method: set-color  ( color -- )  dup to current-fg-color wingc xog-dpy XSetForeground ;
 864 BaseWindow method: set-named-color  ( addr count -- )  xog-get-color set-color ;
 865
 866 BaseWindow method: set-bg-color  ( color -- ) dup to current-bg-color wingc xog-dpy XSetBackground ;
 867 BaseWindow method: set-named-bg-color  ( addr count -- ) xog-get-color set-bg-color ;
 868
 869 BaseWindow method: set-line-style  ( style -- )  JoinMiter CapButt rot 0 wingc xog-dpy XSetLineAttributes drop ;
 870 BaseWindow method: set-line-solid  ( -- )  LineSolid set-line-style ;
 871 BaseWindow method: set-line-dashed  ( -- )  LineOnOffDash set-line-style ;
 872
 873 BaseWindow method: draw-point  ( x y -- )  swap wingc my-drawable xog-dpy XDrawPoint ;
 874 BaseWindow method: draw-line  ( x0 y0 x1 y1 -- )  swap 2swap swap wingc my-drawable xog-dpy XDrawLine ;
 875 BaseWindow method: fill-rect  ( x y w h -- )  swap 2swap swap wingc my-drawable xog-dpy XFillRectangle ;
 876 BaseWindow method: draw-rect  ( x y w h -- )  swap 2swap swap wingc my-drawable xog-dpy XDrawRectangle ;
 877 BaseWindow method: draw-ellipse  ( x0 y0 w h -- )  swap 2swap swap 23040 0 2nrot wingc my-drawable xog-dpy XDrawArc ;
 878 BaseWindow method: fill-ellipse  ( x0 y0 w h -- )  swap 2swap swap 23040 0 2nrot wingc my-drawable xog-dpy XFillArc ;
 879
 880
 881 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 882 ;; draw rounded rectangles
 883 ;;
 884 BaseWindow method: draw-rounded-rect  {{ x y w h ew eh | arcs curarc ew2 eh2 -- }}
 885   XArc @sizeof 8 * ralloca dup to arcs to curarc
 886
 887   ew 0 max to ew
 888   eh 0 max to eh
 889
 890   ew 1 lshift dup to ew2 w > if 0 dup to ew2 to ew endif
 891   eh 1 lshift dup to eh2 h > if 0 dup to eh2 to eh endif
 892
 893   ;; [0]
 894   x curarc XArc x w!
 895   y curarc XArc y w!
 896   ew2 curarc XArc width w!
 897   eh2 curarc XArc height w!
 898   [ 180 64 * ] literal curarc XArc angle1 w!
 899   [ -90 64 * ] literal curarc XArc angle2 w!
 900   curarc XArc @sizeof + to curarc
 901
 902   ;; [1]
 903   x ew + curarc XArc x w!
 904   y curarc XArc y w!
 905   w ew2 - curarc XArc width w!
 906   0 curarc XArc height w!
 907   [ 180 64 * ] literal curarc XArc angle1 w!
 908   [ -180 64 * ] literal curarc XArc angle2 w!
 909   curarc XArc @sizeof + to curarc
 910
 911   ;; [2]
 912   x w + ew2 - curarc XArc x w!
 913   y curarc XArc y w!
 914   ew2 curarc XArc width w!
 915   eh2 curarc XArc height w!
 916   [ 90 64 * ] literal curarc XArc angle1 w!
 917   [ -90 64 * ] literal curarc XArc angle2 w!
 918   curarc XArc @sizeof + to curarc
 919
 920   ;; [3]
 921   x w + curarc XArc x w!
 922   y eh + curarc XArc y w!
 923   0 curarc XArc width w!
 924   h eh2 - curarc XArc height w!
 925   [ 90 64 * ] literal curarc XArc angle1 w!
 926   [ -180 64 * ] literal curarc XArc angle2 w!
 927   curarc XArc @sizeof + to curarc
 928
 929   ;; [4]
 930   x w + ew2 - curarc XArc x w!
 931   y h + eh2 - curarc XArc y w!
 932   ew2 curarc XArc width w!
 933   eh2 curarc XArc height w!
 934   [ 0 64 * ] literal curarc XArc angle1 w!
 935   [ -90 64 * ] literal curarc XArc angle2 w!
 936   curarc XArc @sizeof + to curarc
 937
 938   ;; [5]
 939   x ew + curarc XArc x w!
 940   y h + curarc XArc y w!
 941   w ew2 - curarc XArc width w!
 942   0 curarc XArc height w!
 943   [ 0 64 * ] literal curarc XArc angle1 w!
 944   [ -180 64 * ] literal curarc XArc angle2 w!
 945   curarc XArc @sizeof + to curarc
 946
 947   ;; [6]
 948   x curarc XArc x w!
 949   y h + eh2 - curarc XArc y w!
 950   ew2 curarc XArc width w!
 951   eh2 curarc XArc height w!
 952   [ 270 64 * ] literal curarc XArc angle1 w!
 953   [ -90 64 * ] literal curarc XArc angle2 w!
 954   curarc XArc @sizeof + to curarc
 955
 956   ;; [7]
 957   x curarc XArc x w!
 958   y eh + curarc XArc y w!
 959   0 curarc XArc width w!
 960   h eh2 - curarc XArc height w!
 961   [ 270 64 * ] literal curarc XArc angle1 w!
 962   [ -180 64 * ] literal curarc XArc angle2 w!
 963
 964   8 arcs wingc my-drawable xog-dpy XDrawArcs
 965
 966   XArc @sizeof 8 * rdealloca
 967 ;
 968
 969
 970 BaseWindow method: fill-rounded-rect  {{ x y w h ew eh | arcs curarc rects currect gcvals ew2 eh2 -- }}
 971   XArc @sizeof 4 * ralloca dup to arcs to curarc
 972   XRectangle @sizeof 3 * ralloca dup to rects to currect
 973   XGCValues @sizeof ralloca to gcvals
 974
 975   gcvals GCArcMode wingc xog-dpy XGetGCValues drop
 976   gcvals XGCValues arc_mode @ ArcPieSlice <> if
 977     ArcPieSlice wingc xog-dpy XSetArcMode drop
 978   endif
 979
 980   ew 0 max to ew
 981   eh 0 max to eh
 982
 983   ew 1 lshift dup to ew2 w > if 0 dup to ew2 to ew endif
 984   eh 1 lshift dup to eh2 h > if 0 dup to eh2 to eh endif
 985
 986   ;; [0]
 987   x curarc XArc x w!
 988   y curarc XArc y w!
 989   ew2 curarc XArc width w!
 990   eh2 curarc XArc height w!
 991   [ 180 64 * ] literal curarc XArc angle1 w!
 992   [ -90 64 * ] literal curarc XArc angle2 w!
 993   curarc XArc @sizeof + to curarc
 994
 995   ;; [1]
 996   x w + ew2 - 1- curarc XArc x w!
 997   y curarc XArc y w!
 998   ew2 curarc XArc width w!
 999   eh2 curarc XArc height w!
1000   [ 90 64 * ] literal curarc XArc angle1 w!
1001   [ -90 64 * ] literal curarc XArc angle2 w!
1002   curarc XArc @sizeof + to curarc
1003
1004   ;; [2]
1005   x w + ew2 - 1- curarc XArc x w!
1006   y h + eh2 - 1- curarc XArc y w!
1007   ew2 curarc XArc width w!
1008   eh2 curarc XArc height w!
1009   [ 0 64 * ] literal curarc XArc angle1 w!
1010   [ -90 64 * ] literal curarc XArc angle2 w!
1011   curarc XArc @sizeof + to curarc
1012
1013   ;; [3]
1014   x curarc XArc x w!
1015   y h + eh2 - 1- curarc XArc y w!
1016   ew2 curarc XArc width w!
1017   eh2 curarc XArc height w!
1018   [ 270 64 * ] literal curarc XArc angle1 w!
1019   [ -90 64 * ] literal curarc XArc angle2 w!
1020
1021   4 arcs wingc my-drawable xog-dpy XFillArcs
1022
1023   ;; [0]
1024   x ew + currect XRectangle x w!
1025   y currect XRectangle y w!
1026   w ew2 - currect XRectangle width w!
1027   h currect XRectangle height w!
1028   currect XRectangle @sizeof + to currect
1029
1030   ;; [1]
1031   x currect XRectangle x w!
1032   y eh + currect XRectangle y w!
1033   ew currect XRectangle width w!
1034   h eh2 - currect XRectangle height w!
1035   currect XRectangle @sizeof + to currect
1036
1037   ;; [2]
1038   x w + ew - currect XRectangle x w!
1039   y eh + currect XRectangle y w!
1040   ew currect XRectangle width w!
1041   h eh2 - currect XRectangle height w!
1042
1043   3 rects wingc my-drawable xog-dpy XFillRectangles
1044
1045   gcvals XGCValues arc_mode @ ArcPieSlice <> if
1046     gcvals XGCValues arc_mode @ wingc xog-dpy XSetArcMode drop
1047   endif
1048
1049   XGCValues @sizeof rdealloca
1050   XRectangle @sizeof 3 * rdealloca
1051   XArc @sizeof 4 * rdealloca
1052 ;
1053
1054
1055 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1056 previous previous