[Openmcl-cvs-notifications] r12844 - /trunk/source/examples/gtk-clock.lisp
gb at clozure.com
gb at clozure.com
Wed Sep 16 11:19:41 EDT 2009
Author: gb
Date: Wed Sep 16 11:19:41 2009
New Revision: 12844
Log:
Remove old (gtk1.x) example.
Removed:
trunk/source/examples/gtk-clock.lisp
Removed: trunk/source/examples/gtk-clock.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/gtk-clock.lisp (original)
+++ trunk/source/examples/gtk-clock.lisp (removed)
@@ -1,203 +1,0 @@
-;;;-*-Mode: LISP; Package: CCL -*-
-;;;
-;;; Copyright (C) 2001 Clozure Associates
-;;;
-;;; This is a (loose) translation of the double-buffered clock GTK+
-;;; example to OpenMCL. See p 222 of "Developing Linux Applications
-;;; with GDK and GTK+", Eric Harlow, (c) 1999 New Riders Publishing.
-;;;
-;;; Anyone who wants to use this code for any purpose is free to do so.
-;;; In doing so, the user acknowledges that this code is provided "as is",
-;;; without warranty of any kind, and that no other party is legally or
-;;; otherwise responsible for any consequences of its use.
-
-(in-package "CCL")
-
-;;; =
-;;; Make GTK+ interface info available.
-(eval-when (:compile-toplevel :execute)
- (use-interface-dir :GTK))
-
-;;; GTK+ "runtime support"; handy to have around at compile time, too.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (require "OPENMCL-GTK-SUPPORT"))
-
-
-;;; A global alist mapping clock windows to their offscreen pixmaps.
-(defvar *gtk-clock-window-pixmaps* ())
-
-
-(defun draw-tick-at (pixmap gc nhour cx cy radius)
- (let* ((radians (/ (* pi nhour) 6.0d0))
- (sin-radians (sin radians))
- (cos-radians (cos radians))
- (95%radius (* radius .95)))
- (#_gdk_draw_line pixmap gc
- (+ cx (floor (* 95%radius sin-radians)))
- (+ cy (floor (* 95%radius cos-radians)))
- (+ cx (floor (* radius sin-radians)))
- (+ cy (floor (* radius cos-radians))))))
-
-;;; It seems like this can get called when the drawing area's in the
-;;; process of being destroyed. Try not to segfault in that case.
-(defcallback gtk-clock-repaint (:address data :signed-fullword)
- (if (or (%null-ptr-p data)
- (%null-ptr-p (pref data :<G>tk<W>idget.style)))
- #$FALSE
- (let* ((drawing-area data)
- (radius 0)
- (white-gc (pref drawing-area :<G>tk<W>idget.style.white_gc))
- (black-gc (pref drawing-area :<G>tk<W>idget.style.black_gc))
- (area-width (pref drawing-area :<G>tk<W>idget.allocation.width))
- (area-height (pref drawing-area :<G>tk<W>idget.allocation.height))
- (dradians)
- (midx 0)
- (midy 0)
- (vbox (pref drawing-area :<G>tk<W>idget.parent))
- (window (pref vbox :<G>tk<W>idget.parent))
- (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*))))
- (rlet ((update-rect :<G>dk<R>ectangle))
- ;; Clear pixmap (background image)
- (#_gdk_draw_rectangle
- pixmap white-gc #$TRUE 0 0 area-width area-height)
- =
- ;; Calculate midpoint of clock.
- (setq midx (ash area-width -1)
- midy (ash area-height -1))
- =
- ;; Calculate radius
- (setq radius (min midx midy))
-
- ;; Draw circle
- (#_gdk_draw_arc pixmap black-gc 0 0 0
- (+ midx midx) (+ midy midy) 0 (* 360 64))
- =
- ;; Draw tickmarks on clock face.
- (do* ((nhour 1 (1+ nhour)))
- ((> nhour 12))
- (draw-tick-at pixmap black-gc nhour midx midy radius))
- (multiple-value-bind (seconds minutes hours)
- (decode-universal-time (get-universal-time))
- =
- ;; Get radians from seconds
- (setq dradians (/ (* seconds pi) 30.0d0))
- =
- ;; Draw second hand.
- (#_gdk_draw_line
- pixmap black-gc midx midy
- (+ midx (floor (* 0.9d0 radius (sin dradians))))
- (- midy (floor (* 0.9d0 radius (cos dradians)))))
- =
- ;; Get radians from minutes & seconds.
- (setq dradians (+ (/ (* minutes pi) 30.0d0)
- (/ (* seconds pi) 1800.0d0)))
- =
- ;; Draw minute hand.
- (#_gdk_draw_line
- pixmap black-gc midx midy
- (+ midx (floor (* 0.7d0 radius (sin dradians))))
- (- midy (floor (* 0.7d0 radius (cos dradians)))))
- =
- ;; Get radians from hours & minutes.
- (setq dradians (+ (/ (* (mod hours 12) pi) 6.0d0)
- (/ (* minutes pi) 360.0d0)))
- =
- ;; Draw hour hand.
- (#_gdk_draw_line
- pixmap black-gc midx midy
- (+ midx (floor (* 0.5d0 radius (sin dradians))))
- (- midy (floor (* 0.5d0 radius (cos dradians)))))
- =
- ;; Setup the update rectangle; this will force an expose event.
- ;; The expose event handler will then copy the pixmap to the
- ;; window.
- =
- (setf (pref update-rect :<G>dk<R>ectangle.x) 0
- (pref update-rect :<G>dk<R>ectangle.y) 0
- (pref update-rect :<G>dk<R>ectangle.width) area-width
- (pref update-rect :<G>dk<R>ectangle.height) area-height)
- =
- ;; Draw the update rectangle.
- (#_gtk_widget_draw drawing-area update-rect)
- #$TRUE)))))
-
-
-;;; This is called when the window's created and whenever it's
-;;; resized. Create a new pixmap of appropriate
-;;; size; free the old one (if it's non-null).
-(defcallback gtk-clock-configure-event
- (:address widget :address event :address window :signed-fullword)
- (declare (ignore event))
- (let* ((pair (assoc window *gtk-clock-window-pixmaps*)))
- (if (cdr pair)
- (#_gdk_pixmap_unref (cdr pair)))
- =
- (setf (cdr pair)
- (#_gdk_pixmap_new (pref widget :<G>tk<W>idget.window)
- (pref widget :<G>tk<W>idget.allocation.width)
- (pref widget :<G>tk<W>idget.allocation.height)
- -1)))
- #$TRUE)
-
-;;; Copy the window's pixmap to the exposed region of the window.
-(defcallback gtk-clock-expose-event
- (:address widget :address event :address window :signed-fullword)
- (let* ((state (pref widget :<G>tk<W>idget.state))
- (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*)))
- (fg-gc (pref widget :<G>tk<W>idget.style.fg_gc))
- (x (pref event :<G>dk<E>vent<E>xpose.area.x))
- (y (pref event :<G>dk<E>vent<E>xpose.area.y))
- (width (pref event :<G>dk<E>vent<E>xpose.area.width))
- (height (pref event :<G>dk<E>vent<E>xpose.area.height)))
- (#_gdk_draw_pixmap
- (pref widget :<G>tk<W>idget.window)
- (%get-ptr fg-gc (ash state 2))
- pixmap
- x y
- x y
- width height)
- #$FALSE))
-
-;;; When the window's destroyed, delete its entry from the
-;;; *gtk-clock-window-pixmaps* alist.
-
-(defcallback gtk-clock-close (:address window :void)
- (let* ((pair (assoc window *gtk-clock-window-pixmaps*)))
- (if pair
- (setq *gtk-clock-window-pixmaps*
- (delete pair *gtk-clock-window-pixmaps*))
- (break "No entry for window!"))))
-
-(defun gtk-clock ()
- ;; Doesn't hurt to call gtk-init more than once.
- (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL))
- (vbox (#_gtk_vbox_new #$FALSE 0)))
- (push (cons window nil) *gtk-clock-window-pixmaps*)
- (#_gtk_container_add window vbox)
- (#_gtk_widget_show vbox)
- (let* ((drawing-area (#_gtk_drawing_area_new)))
- (#_gtk_drawing_area_size drawing-area 200 200)
- (#_gtk_box_pack_start vbox drawing-area #$TRUE #$TRUE 0)
- (#_gtk_widget_show drawing-area)
- (with-cstrs ((expose-name "expose_event")
- (configure-name "configure_event")
- (destroy-name "destroy")
- (window-title
- "Takes a lickin' and keeps on tickin'."))
- (#_gtk_window_set_title window window-title)
- (#_gtk_signal_connect drawing-area
- expose-name
- gtk-clock-expose-event
- window)
- (#_gtk_signal_connect drawing-area
- configure-name
- gtk-clock-configure-event
- window)
- (#_gtk_signal_connect window
- destroy-name
- gtk-clock-close
- (%null-ptr)))
- (#_gtk_widget_show window)
- (#_gtk_timeout_add 1000 gtk-clock-repaint drawing-area)
- (values))))
-
More information about the Openmcl-cvs-notifications
mailing list