2006-09-14 16:15:39 -04:00
|
|
|
! Copyright (C) 2006 Slava Pestov.
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2006-09-23 02:40:25 -04:00
|
|
|
IN: gadgets-messages
|
|
|
|
|
DEFER: messages
|
|
|
|
|
|
2006-09-14 16:15:39 -04:00
|
|
|
IN: gadgets-workspace
|
|
|
|
|
USING: gadgets gadgets-books gadgets-controls gadgets-workspace
|
2006-09-23 02:40:25 -04:00
|
|
|
generic kernel models scratchpad sequences syntax
|
|
|
|
|
gadgets-messages ;
|
2006-09-14 16:15:39 -04:00
|
|
|
|
|
|
|
|
DEFER: workspace-window
|
|
|
|
|
|
|
|
|
|
GENERIC: call-tool* ( arg tool -- )
|
|
|
|
|
|
2006-09-20 03:22:26 -04:00
|
|
|
GENERIC: tool-scroller ( tool -- scroller )
|
|
|
|
|
|
|
|
|
|
M: gadget tool-scroller drop f ;
|
|
|
|
|
|
|
|
|
|
GENERIC: tool-help ( tool -- topic )
|
|
|
|
|
|
|
|
|
|
M: gadget tool-help drop f ;
|
|
|
|
|
|
2006-09-14 16:15:39 -04:00
|
|
|
TUPLE: workspace ;
|
|
|
|
|
|
|
|
|
|
TUPLE: tool gadget ;
|
|
|
|
|
|
2006-09-23 02:40:25 -04:00
|
|
|
: find-tool ( class workspace -- index tool )
|
|
|
|
|
gadget-children [ tool-gadget class eq? ] find-with ;
|
|
|
|
|
|
2006-09-14 16:15:39 -04:00
|
|
|
: show-tool ( class workspace -- tool )
|
2006-09-23 02:40:25 -04:00
|
|
|
[ find-tool swap ] keep control-model set-model* ;
|
2006-09-14 16:15:39 -04:00
|
|
|
|
|
|
|
|
: select-tool ( workspace class -- ) swap show-tool drop ;
|
|
|
|
|
|
|
|
|
|
: find-workspace ( -- workspace )
|
|
|
|
|
[ workspace? ] find-window
|
|
|
|
|
[ world-gadget ] [ workspace-window find-workspace ] if* ;
|
|
|
|
|
|
|
|
|
|
: call-tool ( arg class -- )
|
|
|
|
|
find-workspace show-tool call-tool* ;
|
2006-09-23 02:40:25 -04:00
|
|
|
|
|
|
|
|
: get-tool ( class -- gadget )
|
|
|
|
|
find-workspace find-tool nip tool-gadget ;
|
|
|
|
|
|
|
|
|
|
: find-messages ( -- gadget ) messages get-tool ;
|
