extra/slides/slides.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays colors fonts fry help.markup help.stylesheet
   4 io.styles kernel literals math math.ranges models namespaces parser
   5 sequences system ui ui.gadgets ui.gadgets.books ui.gadgets.panes
   6 ui.gestures ui.pens.gradient ui.pens.solid ;
   7 IN: slides
   8
   9 CONSTANT: stylesheet
  10     H{
  11         { default-span-style
  12             H{
  13                 { font-name $ default-sans-serif-font-name }
  14                 { font-size $[ default-font-size 3 * ] }
  15             }
  16         }
  17         { default-block-style
  18             H{
  19                 { wrap-margin $[ default-font-size 92 * ] }
  20             }
  21         }
  22         { code-char-style
  23             H{
  24                 { font-name $ default-monospace-font-name }
  25                 { font-size $[ default-font-size 3 * ] }
  26             }
  27         }
  28         { code-style
  29             H{
  30                 { page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
  31             }
  32         }
  33         { snippet-style
  34             H{
  35                 { font-name $ default-monospace-font-name }
  36                 { font-size $[ default-font-size 3 * ] }
  37                 { foreground T{ rgba f 0.1 0.1 0.4 1 } }
  38             }
  39         }
  40         { table-content-style
  41             H{ { wrap-margin $[ default-font-size 83 * ] } }
  42         }
  43         { list-style
  44             H{
  45                 { table-gap ${ default-font-size 5/6 *
  46                                default-font-size 10/6 * }
  47                 }
  48             }
  49         }
  50     }
  51
  52 : $title ( string -- )
  53     [
  54         H{
  55             { font-name $ default-sans-serif-font-name }
  56             { font-size $[ default-font-size 4 * ] }
  57         } format
  58     ] ($block) ;
  59
  60 : divider-interior ( -- interior )
  61     os windows? [
  62         T{ rgba f 0.25 0.25 0.25 1.0 } <solid>
  63     ] [ {
  64             T{ rgba f 0.25 0.25 0.25 1.0 }
  65             T{ rgba f 1.0 1.0 1.0 0.0 }
  66         } <gradient>
  67     ] if ;
  68
  69 : $divider ( -- )
  70     [
  71         <gadget>
  72             divider-interior >>interior
  73             ${ default-font-size 67 * default-font-size 5/6 * } >>dim
  74             { 1 0 } >>orientation
  75         gadget.
  76     ] ($block) ;
  77
  78 : page-interior ( -- interior )
  79     os windows? [
  80         T{ rgba f 0.8 0.8 1.0 1.0 } <solid>
  81     ] [ {
  82             T{ rgba f 0.8 0.8 1.0 1.0 }
  83             T{ rgba f 0.8 1.0 1.0 1.0 }
  84         } <gradient>
  85     ] if ;
  86
  87 : page-theme ( gadget -- gadget )
  88     page-interior >>interior ;
  89
  90 : <page> ( list -- gadget )
  91     [
  92         stylesheet clone [
  93             [ print-element ] with-default-style
  94         ] with-variables
  95     ] make-pane page-theme ;
  96
  97 : $slide ( element -- )
  98     unclip $title $divider $list ;
  99
 100 TUPLE: slides < book ;
 101
 102 : <slides> ( slides -- gadget )
 103     0 <model> slides new-book [ <page> add-gadget ] reduce ;
 104
 105 : change-page ( book n -- )
 106     over control-value + over children>> length rem
 107     swap set-control-value ;
 108
 109 : next-page ( book -- ) 1 change-page ;
 110
 111 : prev-page ( book -- ) -1 change-page ;
 112
 113 : strip-tease ( data -- seq )
 114     first3 2 over length [a,b] [ head 3array ] with with with map ;
 115
 116 SYNTAX: STRIP-TEASE:
 117     parse-definition strip-tease append! ;
 118
 119 \ slides H{
 120     { T{ button-down } [ request-focus ] }
 121     { T{ key-down f f "DOWN" } [ next-page ] }
 122     { T{ key-down f f "UP" } [ prev-page ] }
 123     { T{ key-down f f "f" } [ toggle-fullscreen ] }
 124 } set-gestures
 125
 126 : slides-window ( slides title -- )
 127     '[ _ <slides> _ open-window ] with-ui ;