From mboxrd@z Thu Jan  1 00:00:00 1970
Path: news.gmane.org!not-for-mail
From: Vladimir Zhbanov <vzhbanov@gmail.com>
Newsgroups: gmane.lisp.guile.user
Subject: Re: Example usages of guile-cairo
Date: Wed, 27 Jul 2016 22:30:27 +0300
Message-ID: <20160727193027.GB21477@localhost.localdomain>
References: <CAMFYt2aWLCOJxVqUtx-dj4P8oOPzUpD0R=QMfztPgy6Cn9P48w@mail.gmail.com>
	<20160715201922.GB12575@localhost.localdomain>
	<CAMFYt2aHs0ChZzEFMucvXnWp6tNO2H_AQSrJawArdg+TZRy1xQ@mail.gmail.com>
NNTP-Posting-Host: plane.gmane.org
Mime-Version: 1.0
Content-Type: multipart/mixed; boundary="wac7ysb48OaltWcw"
X-Trace: ger.gmane.org 1469647867 22528 80.91.229.3 (27 Jul 2016 19:31:07 GMT)
X-Complaints-To: usenet@ger.gmane.org
NNTP-Posting-Date: Wed, 27 Jul 2016 19:31:07 +0000 (UTC)
To: guile-user@gnu.org
Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Wed Jul 27 21:31:02 2016
Return-path: <guile-user-bounces+guile-user=m.gmane.org@gnu.org>
Envelope-to: guile-user@m.gmane.org
Original-Received: from lists.gnu.org ([208.118.235.17])
	by plane.gmane.org with esmtp (Exim 4.69)
	(envelope-from <guile-user-bounces+guile-user=m.gmane.org@gnu.org>)
	id 1bSUXl-0004Ef-A5
	for guile-user@m.gmane.org; Wed, 27 Jul 2016 21:31:01 +0200
Original-Received: from localhost ([::1]:48323 helo=lists.gnu.org)
	by lists.gnu.org with esmtp (Exim 4.71)
	(envelope-from <guile-user-bounces+guile-user=m.gmane.org@gnu.org>)
	id 1bSUXk-0008HW-Gj
	for guile-user@m.gmane.org; Wed, 27 Jul 2016 15:31:00 -0400
Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:45874)
	by lists.gnu.org with esmtp (Exim 4.71)
	(envelope-from <vzhbanov@gmail.com>) id 1bSUXN-0008HC-Tz
	for guile-user@gnu.org; Wed, 27 Jul 2016 15:30:39 -0400
Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71)
	(envelope-from <vzhbanov@gmail.com>) id 1bSUXK-0004ee-5F
	for guile-user@gnu.org; Wed, 27 Jul 2016 15:30:37 -0400
Original-Received: from mail-lf0-x22b.google.com ([2a00:1450:4010:c07::22b]:35413)
	by eggs.gnu.org with esmtp (Exim 4.71)
	(envelope-from <vzhbanov@gmail.com>) id 1bSUXJ-0004eI-PR
	for guile-user@gnu.org; Wed, 27 Jul 2016 15:30:34 -0400
Original-Received: by mail-lf0-x22b.google.com with SMTP id f93so34475611lfi.2
	for <guile-user@gnu.org>; Wed, 27 Jul 2016 12:30:31 -0700 (PDT)
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113;
	h=date:from:to:subject:message-id:mail-followup-to:references
	:mime-version:content-disposition:in-reply-to:user-agent;
	bh=ASdV2k5nD84tieTkKaez0OwEaIjDgm7+dauPIdX2Vck=;
	b=HFRBwSdzqPuq2876izyTJQnq0lsBmv8ooTPeuMRKv8GMcAdAO18LnyUwKHqNBSZK68
	e3zuryUFszQYRAeUE2V5AIplZpe4Co5KZKRTxxZzNdI0vVYDsN2TPVwoHODrfan6/dDr
	+ztxPp5utGwEq58s2mcthBXKOarygq+8oj/fvOUQwfOz8sKu5t5bMzVcLXY93JD4piHR
	FVb+uuMeYY8AHZ7Cy7gkF4kDoEYv/Xn8/wAJ9E5YogsO422Vn0BPF2nz5wK6qAMlaE0p
	nw6HtHKNo8fKurgl0QkQILTX+rpJMUBDFIVnXgHPNkykURRlBjz2Hzqxktd0vKXG7UGo
	1+YA==
