Re: [Help-smalltalk] cairo library wrapper

[Mike Anderson]

Brad Watson wrote:
> Please find attached a first attempt at creating a wrapper for the cairo 
> library.

The "clock demo" I posted a while back uses Cairo to do its drawing. 
Here is the relevant code for comparison.

Mike

"======================================================================
|
| Copyright 2006 Mike Anderson
| Written by Mike Anderson
|
| This is free software; you can redistribute it and/or modify it under 
| the terms of the GNU Lesser General Public License as published by the 
| Free Software Foundation; either version 2.1, or (at your option) any 
| later version.
| 
| This code is distributed in the hope that it will be useful, but 
| WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
| or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public 
| License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LIB.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================
"

Object subclass: #CLibrary
        instanceVariableNames: ''
        classVariableNames: 'typesMap funcsMap'
        poolDictionaries: ''
        category: ''
!

!CLibrary class methodsFor: 'loading'!

smalltalkize: aString
    | r aa |
    r := WriteStream on: String new.
    aa := (aString tokenize: '_') asOrderedCollection.
    r << aa removeFirst.
    aa do: [ :each | r << each first asUppercase << (each copyFrom: 2) ].
    ^r contents.
!

defaultSelector: aFuncName args: aArgs
    | sel | 
    sel := self smalltalkize: aFuncName.
    aArgs notEmpty ifTrue:
        [ sel := WriteStream with: sel.
        sel << ': ' << (self smalltalkize: (aArgs at: 1)).
        (aArgs copyFrom: 2) do: 
            [ :each | sel << ' ' << (self smalltalkize: each) << ': ' 
                << (self smalltalkize: each) ].
        sel := sel contents. ].
    ^sel
!

normalizeSpace: aString
        | s |
        s := aString copyReplacingAllRegex: '[ \t\n\r]+' with: ' '.
        s := s copyReplacingAllRegex: ' \*' with: '*'.
        ^s trimSeparators
!

parseCFunction: aFuncDecl
    | parsed args fn m ret sel |
        
        m := (self normalizeSpace: aFuncDecl) 
        =~ '^([\w+ \*]+)\b([\w-]+) *\(([^\)]*)\)'.
        m matched ifFalse: 
        [ self error: 'Can''t parse function declaration: ', aFuncDecl ].
                
        parsed := LookupTable new.
        args := OrderedCollection new.
        parsed at: #args put: args.

        ret := self normalizeSpace: (m at: 1).

        self typesMap at: ret ifPresent: [ :a | ret := a ]. 
        parsed at: #return put: ret asSymbol.
        fn := m at: 2.
        parsed at: #name put: fn.
        (m at: 3) onRegexMatches: '(\w[^,]*)\b(\w[-\w]*)(,|$)' do: 
                [ :each | | name type |
                name := each at: 2.
                type := self typesMap at: (self normalizeSpace: (each at: 1)).
                args add: name -> type. ].
                
        parsed at: #selector put:
                (self funcsMap 
                        at: fn 
                        ifAbsent: 
                                [ self 
                                        defaultSelector: fn 
                                        args: (args collect: [ :each | each key 
]) ]).
                                        
        ^parsed
!

