deleted file mode 100644

@@ -1,137 +0,0 @@

-;  Copyright (c) 2014 Edward Langley

-;  All rights reserved.

-

-;  Redistribution and use in source and binary forms, with or without

-;  modification, are permitted provided that the following conditions

-;  are met:

-

-;  Redistributions of source code must retain the above copyright notice,

-;  this list of conditions and the following disclaimer.

-

-;  Redistributions in binary form must reproduce the above copyright

-;  notice, this list of conditions and the following disclaimer in the

-;  documentation and/or other materials provided with the distribution.

-

-;  Neither the name of the project's author nor the names of its

-;  contributors may be used to endorse or promote products derived from

-;  this software without specific prior written permission.

-

-;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

-;  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

-;  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS

-;  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

-;  HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

-;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED

-;  TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR

-;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF

-;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

-;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

-;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-

-(asdf:load-system :cl-cffi-gtk)

-

-(defpackage :gtk-tutorial

-  (:use :gtk :gdk :gdk-pixbuf :gobject

-        :glib :gio :pango :cairo :common-lisp))

-

-(in-package :gtk-tutorial)

-

-;(macroexpand-1 '(on (clicked button) (__)

-;                    (declare (ignore __))

-;                    (format t "Button 1 was pressed")))

-

-(defmacro on ((sig target) bind &body body)

-  "Bind a signal handler: note that this intentionally shadows whatever the 'bind' argument is"

-  `(g-signal-connect ,target ,(string-downcase (symbol-name sig))

-                     (lambda ,bind

-                       ,@body)))

-

-(let ((surface nil))

-  (defun example-drawing ()

-    (within-main-loop

-      (let ((window (make-instance 'gtk-window

-                                   :type :toplevel

-                                   :title "Example Drawing"))

-            (frame (make-instance 'gtk-frame

-                                  :shadow-type :in))

-            (area (make-instance 'gtk-drawing-area

-                                 :width-request 250

-                                 :height-request 200)))

-        (g-signal-connect window "destroy"

-                          (lambda (widget)

-                            (declare (ignore widget))

-                            (leave-gtk-main)))

-        ;; Signals used to handle the backing surface

-        (g-signal-connect area "draw"

-                          (lambda (widget cr)

-                            (declare (ignore widget))

-                            (let ((cr (pointer cr)))

-                              (cairo-set-source-surface cr surface 0.0 0.0)

-                              (cairo-paint cr)

-                              (cairo-destroy cr)

-                              +gdk-event-propagate+)))

-        (g-signal-connect area "configure-event"

-                          (lambda (widget event)

-                            (declare (ignore event))

-                            (when surface

-                              (cairo-surface-destroy surface))

-                            (setf surface

-                                  (gdk-window-create-similar-surface

-                                    (gtk-widget-window widget)

-                                    :color

-                                    (gtk-widget-get-allocated-width widget)

-                                    (gtk-widget-get-allocated-height widget)))

-                            ;; Clear surface

-                            (let ((cr (cairo-create surface)))

-                              (cairo-set-source-rgb cr 1.0 1.0 1.0)

-                              (cairo-paint cr)

-                              (cairo-destroy cr))

-                            (format t "leave event 'configure-event'~%")

-                            +gdk-event-stop+))

-        ;; Event signals

-        (g-signal-connect area "motion-notify-event"

-                          (lambda (widget event)

-                            (format t "MOTION-NOTIFY-EVENT ~A~%" event)

-                            (when (member :button1-mask (gdk-event-motion-state event))

-                              (let ((cr (cairo-create surface))

-                                    (x (gdk-event-motion-x event))

-                                    (y (gdk-event-motion-y event)))

-                                (cairo-rectangle cr (- x 3.0) (- y 3.0) 6.0 6.0)

-                                (cairo-fill cr)

-                                (cairo-destroy cr)

-                                (gtk-widget-queue-draw-area widget

-                                                            (truncate (- x 3.0))

-                                                            (truncate (- y 3.0))

-                                                            6

-                                                            6)))

-                            ;; We have handled the event, stop processing

-                            +gdk-event-stop+))

-        (g-signal-connect area "button-press-event"

-                          (lambda (widget event)

-                            (format t "BUTTON-PRESS-EVENT ~A~%" event)

-                            (if (eql 1 (gdk-event-button-button event))

-                              (let ((cr (cairo-create surface))

-                                    (x (gdk-event-button-x event))

-                                    (y (gdk-event-button-y event)))

-                                (cairo-rectangle cr (- x 3.0) (- y 3.0) 6.0 6.0)

-                                (cairo-fill cr)

-                                (cairo-destroy cr)

-                                (gtk-widget-queue-draw-area widget

-                                                            (truncate (- x 3.0))

-                                                            (truncate (- y 3.0))

-                                                            6

-                                                            6))

-                              ;; Clear surface

-                              (let ((cr (cairo-create surface)))

-                                (cairo-set-source-rgb cr 1.0 1.0 1.0)

-                                (cairo-paint cr)

-                                (cairo-destroy cr)

-                                (gtk-widget-queue-draw widget)))))

-        (gtk-widget-add-events area

-                               '(:button-press-mask

-                                  :pointer-motion-mask))

-        (gtk-container-add frame area)

-        (gtk-container-add window frame)

-        (gtk-widget-show-all window)))))

-

-(example-drawing)