/usr/share/doc/guile-gnome2-gtk/examples/test-gdk.scm is in guile-gnome2-gtk 2.16.1-6ubuntu2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | #! /bin/sh
# -*- scheme -*-
exec guile-gnome-2 -s $0 "$@"
!#
;; guile-gnome
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program 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 General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
(use-modules (gnome gtk))
;; translate me nicely please :-)
(define div quotient)
(define (arc-drawer-new width height start-adj extent-adj)
(let ((widget (make <gtk-drawing-area>))
(pixmap #f) (window #f)
(fore-gc #f) (back-gc #f) (handle-gc #f)
(start #f) (extent #f) (need-update #t)
(pi (* 2 (acos 0)))
(poly '((10 . 10) (20 . 10) (10 . 20) (50 . 50)))
(use-backing #f))
(define (realize)
(set! window (window widget))
(let ((style (gtk-widget-style widget)))
(set! fore-gc (gtk-style-fg-gc style 'normal))
(set! back-gc (gtk-style-bg-gc style 'normal)))
(configure #f))
(define (configure ev)
(cond (ev
(set! width (gdk-event-configure-width ev))
(set! height (gdk-event-configure-height ev))))
(cond (window
(set! pixmap (if use-backing
(gdk-pixmap-new window width height)
window))
(set! need-update #t)
(set! handle-gc (gdk-gc-new pixmap))
(gdk-gc-set-foreground handle-gc "red3"))))
(define (expose ev)
(cond (use-backing
(if need-update (update))
(gdk-draw-pixmap window back-gc pixmap 0 0 0 0 width height))
(else
(update))))
(define (draw-handle x y)
(gdk-draw-rectangle pixmap handle-gc #t
(+ x -2)
(+ y -2)
4 4))
(define (draw-poly)
(gdk-draw-polygon pixmap fore-gc #t poly)
(for-each (lambda (p) (draw-handle (car p) (cdr p))) poly))
(define (draw-arc)
(let ((dx 5) (dy 5) (w (- width 10)) (h (- height 10)))
(define (draw-arc-handle angle)
(define (->rad x) (* x (/ pi (* 180 64))))
(let ((x (inexact->exact (* 0.5 w (cos (->rad angle)))))
(y (inexact->exact (* -0.5 h (sin (->rad angle))))))
(draw-handle (+ (div w 2) dx x) (+ (div h 2) dy y))))
(gdk-draw-arc pixmap fore-gc #f
dx dy w h (remainder start (* 360 64)) extent)
(draw-arc-handle start)
(draw-arc-handle (+ start extent))))
(define button1-motion-handler #f)
(define (button1-motion ev)
(if button1-motion-handler (button1-motion-handler ev)))
(define (button-release ev)
(cond ((= (gdk-event-button ev) 1)
(set! button1-motion-handler #f))))
(define (drag-poly ev)
(define (find-poly-handle x y)
(or-map (lambda (p)
(and (< (abs (- x (car p))) 4)
(< (abs (- y (cdr p))) 4)
p))
poly))
(let ((handle (find-poly-handle (gdk-event-x ev) (gdk-event-y ev))))
(cond (handle
(set! button1-motion-handler
(lambda (ev)
(let ((x (gdk-event-x ev))
(y (gdk-event-y ev)))
(set-car! handle x)
(set-cdr! handle y)
(update))))))))
(define (update)
(set! start (inexact->exact (* (gtk-adjustment-value start-adj) 64)))
(set! extent (inexact->exact (* (gtk-adjustment-value extent-adj) 64)))
(cond (window
(gdk-draw-rectangle pixmap back-gc #t 0 0 width height)
(draw-arc)
(draw-poly)
(set! need-update #f)
(if use-backing (expose #f)))))
(define (pk-event ev)
(pk (gdk-event-type ev) (gdk-event-x ev) (gdk-event-y ev)))
(gtk-signal-connect widget "button_press_event" drag-poly)
(gtk-signal-connect widget "button_release_event" button-release)
(gtk-signal-connect widget "motion_notify_event" button1-motion)
(gtk-signal-connect widget "realize" realize)
(gtk-signal-connect widget "expose_event" expose)
(gtk-signal-connect widget "configure_event" configure)
(gtk-signal-connect start-adj "value_changed" update)
(gtk-signal-connect extent-adj "value_changed" update)
(gtk-drawing-area-size widget width height)
(gtk-widget-set-events widget '(exposure-mask
button-press-mask
button-release-mask
button1-motion-mask
key-press-mask))
(lambda (op . args)
(case op
((widget)
widget)
((use-backing)
(set! use-backing (car args))
(configure #f))))))
(let* ((window (gtk-window-new 'toplevel))
(vbox (gtk-vbox-new #f 5))
(start-adj (gtk-adjustment-new 360.0 0.0 721.0 1.0 1.0 1.0))
(start-scl (gtk-hscale-new start-adj))
(extent-adj (gtk-adjustment-new 180.0 0.0 361.0 1.0 1.0 1.0))
(extent-scl (gtk-hscale-new extent-adj))
(arc (arc-drawer-new 150 150 start-adj extent-adj))
(backing-button (gtk-check-button-new-with-label "Use backing pixmap"))
(close (gtk-button-new-with-label "close")))
(gtk-container-add window vbox)
(gtk-box-pack-start vbox (arc 'widget) #t #t 0)
(gtk-box-pack-end vbox close #f #f 0)
(gtk-box-pack-end vbox backing-button #f #f 0)
(gtk-box-pack-end vbox extent-scl #f #f 0)
(gtk-box-pack-end vbox start-scl #f #f 0)
(gtk-signal-connect backing-button "clicked"
(lambda ()
(arc 'use-backing
(gtk-widget-get backing-button 'active))))
(gtk-signal-connect close "clicked" (lambda () (gtk-widget-destroy window)))
(gtk-scale-set-draw-value start-scl #f)
(gtk-scale-set-draw-value extent-scl #f)
(gtk-widget-show-all window)
(gtk-standalone-main window))
|