addCFunction: aFuncDecl
    | parsed added |
        
        parsed := self parseCFunction: aFuncDecl.
                
    DLD defineExternFunc: (parsed at: #name).

    "Transcript << self name << ' ' << (parsed at: #selector)."
        [ added := self class defineCFunc: (parsed at: #name)
                        withSelectorArgs: (parsed at: #selector)
                        returning: (parsed at: #return)
                        args: ((parsed at: #args) collect: [ :each | each value 
]) asArray.
                ] on: Error do:
                [ :sig | 
                Transcript << 'defineCFunc failed for:'; nl.
                Transcript << (parsed at: #name) ; nl.
                Transcript << (parsed at: #selector) ; nl.
                Transcript << (parsed at: #return) ; nl.
                Transcript << ((parsed at: #args) collect: [ :each | each value 
]) asArray; nl.
                sig signal. ].

    "Transcript << ' ok'; nl."
        
        ^parsed
!

initializeTypesMap
    #('unknown' 'boolean' 'char' 'string' 'stringOut' 'symbol' 'byteArray' 
        'int' 'uInt' 'long' 'uLong' 'double' 'cObject' 
        'smalltalk' 'variadic' 'variadicSmalltalk' 'self' 'selfSmalltalk')
        do:
        [ :each | typesMap at: each put: each asSymbol ].
    typesMap
        at: 'unsigned int' put: #uInt;
        at: 'unsigned long' put: #uLong;
        at: 'char*' put: #string.
    
!

typesMap
        typesMap isNil ifTrue: 
            [ typesMap := LookupTable new. 
            self initializeTypesMap ].
        ^typesMap
!

funcsMap
        funcsMap isNil ifTrue: [ funcsMap := LookupTable new ].
        ^funcsMap
!
!

"======================================================================
|
| Copyright 2006 Mike Anderson
| Written by Mike Anderson
|
| This is free software; you can redistribute it and/or modify it under 
| the terms of the GNU Lesser General Public License as published by the 
| Free Software Foundation; either version 2.1, or (at your option) any 
| later version.
| 
| This code is distributed in the hope that it will be useful, but 
| WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
| or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public 
| License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LIB.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================
"

CLibrary subclass: #Cairo
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: ''
!

CStruct subclass: #CairoMatrix
    declaration: #( 
            (#xx #double)
            (#yx #double)
            (#xy #double)
            (#yy #double)
            (#x0 #double)
            (#y0 #double)
        )
    classVariableNames: ''
    poolDictionaries: ''
    category: ''
!

CStruct subclass: #CairoTextExtents
    declaration: #( 
                (#xBearing #double)
                (#yBearing #double)
                (#width #double)
                (#height #double)
                (#xAdvance #double)
                (#yAdvance #double)
        )
    classVariableNames: ''
    poolDictionaries: ''
    category: ''
!

!Cairo class methodsFor: 'loading'!

defaultSelector: aFuncName args: aArgs
    | sel | 
        sel := super defaultSelector: aFuncName args: aArgs.
    (sel startsWith: 'cairo') ifTrue: 
                [ sel := (sel at: 6) asLowercase asString, (sel copyFrom: 7) ]. 
        ^sel.
!

load    
    (DLD addLibrary: 'libcairo') ifNotNil: [ :s | s printNl ].

    self typesMap
                at: 'const char*' put: #string;
        at: 'Drawable' put: #uLong; "From XLib"
        at: 'Pixmap' put: #uLong;       "From XLib"
                at: 'cairo_t*' put: #cObject;
                at: 'cairo_surface_t*' put: #cObject;
                at: 'cairo_pattern_t*' put: #cObject;
                at: 'cairo_line_cap_t' put: #int;
                at: 'cairo_line_join_t' put: #int;
                at: 'const cairo_matrix_t*' put: #cObject;
                at: 'cairo_matrix_t*' put: #cObject;
                at: 'cairo_text_extents_t*' put: #cObject;
                at: 'cairo_font_slant_t' put: #int;
                at: 'cairo_font_weight_t' put: #int.
                    
    #(  'void cairo_surface_destroy (cairo_surface_t *surface);'
                'void cairo_surface_flush (cairo_surface_t *surface);'
                'void cairo_surface_finish (cairo_surface_t *surface);'
                
                'cairo_surface_t* cairo_xlib_surface_create (Display *dpy, 
Drawable drawable, Visual *visual, int width, int height);'
                'cairo_surface_t* cairo_xlib_surface_create_for_bitmap (Display 
*dpy, Pixmap bitmap, Screen *screen, int width, int height);'
                'void cairo_xlib_surface_set_size (cairo_surface_t *surface, 
int width, int height);'
                'void cairo_xlib_surface_set_drawable (cairo_surface_t 
*surface, Drawable drawable, int width, int height);'
                
                'cairo_t* cairo_create (cairo_surface_t *target);'
                'cairo_t* cairo_reference (cairo_t *cr);'
                'void cairo_destroy (cairo_t *cr);'
                'void cairo_save (cairo_t *cr);'
                'void cairo_restore (cairo_t *cr);'
                
                'void cairo_new_path (cairo_t *cr);'            
                'void cairo_move_to (cairo_t *cr, double x, double y);'
                'void cairo_line_to (cairo_t *cr, double x, double y);'
                'void cairo_curve_to (cairo_t *cr, double x1, double y1, double 
x2, double y2, double x3, double y3);'
                'void cairo_arc (cairo_t *cr, double xc, double yc, double 
radius, double angle1, double angle2);'
                'void cairo_arc_negative (cairo_t *cr, double xc, double yc, 
double radius, double angle1, double angle2);'
                "void cairo_arc_to (cairo_t *cr, double x1, double y1, double 
x2, double y2, double radius);"
                'void cairo_rel_move_to (cairo_t *cr, double dx, double dy);'
                'void cairo_rel_line_to (cairo_t *cr, double dx, double dy);'
                'void cairo_rel_curve_to (cairo_t *cr, double dx1, double dy1, 
double dx2, double dy2, double dx3, double dy3);'
                'void cairo_rectangle (cairo_t *cr, double x, double y, double 
width, double height);'
                "void cairo_stroke_to_path (cairo_t *cr);"
                'void cairo_close_path (cairo_t *cr);'

                'void cairo_translate (cairo_t *cr, double tx, double ty);'
                'void cairo_scale (cairo_t *cr, double sx, double sy);'
                'void cairo_rotate (cairo_t *cr, double angle);' 
                'void cairo_transform (cairo_t *cr, const cairo_matrix_t 
*matrix);'
                'void cairo_set_matrix (cairo_t *cr, const cairo_matrix_t 
*matrix);'
                'void cairo_get_matrix (cairo_t *cr, cairo_matrix_t *matrix);'
                'void cairo_identity_matrix (cairo_t *cr);'

                'void cairo_paint (cairo_t *cr);'
                'void cairo_paint_with_alpha (cairo_t *cr, double alpha);'
                'void cairo_mask (cairo_t *cr, cairo_pattern_t *pattern);'
                'void cairo_mask_surface (cairo_t *cr, cairo_surface_t 
*surface, double surface_x, double surface_y);'
                'void cairo_stroke (cairo_t *cr);'
                'void cairo_stroke_preserve (cairo_t *cr);'
                'void cairo_fill (cairo_t *cr);'
                'void cairo_fill_preserve (cairo_t *cr);'
                'void cairo_set_source (cairo_t *cr, cairo_pattern_t *source);'
                'void cairo_set_source_rgb (cairo_t *cr, double red, double 
green, double blue);'
                'void cairo_set_source_rgba (cairo_t *cr, double red, double 
green, double blue, double alpha);'
                'void cairo_set_line_width (cairo_t *cr, double width);'
                'void cairo_set_line_cap (cairo_t *cr, cairo_line_cap_t 
line_cap);'
                'void cairo_set_line_join (cairo_t *cr, cairo_line_join_t 
