Регистрация | Войти
Lisp — программируемый язык программирования
roller.lisp
Автор: motopeh - 2016-05-03T19:18:36.000000+03:00
(in-package :cl-user)


(ql:quickload '("cl-cairo2" "cl-gobject-introspection"))

(cl:defpackage #:gir-test
  (:use #:cl)
)

(in-package #:gir-test)

(defvar *gtk* (gir:require-namespace "Gtk"))
(defvar *gdk* (gir:require-namespace "Gdk"))

(defparameter *angle* (/ pi 2))
(defvar *center*)
(defvar *start-angle*)

(defun draw-roller-in-cairo-context (c)
  (let* ((h  (cairo:height c))
         (w (cairo:width c))
         (size (min h w))
         (xc (/ w 2.0))
         (yc (/ h 2.0))
         (radius (* 0.45 size))
)

    (setf *center* (list xc yc))
    (cairo:with-context (c)
      (cairo:set-source-rgb 1 1 1)
      (cairo:paint)
      
      (cairo:set-source-rgba 1 0.2 0.2 0.6)
      (cairo:set-line-width 6.0)
      (cairo:arc xc yc 10.0 0 (* 2.0 pi))
      (cairo:fill-path)
      (cairo:stroke)

      (cairo:set-source-rgb 0 0 0)
      (cairo:set-line-width 6.0)
      (cairo:arc xc yc radius 0 (* 2 pi))
      
      (let ((c (cos *angle*))
            (s (sin *angle*))
            (r1 (* 0.96 radius))
            (r2 (* 1.08 radius))
)

        (cairo:move-to (+ xc (* r1 c))
                       (- yc (* r1 s))
)

        (cairo:line-to (+ xc (* r2 c))
                       (- yc (* r2 s))
)
)


      ;; (cairo:show-text-a )
     ;; (cairo:select-font-face "DejaVu Sans Mono" :normal :normal)
     ;; (cairo:set-font-size 25)
     (cairo:stroke)
)
)
)


(defun register-events (obj
                        event-masks
)

  (gir:invoke
   (obj 'set-events)
   (let ((e (gir:nget *gdk* "EventMask")))
     (reduce (lambda (s m)
               (boole boole-ior
                      s
                      (funcall e m)
)
)

             (rest event-masks)
             :initial-value (funcall e (first event-masks))
)
)
)
)


(defun square (x)
  (* x x)
)


(defun calc-angle (event)
  (when *center*
    (destructuring-bind (x y)
        (mapcar #'-
                (list (gir:field event "x")
                      (gir:field event "y")
)

                *center*
)

      (let ((a (acos (/ x
                        (sqrt (+ (square x)
                                 (square y)
)
)
)
)
)
)

        (if (< y 0)
            a
            (- a)
)
)
)
)
)


(defun handle-rotation-event (drawing-area ev)
  (setf *angle*
        (+ (calc-angle ev)
           *start-angle*
)
)

  (gir:invoke (drawing-area :queue-draw))
)


(defun handle-button-press-event (drawing-area ev)
  (declare (ignorable drawing-area ev))
  (setf *start-angle*
        (- *angle*
           (calc-angle ev)
)
)
)


(defun roller-window ()
  (gir:invoke (*gtk* 'init) nil)
  (let ((window (gir:invoke (*gtk* "Window" 'new)
                            (gir:nget *gtk* "WindowType" :toplevel)
)
)

        (drawing-area (gir:invoke (*gtk* "DrawingArea" 'new)))
)

    (setf (gir:property window 'title) "Roller")
    (gir:connect window :destroy
                 (lambda (win)
                   (declare (ignore win))
                   (gir:invoke (*gtk* 'main-quit))
)
)

    (gir:connect drawing-area :draw
                 (lambda (drawing-area c)
                   (let* ((h (gir:invoke (drawing-area "get_allocated_height")))
                          (w (gir:invoke (drawing-area "get_allocated_width")))
                          (context (make-instance 'cairo:context
                                                  :pointer c
                                                  :height h
                                                  :width w
)
)
)

                     (draw-roller-in-cairo-context context)
)
)
)

    (macrolet (($connect-handler (event event-type handler)
                 `(gir:connect drawing-area ,event
                               (let ((event-class (gir:nget *gdk* ,event-type)))
                                 (lambda (drawing-area ev)
                                   (,handler drawing-area
                                             (gir::build-struct-ptr event-class
                                                                    ev
)
)
)
)
)
)
)

      ($connect-handler :button-press-event
                        "EventButton"
                        handle-button-press-event
)

      ($connect-handler :motion-notify-event
                        "EventMotion"
                        handle-rotation-event
)
)

    (register-events drawing-area
                     '(:button1-motion-mask
                       :button-press-mask
                       :button-release-mask
)
)

    (gir:invoke (window 'add) drawing-area)
    (gir:invoke (window 'show-all))
    (gir:invoke (*gtk* 'main))
)
)

@2009-2013 lisper.ru