core/ui/gadgets/presentations.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-presentations
   4 USING: arrays definitions gadgets gadgets-borders
   5 gadgets-buttons gadgets-labels gadgets-theme
   6 generic hashtables tools io kernel prettyprint sequences strings
   7 styles words help math models namespaces ;
   8
   9 TUPLE: presentation object hook ;
  10
  11 : invoke-presentation ( presentation command -- )
  12     over dup presentation-hook call
  13     >r presentation-object r> invoke-command ;
  14
  15 : invoke-primary ( presentation -- )
  16     dup presentation-object primary-operation
  17     invoke-presentation ;
  18
  19 : invoke-secondary ( presentation -- )
  20     dup presentation-object secondary-operation
  21     invoke-presentation ;
  22
  23 : show-mouse-help ( presentation -- )
  24     dup presentation-object swap find-world
  25     [ world-status set-model ] [ drop ] if* ;
  26
  27 : hide-mouse-help ( presentation -- )
  28     find-world [ world-status f swap set-model ] when* ;
  29
  30 M: presentation ungraft* ( presentation -- )
  31     dup hide-mouse-help delegate ungraft* ;
  32
  33 C: presentation ( label object -- button )
  34     [ drop ] over set-presentation-hook
  35     [ set-presentation-object ] keep
  36     swap [ invoke-primary ] <roll-button>
  37     over set-gadget-delegate ;
  38
  39 : (command-button) ( target command -- label quot )
  40     dup command-name -rot
  41     [ invoke-command drop ] curry curry ;
  42
  43 : <command-button> ( target command -- button )
  44     (command-button) <bevel-button> ;
  45
  46 : <toolbar> ( target classes -- toolbar )
  47     [ commands "toolbar" swap hash ] map concat
  48     [ <command-button> ] map-with
  49     make-shelf ;
  50
  51 : <menu-item> ( hook target command -- button )
  52     rot >r
  53     (command-button) [ hand-clicked get find-world hide-glass ]
  54     r> 3append <roll-button> ;
  55
  56 : <commands-menu> ( hook target commands -- gadget )
  57     [ >r 2dup r> <menu-item> ] map 2nip make-filled-pile
  58     <default-border>
  59     dup menu-theme ;
  60
  61 : operations-menu ( presentation -- )
  62     dup
  63     dup presentation-hook curry
  64     over presentation-object
  65     dup object-operations <commands-menu>
  66     swap show-menu ;
  67
  68 presentation H{
  69     { T{ button-down f f 3 } [ operations-menu ] }
  70     { T{ mouse-leave } [ dup hide-mouse-help button-update ] }
  71     { T{ motion } [ dup show-mouse-help button-update ] }
  72 } set-gestures
  73
  74 ! Presentation help bar
  75 : <presentation-help> ( model -- gadget )
  76     [ [ summary ] [ "" ] if* ] <filter> <label-control>
  77     dup reverse-video-theme ;