X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
	d=1e100.net; s=20130820;
	h=x-gm-message-state:date:from:to:subject:message-id:mail-followup-to
	:references:mime-version:content-disposition:in-reply-to:user-agent;
	bh=ASdV2k5nD84tieTkKaez0OwEaIjDgm7+dauPIdX2Vck=;
	b=C9nVKLwDgke1y0b2e7yXyfN0pfDXQnKCO6v53SFFVwqPT0NiApekoCO3YghnGcvqI7
	G+lF1TTZ0pGcO+hso1ul8OuzNdGgSB7NErdbvW0ur879Kx0SCTjfx/tjFMZxHPMg4F2S
	Izt5YcA3l23ibKKPtVRL4IVu4BOoQzjrN4DAj4Fr2APXDtaiseFZvjPgpxxv5837DaBf
	sxryRuEuROuAnc0ORlILZZbdAlRQv/GD/CK1l8UQAtYrHlnh/JlOKZIRgXlkfrSN1QIU
	DLNtKffqPMsR7YfmiGkHty73bl3kRXBkTUY4rayIi80tRXWSkSSDtbRmfj5GLIlF2JCX
	qJzA==
X-Gm-Message-State: AEkoouvTwPr1YxcipQv1RWos7FDOVBLJ3Ks0Hbw4Q2hl8yXerm/ZxxI/M5vuAuZ6CnVGsA==
X-Received: by 10.25.210.80 with SMTP id j77mr11148828lfg.139.1469647830138;
	Wed, 27 Jul 2016 12:30:30 -0700 (PDT)
Original-Received: from newvzh.vzh ([217.107.127.93])
	by smtp.gmail.com with ESMTPSA id 78sm1233095lfv.39.2016.07.27.12.30.28
	for <guile-user@gnu.org>
	(version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128);
	Wed, 27 Jul 2016 12:30:29 -0700 (PDT)
Original-Received: from vovka by newvzh.vzh with local (Exim 4.84_2)
	(envelope-from <vzhbanov@gmail.com>) id 1bSUXD-0003lo-EK
	for guile-user@gnu.org; Wed, 27 Jul 2016 22:30:27 +0300
Mail-Followup-To: guile-user@gnu.org
Content-Disposition: inline
In-Reply-To: <CAMFYt2aHs0ChZzEFMucvXnWp6tNO2H_AQSrJawArdg+TZRy1xQ@mail.gmail.com>
User-Agent: Mutt/1.5.23 (2014-03-12)
X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic]
X-Received-From: 2a00:1450:4010:c07::22b
X-BeenThere: guile-user@gnu.org
X-Mailman-Version: 2.1.21
Precedence: list
List-Id: General Guile related discussions <guile-user.gnu.org>
List-Unsubscribe: <https://lists.gnu.org/mailman/options/guile-user>,
	<mailto:guile-user-request@gnu.org?subject=unsubscribe>
List-Archive: <http://lists.gnu.org/archive/html/guile-user/>
List-Post: <mailto:guile-user@gnu.org>
List-Help: <mailto:guile-user-request@gnu.org?subject=help>
List-Subscribe: <https://lists.gnu.org/mailman/listinfo/guile-user>,
	<mailto:guile-user-request@gnu.org?subject=subscribe>
Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org
Original-Sender: "guile-user" <guile-user-bounces+guile-user=m.gmane.org@gnu.org>
Xref: news.gmane.org gmane.lisp.guile.user:12801
Archived-At: <http://permalink.gmane.org/gmane.lisp.guile.user/12801>


