Re: Subclasses

Espen S Johnsen <[email protected]> writes:

> I found an article¹ about writing custom widgets in Pyton and decided to
> write the example in Lisp. It is not very advanced, but it could easily
> be extended to do something more useful. The next article is promised to
> do that. Anyway here is the example (it requires the latest code which
> may not propagate into anonymous CVS until a few hours²):

Sorry, that was the wrong code. Here is a working example:

(defclass egg-clock-face (drawing-area)
  ()
  (:metaclass gobject-class))

(define-signal-handler expose-event ((clock egg-clock-face) event)
  (let ((cr (gdk:cairo-create (widget-window clock))))
    (with-slots (gdk:x gdk:y gdk:width gdk:height) event
      (cairo:rectangle cr gdk:x gdk:y gdk:width gdk:height))
    (cairo:clip cr)
    
    (multiple-value-bind (width height) (widget-get-size-allocation clock)
      (let* ((x (/ width 2))
             (y (/ height 2))
             (radius (- (min (/ width 2) (/ height 2)) 5)))

        (cairo:circle cr x y radius)
        (cairo:set-source-color cr 1.0 1.0 1.0)
        (cairo:fill cr t)
        (cairo:set-source-color cr 0 0 0)
        (cairo:stroke cr)

        (loop
         for tick from 0 below 12
         do (cairo:with-context (cr)
              (let ((inset (if (zerop (mod tick 3))
                               (* 0.2 radius)
                             (progn
                               (setf 
                                (cairo:line-width cr) 
                                (* 0.5 (cairo:line-width cr)))
                               (* 0.1 radius)))))
                
                (cairo:move-to cr 
                 (+ x (* (- radius inset) (cos (* tick (/ pi 6)))))
                 (+ y (* (- radius inset) (sin (* tick (/ pi 6))))))
                (cairo:line-to cr 
                 (+ x (* radius (cos (* tick (/ pi 6)))))
                 (+ y (* radius (sin (* tick (/ pi 6))))))
                (cairo:stroke cr)))))))
  nil)


#+sbcl(sb-int:set-floating-point-modes :traps nil) 
#+cmu(ext:set-floating-point-modes :traps nil)

(make-instance 'window 
 :child (make-instance 'egg-clock-face :visible t)
 :visible t)

-- 
Espen


-------------------------------------------------------
This SF.net email is sponsored by: Splunk Inc. Do you grep through log files
for problems?  Stop!  Download the new AJAX search engine that makes
searching your log files as easy as surfing the  web.  DOWNLOAD SPLUNK!
http://sel.as-us.falkag.net/sel?cmd=lnk&kid3432&bid#0486&dat1642