extra/cairo-samples/cairo-samples.factor

   1 ! Copyright (C) 2008 Matthew Willis
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! these samples are a subset of the samples on
   5 ! http://cairographics.org/samples/
   6 USING: cairo cairo.ffi locals math.constants math
   7 io.backend kernel alien.c-types libc namespaces
   8 cairo.gadgets ui.gadgets accessors specialized-arrays.double ;
   9
  10 IN: cairo-samples
  11
  12 TUPLE: arc-gadget < cairo-gadget ;
  13 M:: arc-gadget render-cairo* ( gadget -- )
  14     [let | xc [ 128.0 ]
  15            yc [ 128.0 ]
  16            radius [ 100.0 ]
  17            angle1 [ pi 1/4 * ]
  18            angle2 [ pi ] |
  19         cr 10.0 cairo_set_line_width
  20         cr xc yc radius angle1 angle2 cairo_arc
  21         cr cairo_stroke
  22
  23         ! draw helping lines
  24         cr 1 0.2 0.2 0.6 cairo_set_source_rgba
  25         cr 6.0 cairo_set_line_width
  26
  27         cr xc yc 10.0 0 2 pi * cairo_arc
  28         cr cairo_fill
  29
  30         cr xc yc radius angle1 angle1 cairo_arc
  31         cr xc yc cairo_line_to
  32         cr xc yc radius angle2 angle2 cairo_arc
  33         cr xc yc cairo_line_to
  34         cr cairo_stroke
  35     ] ;
  36
  37 TUPLE: clip-gadget < cairo-gadget ;
  38 M: clip-gadget render-cairo* ( gadget -- )
  39     drop
  40     cr 128 128 76.8 0 2 pi * cairo_arc
  41     cr cairo_clip
  42     cr cairo_new_path
  43
  44     cr 0 0 256 256 cairo_rectangle
  45     cr cairo_fill
  46     cr 0 1 0 cairo_set_source_rgb
  47     cr 0 0 cairo_move_to
  48     cr 256 256 cairo_line_to
  49     cr 256 0 cairo_move_to
  50     cr 0 256 cairo_line_to
  51     cr 10 cairo_set_line_width
  52     cr cairo_stroke ;
  53
  54 TUPLE: clip-image-gadget < cairo-gadget ;
  55 M:: clip-image-gadget render-cairo* ( gadget -- )
  56     [let* | png [ "resource:misc/icons/Factor_128x128.png"
  57                   normalize-path cairo_image_surface_create_from_png ]
  58             w [ png cairo_image_surface_get_width ]
  59             h [ png cairo_image_surface_get_height ] |
  60         cr 128 128 76.8 0 2 pi * cairo_arc
  61         cr cairo_clip
  62         cr cairo_new_path
  63
  64         cr 192.0 w / 192.0 h / cairo_scale
  65         cr png 32 32 cairo_set_source_surface
  66         cr cairo_paint
  67         png cairo_surface_destroy
  68     ] ;
  69
  70 TUPLE: dash-gadget < cairo-gadget ;
  71 M:: dash-gadget render-cairo* ( gadget -- )
  72     [let | dashes [ double-array{ 50 10 10 10 } underlying>> ]
  73            ndash [ 4 ] |
  74         cr dashes ndash -50 cairo_set_dash
  75         cr 10 cairo_set_line_width
  76         cr 128.0 25.6 cairo_move_to
  77         cr 230.4 230.4 cairo_line_to
  78         cr -102.4 0 cairo_rel_line_to
  79         cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
  80         cr cairo_stroke
  81     ] ;
  82
  83 TUPLE: gradient-gadget < cairo-gadget ;
  84 M:: gradient-gadget render-cairo* ( gadget -- )
  85     [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
  86            radial [ 115.2 102.4 25.6 102.4 102.4 128.0
  87                     cairo_pattern_create_radial ] |
  88         pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
  89         pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
  90         cr 0 0 256 256 cairo_rectangle
  91         cr pat cairo_set_source
  92         cr cairo_fill
  93         pat cairo_pattern_destroy
  94
  95         radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
  96         radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
  97         cr radial cairo_set_source
  98         cr 128.0 128.0 76.8 0 2 pi * cairo_arc
  99         cr cairo_fill
 100         radial cairo_pattern_destroy
 101     ] ;
 102
 103 TUPLE: text-gadget < cairo-gadget ;
 104 M: text-gadget render-cairo* ( gadget -- )
 105     drop
 106     cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
 107     cairo_select_font_face
 108     cr 50 cairo_set_font_size
 109     cr 10 135 cairo_move_to
 110     cr "Hello" cairo_show_text
 111
 112     cr 70 165 cairo_move_to
 113     cr "factor" cairo_text_path
 114     cr 0.5 0.5 1 cairo_set_source_rgb
 115     cr cairo_fill_preserve
 116     cr 0 0 0 cairo_set_source_rgb
 117     cr 2.56 cairo_set_line_width
 118     cr cairo_stroke
 119
 120     ! draw helping lines
 121     cr 1 0.2 0.2 0.6 cairo_set_source_rgba
 122     cr 10 135 5.12 0 2 pi * cairo_arc
 123     cr cairo_close_path
 124     cr 70 165 5.12 0 2 pi * cairo_arc
 125     cr cairo_fill ;
 126
 127 TUPLE: utf8-gadget < cairo-gadget ;
 128 M: utf8-gadget render-cairo* ( gadget -- )
 129     drop
 130     cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
 131     cairo_select_font_face
 132     cr 50 cairo_set_font_size
 133     "cairo_text_extents_t" malloc-object
 134     cr "日本語" pick cairo_text_extents
 135     cr over
 136     [ cairo_text_extents_t-width 2 / ]
 137     [ cairo_text_extents_t-x_bearing ] bi +
 138     128 swap - pick
 139     [ cairo_text_extents_t-height 2 / ]
 140     [ cairo_text_extents_t-y_bearing ] bi +
 141     128 swap - cairo_move_to
 142     free
 143     cr "日本語" cairo_show_text
 144
 145     cr 1 0.2 0.2 0.6 cairo_set_source_rgba
 146     cr 6 cairo_set_line_width
 147     cr 128 0 cairo_move_to
 148     cr 0 256 cairo_rel_line_to
 149     cr 0 128 cairo_move_to
 150     cr 256 0 cairo_rel_line_to
 151     cr cairo_stroke ;
 152
 153  USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
 154  : samples ( -- )
 155     {
 156         arc-gadget clip-gadget clip-image-gadget dash-gadget
 157         gradient-gadget text-gadget utf8-gadget
 158     }
 159     [ new-gadget { 256 256 } >>dim gadget. ] each ;
 160
 161  MAIN: samples