library/ui/gadgets/presentations.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-listener
   4 DEFER: call-listener
   5
   6 IN: gadgets-presentations
   7 USING: arrays definitions gadgets gadgets-borders
   8 gadgets-buttons gadgets-grids gadgets-labels gadgets-outliner
   9 gadgets-panes gadgets-paragraphs gadgets-theme
  10 generic hashtables tools io kernel prettyprint sequences strings
  11 styles words help math models namespaces ;
  12
  13 ! Clickable objects
  14 TUPLE: presentation object command ;
  15
  16 C: presentation ( button object command -- button )
  17     [ set-presentation-command ] keep
  18     [ set-presentation-object ] keep
  19     [ set-gadget-delegate ] keep ;
  20
  21 : <object-presentation> ( gadget object -- button )
  22     >r f <roll-button> r> f <presentation> ;
  23
  24 : <command-presentation> ( target command -- button )
  25     dup command-name f <bevel-button> -rot <presentation> ;
  26
  27 : <commands-menu> ( target commands -- gadget )
  28     [ hand-clicked get find-world hide-glass ] modify-operations
  29     [ <command-presentation> ] map-with
  30     make-pile 1 over set-pack-fill ;
  31
  32 : operations-menu ( presentation -- gadget )
  33     dup presentation-command [
  34         drop
  35     ] [
  36         dup presentation-object
  37         dup object-operations <commands-menu>
  38         swap show-menu
  39     ] if ;
  40
  41 : invoke-presentation ( presentation -- )
  42     dup presentation-object swap presentation-command
  43     [ dup default-operation ] unless*
  44     invoke-command ;
  45
  46 : show-mouse-help ( presentation -- )
  47     dup find-world [ world-status set-model* ] [ drop ] if* ;
  48
  49 : hide-mouse-help ( presentation -- )
  50     find-world [ world-status f swap set-model* ] when* ;
  51
  52 M: presentation ungraft* ( presentation -- )
  53     dup hide-mouse-help delegate ungraft* ;
  54
  55 presentation H{
  56     { T{ button-up } [ [ invoke-presentation ] if-clicked ] }
  57     { T{ button-down f f 3 } [ [ operations-menu ] if-clicked ] }
  58     { T{ mouse-leave } [ dup hide-mouse-help button-update ] }
  59     { T{ motion } [ dup show-mouse-help button-update ] }
  60 } set-gestures
  61
  62 ! Presentation help bar
  63 : <presentation-help> ( model -- gadget )
  64     [ [ presentation-object summary ] [ "" ] if* ] <filter>
  65     <label-control> dup reverse-video-theme ;
  66
  67 : <listener-button> ( gadget quot -- button )
  68     [ call-listener ] curry <roll-button> ;
  69
  70 ! Character styles
  71
  72 : apply-style ( style gadget key quot -- style gadget )
  73     >r pick hash r> when* ; inline
  74
  75 : apply-foreground-style ( style gadget -- style gadget )
  76     foreground [ over set-label-color ] apply-style ;
  77
  78 : apply-background-style ( style gadget -- style gadget )
  79     background [ <solid> over set-gadget-interior ] apply-style ;
  80
  81 : specified-font ( style -- font )
  82     [ font swap hash [ "monospace" ] unless* ] keep
  83     [ font-style swap hash [ plain ] unless* ] keep
  84     font-size swap hash [ 12 ] unless* 3array ;
  85
  86 : apply-font-style ( style gadget -- style gadget )
  87     over specified-font over set-label-font ;
  88
  89 : apply-presentation-style ( style gadget -- style gadget )
  90     presented [ <object-presentation> ] apply-style ;
  91
  92 : apply-quotation-style ( style gadget -- style gadget )
  93     quotation [ <listener-button> ] apply-style ;
  94
  95 : <styled-label> ( style text -- gadget )
  96     <label>
  97     apply-foreground-style
  98     apply-background-style
  99     apply-font-style
 100     apply-presentation-style
 101     apply-quotation-style
 102     nip ;
 103
 104 ! Paragraph styles
 105
 106 : apply-wrap-style ( style pane -- style pane )
 107     wrap-margin [
 108         2dup <paragraph> swap set-pane-prototype
 109         <paragraph> over set-pane-current
 110     ] apply-style ;
 111
 112 : apply-border-width-style ( style gadget -- style gadget )
 113     border-width [ <border> ] apply-style ;
 114
 115 : apply-border-color-style ( style gadget -- style gadget )
 116     border-color [
 117         <solid> over set-gadget-boundary
 118     ] apply-style ;
 119
 120 : apply-page-color-style ( style gadget -- style gadget )
 121     page-color [
 122         <solid> over set-gadget-interior
 123     ] apply-style ;
 124
 125 : apply-outliner-style ( style gadget -- style gadget )
 126     outline [ <outliner> ] apply-style ;
 127
 128 : <styled-paragraph> ( style pane -- gadget )
 129     apply-wrap-style
 130     apply-border-width-style
 131     apply-border-color-style
 132     apply-page-color-style
 133     apply-presentation-style
 134     apply-quotation-style
 135     apply-outliner-style
 136     nip ;
 137
 138 : styled-pane ( quot style -- gadget )
 139     #! Create a pane, call the quotation to fill it out.
 140     >r <pane> dup r> swap <styled-paragraph>
 141     >r swap with-pane r> ; inline
 142
 143 : apply-table-gap-style ( style grid -- style grid )
 144     table-gap [ over set-grid-gap ] apply-style ;
 145
 146 : apply-table-border-style ( style grid -- style grid )
 147     table-border [ <grid-lines> over set-gadget-boundary ]
 148     apply-style ;
 149
 150 : styled-grid ( style grid -- grid )
 151     <grid>
 152     apply-table-gap-style
 153     apply-table-border-style
 154     nip ;
 155
 156 : <pane-grid> ( quot style grid -- gadget )
 157     [
 158         [ pick pick >r >r -rot styled-pane r> r> rot ] map
 159     ] map styled-grid nip ;
 160
 161 M: pane-stream with-stream-table
 162     >r rot <pane-grid> r> print-gadget ;
 163
 164 M: pane-stream with-nested-stream
 165     >r styled-pane r> write-gadget ;
 166
 167 ! Stream utilities
 168 M: pack stream-close drop ;
 169
 170 M: paragraph stream-close drop ;
 171
 172 : gadget-write ( string gadget -- )
 173     over empty? [
 174         2drop
 175     ] [
 176         >r <label> dup text-theme r> add-gadget
 177     ] if ;
 178
 179 M: pack stream-write gadget-write ;
 180
 181 : gadget-bl ( style stream -- )
 182     >r " " <styled-label> <word-break-gadget> r> add-gadget ;
 183
 184 M: paragraph stream-write
 185     swap " " split
 186     [ over gadget-write ] [ H{ } over gadget-bl ] interleave
 187     drop ;
 188
 189 : gadget-write1 ( char gadget -- )
 190     >r ch>string r> stream-write ;
 191
 192 M: pack stream-write1 gadget-write1 ;
 193
 194 M: paragraph stream-write1
 195     over CHAR: \s =
 196     [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
 197
 198 : gadget-format ( string style stream -- )
 199     pick empty?
 200     [ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;
 201
 202 M: pack stream-format
 203     gadget-format ;
 204
 205 M: paragraph stream-format
 206     presented pick hash [
 207         gadget-format
 208     ] [
 209         rot " " split
 210         [ pick pick gadget-format ]
 211         [ 2dup gadget-bl ] interleave
 212         2drop
 213     ] if ;