core/ui/ui.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets
   4 USING: arrays errors gadgets gadgets-buttons
   5 gadgets-labels gadgets-panes gadgets-presentations
   6 gadgets-scrolling gadgets-theme gadgets-viewports gadgets-lists
   7 generic hashtables io kernel math models namespaces prettyprint
   8 queues sequences test threads sequences words timers ;
   9
  10 : update-hand ( gadget -- )
  11     find-world [
  12         dup hand-world get-global eq?
  13         [ hand-loc get-global swap move-hand ] [ drop ] if
  14     ] when* ;
  15
  16 : post-layout ( gadget -- )
  17     find-world [ dup world-handle set ] when* ;
  18
  19 : layout-queued ( -- )
  20     invalid dup queue-empty? [
  21         drop
  22     ] [
  23         deque dup layout post-layout layout-queued
  24     ] if ;
  25
  26 : init-ui ( -- )
  27     <queue> \ invalid set-global
  28     V{ } clone windows set-global ;
  29
  30 : ui-step ( -- )
  31     [
  32         do-timers
  33         [ layout-queued ] make-hash hash-values [
  34             dup update-hand
  35             dup world-handle [ dup draw-world ] when
  36             drop
  37         ] each
  38         10 sleep
  39     ] assert-depth ;
  40
  41 TUPLE: world-error world ;
  42
  43 C: world-error ( error world -- error )
  44     [ set-world-error-world ] keep
  45     [ set-delegate ] keep ;
  46
  47 M: world-error error.
  48     "An error occurred while drawing the world " write
  49     dup world-error-world pprint-short "." print
  50     "This world has been deactivated to prevent cascading errors." print
  51     delegate error. ;
  52
  53 : draw-world? ( world -- ? )
  54     #! We don't draw deactivated worlds, or those with 0 size.
  55     #! On Windows, the latter case results in GL errors.
  56     dup world-active? swap rect-dim [ zero? not ] all? and ;
  57
  58 : draw-world ( world -- )
  59     dup draw-world? [
  60         [
  61             dup world set [
  62                 dup (draw-world)
  63             ] [
  64                 over <world-error> debugger-window
  65                 f over set-world-active?
  66             ] recover
  67         ] with-scope
  68     ] when drop ;
  69
  70 IN: shells
  71
  72 DEFER: ui