core/ui/windows.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 generic hashtables io kernel math
   5 models namespaces prettyprint sequences test threads
   6 sequences words timers ;
   7
   8 ! Assoc mapping aliens to gadgets
   9 SYMBOL: windows
  10
  11 : window ( handle -- world ) windows get-global assoc ;
  12
  13 : window-focus ( handle -- gadget ) window world-focus ;
  14
  15 : register-window ( world handle -- )
  16     swap 2array windows get-global push ;
  17
  18 : unregister-window ( handle -- )
  19     windows get-global
  20     [ first = not ] subset-with
  21     windows set-global  ;
  22
  23 : raised-window ( world -- )
  24     windows get-global [ second eq? ] find-with drop
  25     windows get-global [ length 1- ] keep exchange ;
  26
  27 TUPLE: titled-gadget title child ;
  28
  29 M: titled-gadget gadget-title titled-gadget-title ;
  30
  31 M: titled-gadget focusable-child* titled-gadget-child ;
  32
  33 C: titled-gadget ( gadget title -- )
  34     [ set-titled-gadget-title ] keep
  35     { { f set-titled-gadget-child f @center } } make-frame* ;
  36
  37 : open-window ( world -- )
  38     dup pref-dim over set-gadget-dim
  39     dup open-window* draw-world ;
  40
  41 : open-titled-window ( gadget title -- )
  42     <model> <titled-gadget> <world> open-window ;
  43
  44 : find-window ( quot -- world )
  45     windows get 1 <column>
  46     [ world-gadget swap call ] find-last-with nip ; inline
  47
  48 : start-world ( world -- )
  49     dup graft
  50     dup relayout
  51     world-gadget request-focus ;
  52
  53 : close-global ( world global -- )
  54     dup get-global find-world rot eq?
  55     [ f swap set-global ] [ drop ] if ;
  56
  57 : focus-world ( world -- )
  58     t over set-world-focused?
  59     dup raised-window
  60     focused-ancestors f focus-gestures ;
  61
  62 : unfocus-world ( world -- )
  63     f over set-world-focused?
  64     focused-ancestors f swap focus-gestures ;
  65
  66 : reset-world ( world -- )
  67     dup world-fonts clear-hash
  68     dup unfocus-world
  69     f over set-world-focus
  70     f over set-world-handle
  71     ungraft ;
  72
  73 : close-world ( world -- )
  74     dup hand-clicked close-global
  75     dup hand-gadget close-global
  76     dup free-fonts
  77     reset-world ;
  78
  79 : restore-windows ( -- )
  80     windows get [ 1 <column> >array ] keep delete-all
  81     [ dup reset-world open-window* ] each
  82     forget-rollover ;
  83
  84 : restore-windows? ( -- ? )
  85     windows get [ empty? not ] [ f ] if* ;