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