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