[cells-gtk-devel] can't run testprogram

[Martin Kielhorn]

2008/10/27 Peter Hildebrandt <peter.hildebrandt at gmail.com>

>
> Lemme know if I can help.


Right now I figure out if it is feasible to control a microscope with cells.
In the end I would capture from a camera, move the focus, change
objectives...

But for the beginning I just try to create something similar to baudline (
http://www.baudline.com/).
Just capture sound, fft and display in an opengl texture. That should be
easier as there is not as
much hardware involved.

What I've come up with is the following code. And I have several questions:

1) Can how somehow prevent the introduction of the extra defmodel graphics
with the
    cell rotation and just connect my the hscale value to the gl-rotate?

2) What's the best way to continuously call the draw function in graphics,
so that the
    display gets updated with 30 Hz? I searched the graphics instance with
(inspect *win*)
    but I didn't find it. Otherwise I could have called (redraw (graphics
(vbox *win*))) from an endless
    loop in another thread.

Ideally I want to have the application running in several threads. One
thread should capture sound and fill it in a queue.
That should be easy in sbcl:
http://www.sbcl.org/manual/Waitqueue_002fcondition-variables.html#Waitqueue_002fcondition-variables
when 2) is solved.

remark:
I think :resize isn't called when my program starts. (In early versions of
my program it was called. I don't know what
change introduced this bug)

(require :asdf)
(require :cells-gtk)
(require :sb-simple-audio)

(defpackage :martin (:use :cl :cgtk :cells))

(in-package :martin)

(defparameter *tex* #x0)
(defparameter *field* (cffi:make-shareable-byte-vector (* 256 256 3)))
(defparameter *sound-buf-n* 1024)
(defparameter *sound-buf* (make-array *sound-buf-n*))
(defparameter *sound-stream* (sb-simple-audio:open-audio :sample-rate 8000
                             :direction :input))


(defun plot (x y r g b)
  (setf (aref *field* (+ 0 (* 3 (+ x (* 256 y))))) r)
  (setf (aref *field* (+ 1 (* 3 (+ x (* 256 y))))) g)
  (setf (aref *field* (+ 2 (* 3 (+ x (* 256 y))))) b))

(defmodel graphics (gl-drawing-area)
  ((rotation :cell t :initarg :rotation :initform 0 :accessor rotation))
  (:default-initargs
      :expand t :fill t
      :init #'(lambda (self)
        ;;(declare (ignorable self))
        (loop for i below 256 do
              (loop for j below 256 do
                (plot i j i j 0)))
        (setf *tex* (first (gl:gen-textures 1)))
        (gl:bind-texture :texture-2d *tex*)
        (gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
        (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
        (cffi::with-pointer-to-vector-data (addr *field*)
          (gl:tex-image-2d :texture-2d 0 :rgba 256 256 0 :rgb
                   :unsigned-byte addr)))
      :resize #'(lambda (self)
          (format t "RESIZE~%")
          (with-matrix-mode (:projection)
            (glu:perspective 50 (/ (allocated-width self)
                       (allocated-height self))
                     .5 20)))
      :draw #'(lambda (self)
        (declare (ignorable self))
        (gl:clear :color-buffer-bit)
        (gl:load-identity)
                    ;(gl:translate 0 0 -5)
        (gl:rotate (* 360 (rotation self)) 0 0 1)
        (gl:color 1 1 1)
        (gl:enable :texture-2d)
        (gl:with-primitive :quads
          (gl:tex-coord 0 0)(gl:vertex 0 0)
          (gl:tex-coord 1 0)(gl:vertex 1 0)
          (gl:tex-coord 1 1)(gl:vertex 1 1)
          (gl:tex-coord 0 1)(gl:vertex 0 1))
        (read-sequence *sound-buf* *sound-stream*)
        ;;(format t "~a~%" *sound-buf*)
        (gl:disable :texture-2d)
        (gl:with-primitive :points
          (loop for i below *sound-buf-n* do
            (gl:vertex (/ i *sound-buf-n*)
                   (/ (aref *sound-buf* i) 5000))))
        (gl:flush))))


(defobserver rotation ((self graphics))
  (redraw self))

(defmodel my-app (gtk-app)
  ()
  (:default-initargs :title "minimal gl control test"
    :position :center :width 500 :height 380
    :kids
    (kids-list? (mk-vbox :kids
             (kids-list?
              (mk-hscale :md-name :scale :value-type 'single-float
                     :min .01 :max 1. :step .01 :init .5)
              (make-kid 'graphics :md-name :graphics
                    :height 300
                    :rotation (c? (widget-value :scale))))))))

(cells-gtk-init)

;(defparameter *win* (start-win 'my-app))

(start-app 'my-app)

(*
(inspect *win*)
(sb-thread:list-all-threads)
(make-thread (lambda () (write-line "test")))
*)
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cells-gtk-devel/attachments/20081030/8dd25788/attachment.html>