src
Sat Apr 3 19:19:09 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Replace mudballs with ASDF and support the modular Smoke.
Sun May 24 23:29:56 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Work around null pointer for references bug
Fri Apr 17 17:30:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Use C++ style overload resolution.
Tue Apr 14 16:32:06 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* License
Sun Apr 12 15:34:59 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Use overload by argument count for :cxx generic functions
Wed Apr 8 22:56:48 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* make kmandelbrotui.rc validate with kpartgui.dtd
Fri Apr 3 00:16:06 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
diff -rN -u old-kde.examples/src/hello-world.lisp new-kde.examples/src/hello-world.lisp
--- old-kde.examples/src/hello-world.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/hello-world.lisp 2014-10-30 08:41:17.000000000 +0100
@@ -0,0 +1,12 @@
+;;; Copyright 2009 Tobias Rautenkranz
+;;; License: X11 license
+
+(in-package :cl-smoke.kde.examples)
+
+(defun hello-world ()
+ "KDE Hello World"
+ (kde:with-kde ("khelloworld" "Hello World" "0.1")
+ (let* ((window (make-instance 'kde:push-button :args '("Hello world"))))
+ (cxx:show window)
+ (qt:exec))))
+
Binary files old-kde.examples/src/kmandelbrot/kmandelbrot.png and new-kde.examples/src/kmandelbrot/kmandelbrot.png differ
diff -rN -u old-kde.examples/src/kmandelbrot/kmandelbrotui.rc new-kde.examples/src/kmandelbrot/kmandelbrotui.rc
--- old-kde.examples/src/kmandelbrot/kmandelbrotui.rc 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/kmandelbrot/kmandelbrotui.rc 2014-10-30 08:41:17.000000000 +0100
@@ -0,0 +1,29 @@
+<!DOCTYPE kpartgui SYSTEM "kpartgui.dtd">
+<!--
+This file needs to be in one of the paths of:
+$ kde4-config \-\-path data
+in a directory kmandelbrot.
+
+
+The DTD is at:
+http://websvn.kde.org/trunk/KDE/kdelibs/kdeui/xmlgui/kpartgui.dtd?view=log
+!-->
+<kpartgui name="kmandelbrot" version="1">
+<MenuBar>
+<!--
+<Menu name="file" >
+<Action name="view_zoom_in" />
+</Menu>
+!-->
+</MenuBar>
+
+<ToolBar name="mainToolBar" >
+<text>Main Toolbar</text>
+<Action name="view_zoom_in" />
+<!-- You can find the name with:
+(kde:standard-action.name kde:standard-action.+zoom-in+)
+!-->
+<Action name="view_zoom_out" />
+</ToolBar>
+
+</kpartgui>
diff -rN -u old-kde.examples/src/mandelbrot/mandelbrot.lisp new-kde.examples/src/mandelbrot/mandelbrot.lisp
--- old-kde.examples/src/mandelbrot/mandelbrot.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/mandelbrot/mandelbrot.lisp 2014-10-30 08:41:17.000000000 +0100
@@ -0,0 +1,81 @@
+;;; Copyright (C) 2009, 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :cl-smoke.kde.examples)
+
+(defun make-aboutdata ()
+ (let ((app-name "kmandelbrot")
+ (catalog-name "") ;; not (null-pointer) (see smoke::conversion-pointer)
+ (program-name (kde:ki18n "KMandelbrot"))
+ (version "0.0.1")
+ (description (kde:ki18n "KDE Mandelbrot program."))
+ (copyright (kde:ki18n "Copyright (c) 2009 Tobias Rautenkranz"))
+ (text (kde:ki18n "TODO"))
+ (homepage "http://tobias.rautenkranz.ch/lisp/cl-smoke/")
+ (email "bugs@tobias.rautenkranz.ch"))
+ (let ((aboutdata
+ (make-instance 'kde:about-data
+ :args (list
+ app-name catalog-name program-name
+ version description
+ kde:about-data.+license-lgpl-v2+
+ copyright text homepage email))))
+ (cxx:add-author aboutdata
+ (kde:ki18n "Tobias Rautenkranz")
+ (make-instance 'kde:localized-string)
+ "tobias@rautenkranz.ch")
+ aboutdata)))
+
+(defun mandelbrot ()
+ "KDE Mandelbrot example"
+ (kde:with-app (make-aboutdata)
+ (let* ((window (make-instance 'kde:xml-gui-window))
+ (mandelbrot (make-instance 'mandelbrotwidget))
+ (resource-dir
+ (namestring
+ (asdf:component-pathname
+ (asdf:find-component
+ (asdf:find-component (asdf:find-system :cl-smoke.kde.examples)
+ "src")
+ "kmandelbrot")))))
+ (cxx:add-resource-dir (kde:global.dirs)
+ "icon" resource-dir)
+ (cxx:add-resource-dir (kde:global.dirs)
+ "apps" resource-dir)
+ (cxx:quit (find-class 'kde:standard-action)
+ window (qt:qslot "close()")
+ (cxx:action-collection window))
+
+ (kde:make-standard-action kde:standard-action.+redisplay+
+ (cxx:action-collection window)
+ #'(lambda () (zoom mandelbrot 1d0)))
+
+ (kde:make-standard-action kde:standard-action.+zoom-in+
+ (cxx:action-collection window)
+ #'(lambda () (zoom mandelbrot 0.5d0)))
+
+ (kde:make-standard-action kde:standard-action.+zoom-out+
+ (cxx:action-collection window)
+ #'(lambda () (zoom mandelbrot 2d0)))
+
+ (cxx:set-central-widget window mandelbrot)
+ (cxx:set-focus mandelbrot)
+ (setup-slot mandelbrot)
+
+ (cxx:add-resource-dir (kde:global.dirs) "data" resource-dir)
+ (cxx:setup-gui window)
+
+ (cxx:show window)
+ (qt:exec))))
diff -rN -u old-kde.examples/src/mandelbrot/mandelbrotwidget.lisp new-kde.examples/src/mandelbrot/mandelbrotwidget.lisp
--- old-kde.examples/src/mandelbrot/mandelbrotwidget.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/mandelbrot/mandelbrotwidget.lisp 2014-10-30 08:41:17.000000000 +0100
@@ -0,0 +1,171 @@
+;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :cl-smoke.kde.examples)
+
+(defun zoom-in-factor ()
+ 0.8)
+
+(defun zoom-out-factor ()
+ (/ (zoom-in-factor)))
+
+(defclass mandelbrotwidget (qt:widget)
+ ((pixmap :accessor pixmap :initform nil)
+ (pixmap-scale :accessor pixmap-scale)
+ (pixmap-offset :accessor pixmap-offset)
+ (center :accessor center :initform #C(-0.5d0 0d0))
+ (scale :accessor scale :initform 0.007d0)
+ (update-pixmap-slot :accessor update-pixmap-slot)
+ (render :accessor render-thread)
+ (last-drag-pos :accessor last-drag-pos :initform nil))
+ (:metaclass cxx:class))
+
+(defun update-pixmap (mandelbrotwidget image scale)
+ (when (null (last-drag-pos mandelbrotwidget))
+ (setf (pixmap mandelbrotwidget)
+ (qt:pixmap.from-image image))
+ (setf (pixmap-offset mandelbrotwidget) #c(0 0))
+ (setf (pixmap-scale mandelbrotwidget) scale)
+ (cxx:update mandelbrotwidget)))
+
+(defparameter *render-control* (make-instance 'render-control))
+(defun setup-slot (mandelbrotwidget)
+ (setf (update-pixmap-slot mandelbrotwidget)
+ (qt:make-slot #'(lambda (image scale)
+ (update-pixmap mandelbrotwidget image scale))
+ (mapcar #'find-class
+ '(qt:image double-float))))
+ (qt:connect (done-signal *render-control*)
+ (update-pixmap-slot mandelbrotwidget)
+ qt:+queued-connection+))
+
+(defun draw-rendering (painter widget)
+ (cxx:set-pen painter #xFFFFFF) ;; FIXME make qt:+white+ work
+ (cxx:draw-text painter (cxx:rect widget)
+ (value qt:+align-center+)
+ "Rendering initial image, please wait..."))
+
+(defun complex-floor (complex)
+ "Applys FLOOR to the real and imaginary part of COMPLEX."
+ (complex (floor (realpart complex)
+ (imagpart complex))))
+
+(defun draw-scaled-pixmap (painter widget)
+ (cxx:save painter) ;; FIXME make with- macro
+ (let* ((scale-factor (/ (pixmap-scale widget)
+ (scale widget)))
+ (pixmap-size (complex (cxx:width (pixmap widget))
+ (cxx:height (pixmap widget))))
+ (new-size (* scale-factor pixmap-size))
+ (new-center (+ (pixmap-offset widget) (/ (- pixmap-size new-size) 2))))
+ (cxx:translate painter (realpart new-center) (imagpart new-center))
+ (cxx:scale painter scale-factor scale-factor)
+ (let ((exposed (cxx:adjusted (cxx:map-rect (cxx:inverted (cxx:matrix painter))
+ (cxx:rect widget))
+ -1 -1 1 1)))
+ (cxx:draw-pixmap painter exposed (pixmap widget) exposed)))
+ (cxx:restore painter))
+
+
+(defun draw-pixmap (painter widget)
+ (if (= (scale widget) (pixmap-scale widget))
+ (cxx:draw-pixmap painter
+ (floor (realpart (pixmap-offset widget)))
+ (floor (imagpart (pixmap-offset widget)))
+ (pixmap widget))
+ (draw-scaled-pixmap painter widget)))
+
+(defmethod cxx:paint-event ((widget mandelbrotwidget) event)
+ (declare (ignore event))
+ (qt:with-painter (painter widget)
+ (cxx:fill-rect painter (cxx:rect widget)
+ #x000) ;; FIXME qt:+black+
+ (if (null (pixmap widget))
+ (draw-rendering painter widget)
+ (draw-pixmap painter widget))))
+
+(defmethod cxx:resize-event ((widget mandelbrotwidget) event)
+ (declare (ignore event))
+ (when (slot-boundp widget 'render)
+ (setf (stop-p *render-control*) t)
+ (join-thread (slot-value widget 'render)))
+ (queue-image widget))
+
+(defmethod cxx:key-press-event ((widget mandelbrotwidget) event)
+ (enum-cases (cxx:key event)
+ (qt:+key-up+
+ (scroll widget #C(0d0 -5d0)))
+ (qt:+key-down+
+ (scroll widget #C(0d0 5d0)))
+ (qt:+key-left+
+ (scroll widget #C(-5d0 0d0)))
+ (qt:+key-right+
+ (scroll widget #C(5d0 0d0)))
+ (qt:+key-plus+
+ (zoom widget (zoom-in-factor)))
+ (qt:+key-minus+
+ (zoom widget (zoom-out-factor)))))
+
+(defmethod cxx:mouse-press-event ((widget mandelbrotwidget) event)
+ (when (enum= (cxx:button event) qt:+left-button+)
+ (setf (last-drag-pos widget) (complex (cxx:x event)
+ (cxx:y event)))))
+
+(defmethod cxx:wheel-event ((widget mandelbrotwidget) event)
+ (zoom widget (expt (zoom-in-factor) (/ (cxx:delta event) (* 8 15.0)))))
+
+(defmethod cxx:mouse-move-event ((widget mandelbrotwidget) event)
+ (when (and (logand (cxx:buttons event) (value qt:+left-button+))
+ (last-drag-pos widget))
+ (incf (pixmap-offset widget)
+ (- (complex (cxx:x event)
+ (cxx:y event))
+ (last-drag-pos widget)))
+ (setf (last-drag-pos widget) (complex (cxx:x event)
+ (cxx:y event)))
+ (cxx:update widget)))
+
+(defmethod cxx:mouse-release-event ((widget mandelbrotwidget) event)
+ (when (enum= (cxx:button event) qt:+left-button+)
+ (incf (pixmap-offset widget)
+ (- (complex (cxx:x event)
+ (cxx:y event))
+ (last-drag-pos widget)))
+ (setf (last-drag-pos widget) nil)
+ (let ((pixmap-size (complex (cxx:width (pixmap widget))
+ (cxx:height (pixmap widget))))
+ (size (complex (cxx:width widget)
+ (cxx:height widget))))
+ (scroll widget (- (/ (- size pixmap-size) 2) (pixmap-offset widget))))))
+
+(defun queue-image (widget)
+ (setf (stop-p *render-control*) nil)
+ ;; FIXME do not creating a new thread on every invokation
+ (setf (render-thread widget)
+ (make-thread (make-render-function (center widget)
+ (scale widget)
+ (cxx:width widget)
+ (cxx:height widget)
+ *render-control*))))
+
+(defun zoom (widget factor)
+ (setf (scale widget) (* (scale widget) factor))
+ (cxx:update widget)
+ (queue-image widget))
+
+(defun scroll (widget delta)
+ (incf (center widget) (* (scale widget) delta))
+ (cxx:update widget)
+ (queue-image widget))
diff -rN -u old-kde.examples/src/mandelbrot/render.lisp new-kde.examples/src/mandelbrot/render.lisp
--- old-kde.examples/src/mandelbrot/render.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/mandelbrot/render.lisp 2014-10-30 08:41:17.000000000 +0100
@@ -0,0 +1,110 @@
+;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;; Copyright (C) 2009 Nokia Corporation and/or its subsidiary(-ies).
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :cl-smoke.kde.examples)
+
+(defun make-image (width height)
+ (make-instance 'qt:image :args (list width height
+ qt:image.+format-rgb32+)))
+
+(declaim (inline z_0))
+(defun z_0 ()
+ #C(0d0 0d0))
+
+(declaim (inline z_n+1))
+(defun z_n+1 (z_n c)
+ (+ (expt z_n 2) c))
+
+(declaim (inline make-complex))
+(defun make-complex (realpart imagpart)
+ (+ (float realpart 0d0) (* imagpart #C(0d0 1d0))))
+
+
+(defun diverge-p (c iterations)
+ (declare (type (complex double-float) c)
+ (type fixnum iterations)
+ (optimize (speed 3) (debug 3) (safety 3)))
+ (let ((z (z_0)))
+ (declare (type (complex double-float) z))
+ (dotimes (n iterations nil)
+ (setf z (z_n+1 z c))
+ (when (> (+ (expt (realpart z) 2) (expt (imagpart z) 2)) 4)
+ (return n)))))
+
+
+(declaim (inline div-to-color))
+(defun div-to-color (n iterations)
+ (declare (type fixnum n iterations))
+ (let ((grey (- #xFF (min #xFF n))))
+ (+ #xFF000000
+ (* #x010000 grey)
+ (* #x000100 grey)
+ (* #x000001 grey))))
+
+(defclass render-control ()
+ ((done-signal :initform (qt:make-signal (find-class 'qt:image)
+ (find-class 'double-float))
+ :reader done-signal
+ :documentation "Signals that an image is ready.")
+ (mutex :initform (sb-thread:make-mutex)
+ :accessor mutex)
+ (stop-p :initform nil)))
+
+(defun stop-p (render-control)
+ (sb-thread:with-mutex ((mutex render-control))
+ (slot-value render-control 'stop-p)))
+
+(defmacro if-stop-p (render-control then else)
+ `(sb-thread:with-mutex ((mutex ,render-control))
+ (if (slot-value ,render-control 'stop-p)
+ ,then
+ ,else)))
+
+(defun (setf stop-p) (new-value control)
+ (sb-thread:with-mutex ((mutex control))
+ (setf (slot-value control 'stop-p)
+ new-value)))
+
+;;;a : x width
+;;;b : y height
+(defun render (center scale width height control)
+ (declare (fixnum width height)
+ (type (complex double-float) center)
+ (double-float scale)
+ (optimize (speed 3)))
+ (let ((image (make-image width height))
+ (top-left (- (/ (complex width height) 2))))
+ (dotimes (pass 1)
+ (let ((iterations 200)) ;(+ (expt 2 (+ (* 2 pass) 6)) 32)))
+ (dotimes (y height)
+ (when (stop-p control)
+ (return))
+ (let ((scanline (cxx:scan-line image y)))
+ (dotimes (x width)
+ (let ((diverge (diverge-p (+ (* scale (+ top-left (make-complex x y))) center) iterations)))
+ (if diverge
+ (setf (cffi:mem-ref scanline :unsigned-int)
+ (div-to-color diverge iterations))
+ (setf (cffi:mem-ref scanline :unsigned-int)
+ #.(qt:q-rgb 0 0 0))))
+ (cffi:incf-pointer scanline
+ (cffi:foreign-type-size :unsigned-int))))))
+ (if-stop-p control
+ (return)
+ (funcall (done-signal control) image scale)))))
+
+(defun make-render-function (center scale width height done-signal)
+ #'(lambda () (render center scale width height done-signal)))
diff -rN -u old-kde.examples/src/package.lisp new-kde.examples/src/package.lisp
--- old-kde.examples/src/package.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-kde.examples/src/package.lisp 2014-10-30 08:41:17.000000000 +0100
@@ -0,0 +1,39 @@
+;;; Copyright 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use,
+;;; copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following
+;;; conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;; OTHER DEALINGS IN THE SOFTWARE.
+
+(defpackage :cl-smoke.kde.examples
+ (:use #:cl :bordeaux-threads #:cxx-support)
+ (:nicknames :kde.examples)
+ (:export #:hello-world
+ #:mandelbrot))
+
+(in-package :cl-smoke.kde.examples)
+
+(defun test-all ()
+ (let ((qt:*exec-p* nil))
+ (do-external-symbols (example :cl-smoke.kde.examples)
+ (when (fboundp example)
+ (format *debug-io* "testing ~A~%"
+ (documentation (symbol-function example)
+ 'function))
+ (funcall (symbol-function example))))))