This file is indexed.

/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))