--wac7ysb48OaltWcw
Content-Type: text/plain; charset=utf-8
Content-Disposition: inline

On Sat, Jul 16, 2016 at 10:05:45AM +0200, Panicz Maciej Godek wrote:
> Hi,
> thanks for your reply -- I think I have solved it (although I took a
> slightly different approach*) -- the problem was probably that the scale
> was too small for anything to be visible, and it was sufficient to enlarge
> the values of points.
> 
> Of course, if you publish your examples, as it is always a pleasure to read
> other people's ideas :)

I don't think they have anything valuable Scheme-wise. Anyways,
the code is attached. It uses gtk and cairo, and repeating
patterns which I used to prototype custom grids on my
canvas. Probably it could be useful for someone. Working on the
code I've learned hard way gtk is not thread save and how to avoid
this issue working in the Emacs Geiser environment. Basically, it
is something like
  (gdk-threads-init) ; only once
  ; and then
  (and (gdk-threads-enter)
       (your-function)
       (gdk-threads-leave))

Other attempts always lead me to crashes due to non-thread-safe
underground libraries (I cannot recall all, though one of which is
libpango which bugged me not long ago when I worked on another
issue). Even using (begin ...) instead of (and ...) lead to
crashes. Now I suspect the procedures in the (begin ...) body while
are executed one by one, nobody waits until any of them finishes,
which leads to race conditions in the gtk case. Probably I'm
wrong, don't know.

Further investigation has showed me that the standard external
REPL server (I still use the stock version of guile in Debian
stable which is 2.0.11) doesn't even use after-eval-hook so I
cannot try to automate those two calls without using work-arounds
in my code. I've found the rework of REPL in the Sly (previously
guile-2d) code by David Thompson which solves this for his
library. Hope to see something like this in the future releases of
guile.

BTW, thank you for your pamphlet against R. It has given me many
new ideas wrt the code I'm now working on.

-- 
  Vladimir

--wac7ysb48OaltWcw
Content-Type: text/plain; charset=utf-8
Content-Disposition: attachment; filename="grid.scm"

(use-modules (srfi srfi-1)
             (oop goops)
             (cairo)
             (gnome-2)
             (gnome gobject)
             (gnome gtk))

;;; The following commands may sometimes be very useful:
;;;   (gtype-class-get-signal-names <gtk-drawing-area>)
;;;   (get-property-names <gtk-drawing-area>)

;;; 3.1415926
(define pi (* 4 (atan 1)))