line_join);'
                
                'void cairo_pattern_add_color_stop_rgb (cairo_pattern_t 
*pattern, double offset, double red, double green, double blue);'
                'void cairo_pattern_add_color_stop_rgba (cairo_pattern_t 
*pattern, double offset, double red, double green, double blue, double alpha);'
                'cairo_pattern_t* cairo_pattern_create_rgb (double red, double 
green, double blue);'
                'cairo_pattern_t* cairo_pattern_create_rgba (double red, double 
green, double blue, double alpha);'
                'cairo_pattern_t* cairo_pattern_create_for_surface 
(cairo_surface_t *surface);'
                'cairo_pattern_t* cairo_pattern_create_linear (double x0, 
double y0, double x1, double y1);'
                'cairo_pattern_t* cairo_pattern_create_radial (double cx0, 
double cy0, double radius0, double cx1, double cy1, double radius1);'
                'void cairo_pattern_destroy (cairo_pattern_t *pattern);'
                'void cairo_pattern_set_matrix (cairo_pattern_t *pattern, const 
cairo_matrix_t *matrix);'
                'void cairo_pattern_get_matrix (cairo_pattern_t *pattern, 
cairo_matrix_t *matrix);'
                
                'void cairo_select_font_face (cairo_t *cr, const char *family, 
cairo_font_slant_t slant, cairo_font_weight_t weight);'
                'void cairo_set_font_size (cairo_t *cr, double size);'
                'void cairo_set_font_matrix (cairo_t *cr, const cairo_matrix_t 
*matrix);'
                'void cairo_get_font_matrix (cairo_t *cr, cairo_matrix_t 
*matrix);'
                'void cairo_show_text (cairo_t *cr, const char *utf8);'
                'void cairo_text_extents (cairo_t *cr, const char *utf8, 
cairo_text_extents_t *extents);'
                )
                do:
                [ :each | self addCFunction: each. ].
!
!

Cairo load
!

"Namespace current at: #Cairo put: (CairoLibrary new)"
!

"======================================================================
|
| Copyright 2006 Mike Anderson
| Written by Mike Anderson
|
| This is free software; you can redistribute it and/or modify it under 
| the terms of the GNU Lesser General Public License as published by the 
| Free Software Foundation; either version 2.1, or (at your option) any 
| later version.
| 
| This code is distributed in the hope that it will be useful, but 
| WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
| or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public 
| License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LIB.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================
"

PackageLoader fileInPackages: #('Regex' 'MUtility')!

Class methodsFor: 'organization of methods and classes'!

defineExternCFunc: aCFuncName withSelectorArgs: aSelector returning: 
aReturnType args: aArgArray
    "Convenience method"
    DLD defineExternFunc: aCFuncName asSymbol.
    
    self class defineCFunc: aCFuncName 
        withSelectorArgs: aSelector 
        returning: aReturnType 
        args: aArgArray.
!
!

Array methodsFor: 'converting'!

asDictionary
    | r |
    r := LookupTable new: self size.
    self do:
        [ :each | r at: each first put: each second ].
    ^r
!
!

String methodsFor: 'regex'!

onRegexMatches: aPattern do: aBlock
    "Searches for a pattern and executed passed instruction-body (as a trigger)"
    | idx regex m |
    regex := aPattern asRegex.
    idx := 1.
    [   m := self searchRegex: regex startingAt: idx.
        m matched  ] 
        whileTrue: 
            [ aBlock value: m.
            idx := m to + 1. ].
!
!

DLD class methodsFor: 'debugging'!

addLibrary: library
    "Add library to the search path of libraries to be used by DLD."
    ^(LibraryList anySatisfy: [ :anAssociation | anAssociation key = library ])
                ifTrue: [ 'Already added' ]
                ifFalse: 
                        [ | handle |
                        handle := (self linkFile: library).
                        LibraryList add: library -> handle.
                        LibraryStream := RoundRobinStream on: LibraryList 
readStream.
                        handle isNil 
                                ifTrue: [ 'Link failed.' ]
                                ifFalse: [ nil ] ].
!
!