(define (draw-sample cr width height)
  (let ((radius 3)
        (x (/ width 2))
        (y (/ height 2)))
    ;; Use (cairo-antialias-get-values) to define the value of the
    ;; type <cairo-antialias-t> you need.
    (cairo-set-antialias cr 'none)

    ;; Set background color
    (cairo-set-source-rgba cr 0 .7 .4 .5)
    ;; Paint all area with it
    (cairo-paint cr)

    ;; paint a circle
    (cairo-set-source-rgba cr 1 1 0 1)
    (cairo-arc cr x y radius 0 (* 2 pi))
    ;; set background color and fill it
    (cairo-fill-preserve cr)
    ;; set margin color and stroke it
    (cairo-set-source-rgb cr 0 0 0)
    (cairo-set-line-width cr 1)
    (cairo-stroke cr)
    ))

(define (create-sample-surface-similar-to global-cr size scale)
  (let* ((width (* size scale))
         (height width)
         ;; create a new local surface that is as compatible as possible
         ;; with an existing one for the global context;
         ;; (cairo-get-target) gets the cairo surface for the given
         ;; cairo context
         (surface (cairo-surface-create-similar
                   (cairo-get-target global-cr)
                   ;; Use (cairo-content-get-values) to define the
                   ;; value of the type <cairo-content-t> you need.
                   'color-alpha
                   width
                   height))
         ;; create a new cairo context for the new surface
         (cr (cairo-create surface)))

    ;; This sample will become the pattern repeated over the canvas
    (draw-sample cr width height)
    surface))

(define (dots-pattern global-cr size scale)
  ;; next, create a pattern for the local surface we have
  (let ((pattern (cairo-pattern-create-for-surface
                  (create-sample-surface-similar-to global-cr
                                                    size
                                                    scale))))
    ;; Adjust the pattern to make it be repeated.
    ;; Use (cairo-extend-get-values) to define the value of the
    ;; type <cairo-extend-t> you need.
    (cairo-pattern-set-extend pattern 'repeat)
    pattern))

(define (draw cr width height size scale)
  (let ((halfway (/ (* size scale) 2))
        (pattern (dots-pattern cr size scale)))
    (cairo-translate cr halfway halfway)
    ;; set the pattern as a source for the global context
    (cairo-set-source cr pattern)
    (cairo-translate cr (- halfway) (- halfway))
    ;; create a path in the global cairo context (I use the whole
    ;; area)
    (cairo-rectangle cr 0 0 width height)
    ;; and fill it with the pattern
    (cairo-fill cr)
    ))

;;; Get size of GDK-WINDOW
;;; We could use something like
;;;   (event-coord-info (vector->list
;;;                      (fourth
;;;                       (vector->list
;;;                        (gdk-event->vector event)))))
;;; However there is a more specialized way.
;;; The function gdk-drawable-get-size used here is deprecated in
;;; new gtk+ versions, but I use it since guile-cairo on my Debian
;;; system is slightly old and doesn't support its replacements
;;; gdk-window-get-width and gdk-window-get-height.
(define (get-size gdk-window)
  (call-with-values
      (lambda () (gdk-drawable-get-size gdk-window))
    (lambda (a b) (cons a b))))


(define (grid-pattern-expose widget event)
  (let* ((size 15)
         (scale 3)
         (gdk-window (get widget 'window))
         ;; get cairo context for gtk widget
         (cr (gdk-cairo-create gdk-window))
         (window-size (get-size gdk-window))
         (width (car window-size))
         (height (cdr window-size)))
    (apply draw cr `(,width ,height ,size ,scale))
    #f))

(define-class <grid-pattern> (<gtk-drawing-area>)
  #:gsignal '(hi #f))
(define-method (grid-pattern:hi (entry <grid-pattern>))
  (format #t "Hi, all! I'm here! My name is ~A\n" entry))

(define (make-widget)
  (let ((widget (make <grid-pattern>)))
    (connect widget 'expose-event grid-pattern-expose)
    widget))


(define (make-window)
  (let* ((window (make <gtk-window> #:type 'toplevel #:title "Guile Cairo"))
	 ;;;; (button (make <gtk-button> #:label "Hello, World!"))
         )

    (set window 'border-width 10)
    ;;;; (add window button)

    ;;;; (gtype-instance-signal-connect button 'clicked (lambda (b) (gtk-main-quit)))
    (connect window 'destroy (lambda (b) (gtk-main-quit)))

    window))


;;; Make a window and a widget for it.
(define w (make-window))
(define widget (make-widget))
(add w widget)

(show-all w)
(emit widget 'hi)

;;; Threading
(gdk-threads-init)
;;; The above command (gdk-threads-init) is not sufficient to
;;; prevent crashes in multy-threaded environment.  The following
;;; pair of commands must be used in the Guile REPL to prevent
;;; crashes while working in Geiser (using a socket):
;;;   (gdk-threads-enter)
;;;   (gdk-threads-leave)
;;; Convenience procedures
(define -> (gdk-threads-enter))
(define <- (gdk-threads-leave))
;;; Use the following sequence:
;;; -> (your-command) <-

;;; Run main gtk loop yourself if you're working in Geiser
(gtk-main)

--wac7ysb48OaltWcw--