Simple QtWebKit Bridge Demo
+-
+
-
+
Call Lisp function, passing a Date and an Array
+ + -
+
Change value in Lisp (passing a QWebElement)
+ + + -
+
Eval in Lisp
+ + -
+
Set Qt Property of this QWebView
+ + + -
+
Call Qt Slot of this QWebView
+ +
+
See also Web Inspector + Scripts and Console: +
+
+ Script debugging, introspecting web elements / functions and properties of exposed objects
+
(type Lisp and see drop down of QtRuntimeObject)
+
+
+ Delete exposed Lisp + object (examples 1 to 3 will stop working) +
+ + diff --git a/examples/M-modules/webkit/webkit-bridge.lisp b/examples/M-modules/webkit/webkit-bridge.lisp new file mode 100644 index 0000000..40704c8 --- /dev/null +++ b/examples/M-modules/webkit/webkit-bridge.lisp @@ -0,0 +1,77 @@ +;;; Simple QtWebKit Bridge Demo +;;; +;;; depends on small plugin, see "lib/" + +#-qt-wrapper-functions ; see README-OPTIONAL.txt +(load (in-home "src/lisp/all-wrappers")) + +#+win32 (si:trap-fpe 'floating-point-underflow nil) ; for QWebInspector + +(qrequire :webkit) + +(load "inspector") + +(defvar *web-view* (qnew "QWebView" "size" '(700 550))) + +(defvar eql-user::*webkit-bridge* (qload-c++ "lib/webkit_bridge")) ; eval once only, even from other package (see CLONE) +(defvar eql-user::*clone-count* 0) ; (see above) + +(defun frame () + (|mainFrame| (|page| *web-view*))) + +(defun ini () + (qconnect (frame) "javaScriptWindowObjectCleared()" + (lambda () + (|addToJavaScriptWindowObject| (frame) "Lisp" eql-user::*webkit-bridge*) ; for examples 1, 2, 3 + (|addToJavaScriptWindowObject| (frame) "WebView" *web-view*))) ; for examples 4, 5 + (|setUrl| *web-view* (qnew "QUrl(QString)" + (x:cc "file://" (namestring (probe-file "webkit-bridge.htm"))))) + (when (find "debug" (|arguments.QCoreApplication|) :test 'string=) + (inspector)) + (|show| *web-view*)) + +;;; clone me + +(defvar *clone-name* #.(format nil "CLONE-~D" (incf eql-user::*clone-count*))) + +(defun clone () + (make-package #.*clone-name*) + (in-package #.*clone-name*) + (use-package :eql) + (load "webkit-bridge") + (|setWindowTitle| (symbol-value (find-symbol "*WEB-VIEW*" #.*clone-name*)) + #.*clone-name*) + "(clone)") + +;;; These functions can be called from JavaScript (see "README-GLUE-CODE.txt") + +(defun test-call (now arguments) + "Qt: QStringList testCall(QDateTime, QVariantList = 0)" + ;; | from C++ to + ;; ----------|-------------------------------------------------------- + ;; arguments | JS array of vars -> QVariantList -> LIST + ;; return | LIST of strings -> QStringList -> JS array of strings + ;; + (qmsg (cons now arguments)) + (mapcar (lambda (arg) + (if (qt-object-p arg) + (|toString| arg) + (princ-to-string arg))) + (cons now arguments))) + +(defun eval* (expression) + "Qt: QString eval(QString)" + (handler-case (princ-to-string (eval (read-from-string expression))) + (error (condition) + (qmsg (format nil "Lisp Eval Error
~A
" + (qescape (princ-to-string condition)))) + expression))) + +(defun flip-value (web-element) + "Qt: void flipValue(QWebElement)" + ;; indirection fun: a 'value' of an element can only be changed through JavaScript + (flet ((js (code) + (|toString| (|evaluateJavaScript| web-element code)))) + (js (format nil "this.value = ~S" (reverse (js "this.value")))))) + +(ini) diff --git a/examples/X-extras/CLOS-encapsulation.lisp b/examples/X-extras/CLOS-encapsulation.lisp new file mode 100644 index 0000000..d505637 --- /dev/null +++ b/examples/X-extras/CLOS-encapsulation.lisp @@ -0,0 +1,45 @@ +#-qt-wrapper-functions ; see README-OPTIONAL.txt +(load (in-home "src/lisp/all-wrappers")) + +(in-package :eql-user) + +;; define class or struct + +(defclass my-label-1 () + ((label :initform (qnew "QLabel" "objectName" "label_1")))) + +(defstruct my-label-2 + (label (qnew "QLabel" "objectName" "label_2"))) + +;; specialize THE-QT-OBJECT + +(defmethod the-qt-object ((object my-label-1)) + (slot-value object 'label)) + +(defmethod the-qt-object ((object my-label-2)) + (my-label-2-label object)) + +;;; The Lisp objects can now be used the same as QT-OBJECT, +;;; that is: they can be passed as arguments to any EQL function + +(defvar *label-1* (make-instance 'my-label-1)) +(defvar *label-2* (make-my-label-2)) +(defvar *label-3* (qnew "QLabel" "objectName" "label_3")) + +(defun run () + (let* ((dialog (qnew "QDialog")) + (layout (qnew "QVBoxLayout(QWidget*)" dialog))) + (x:do-with (|addWidget| layout) + *label-1* *label-2* *label-3*) + (flet ((print-me (label color) + (|setText| (symbol-value label) (format nil "~A ... ~A"
+ color
+ label
+ (qescape (princ-to-string (symbol-value label)))))))
+ (qset-color dialog |QPalette.Window| "white")
+ (print-me '*label-1* "red")
+ (print-me '*label-2* "green")
+ (print-me '*label-3* "blue"))
+ (x:do-with dialog |show| |raise|)))
+
+(run)
diff --git a/examples/X-extras/calculator.lisp b/examples/X-extras/calculator.lisp
new file mode 100644
index 0000000..8d6f4cf
--- /dev/null
+++ b/examples/X-extras/calculator.lisp
@@ -0,0 +1,227 @@
+;;; A simple calculator
+;;;
+;;; - displays exact value + float value
+;;; - runs visual automations
+
+#-qt-wrapper-functions ; see README-OPTIONAL.txt
+(load (in-home "src/lisp/all-wrappers"))
+
+(defpackage :calculator
+ (:nicknames :clc)
+ (:use :common-lisp :eql)
+ (:export
+ #:*main*
+ #:auto
+ #:run))
+
+(in-package :calculator)
+
+(defvar *main* (qnew "QDialog"))
+(defvar *real* (qnew "QLabel"
+ "frameShape" |QFrame.Box|))
+(defvar *float* (qnew "QLineEdit"
+ "readOnly" t
+ "font" (x:let-it (|font.QApplication|)
+ (|setPointSize| x:it (+ 6 (|pointSize| x:it))))))
+
+(defvar *precision* 0f0) ; f = float, d = double, l = long
+(defvar *value1* nil)
+(defvar *value2* nil)
+(defvar *reset* nil)
+(defvar *operation*)
+(defvar *decimals*)
+
+(defun error-to-string (err)
+ (let ((err (string-trim "#" (write-to-string err :case :downcase))))
+ (subseq err 0 (position #\# err))))
+
+(defun funcall-protect (fun &rest args)
+ (multiple-value-bind (val err)
+ (ignore-errors (apply fun args))
+ (or val
+ (progn
+ (|critical.QMessageBox| nil "Error" (error-to-string err))
+ 0))))
+
+(defun display-number (n)
+ (flet ((str (x)
+ (format nil "~:D" x)))
+ (x:when-it (funcall-protect (lambda (x) (float x *precision*)) n)
+ (|setText| *float* (princ-to-string x:it)))
+ (let* ((num (str (numerator n)))
+ (den (str (denominator n)))
+ (dif (- (length den) (length num))))
+ (|setText| *real* (format nil "~A~A
~A" (if (plusp dif) (make-string dif) "") num den))
+ (|setEnabled| (qfind-child *main* "blah") (= 1 (denominator n))))))
+
+(defun clear-display ()
+ (setf *value1* 0
+ *decimals* nil)
+ (display-number 0))
+
+(defun words-clicked ()
+ (qmsg (format nil "~R" *value1*)))
+
+(defun digit-clicked ()
+ (when *reset*
+ (clear-display)
+ (setf *reset* nil))
+ (let ((clicked (parse-integer (|text| (qsender)))))
+ (setf *value1* (if *decimals*
+ (+ (* clicked (expt 10 (- (incf *decimals*))))
+ *value1*)
+ (+ clicked
+ (* 10 *value1*)))))
+ (display-number *value1*))
+
+(defun back-clicked ()
+ (when (and *decimals* (zerop *decimals*))
+ (setf *decimals* nil))
+ (setf *value1* (if *decimals*
+ (let ((n (expt 10 (decf *decimals*))))
+ (/ (truncate (* n *value1*)) n))
+ (truncate (/ *value1* 10))))
+ (display-number *value1*))
+
+(defun invert (operation)
+ (setf *value1* (funcall-protect operation *value1*))
+ (display-number *value1*))
+
+(defun sign-clicked ()
+ (invert '-))
+
+(defun reci-clicked ()
+ (invert '/))
+
+(defun point-clicked ()
+ (setf *decimals* 0))
+
+(defun clear-clicked ()
+ (setf *value2* nil)
+ (clear-display)
+ (|adjustSize| *main*))
+
+(defun operate ()
+ (x:when-it (funcall-protect *operation* *value2* *value1*)
+ (setf *value2* x:it)
+ (display-number *value2*)))
+
+(defun operation-clicked ()
+ (if *value2*
+ (operate)
+ (setf *value2* *value1*))
+ (setf *operation* (intern (|text| (qsender)))
+ *reset* t))
+
+(defun equal-clicked ()
+ (when *value2*
+ (operate)
+ (shiftf *value1* *value2* nil)
+ (setf *reset* t)))
+
+;;; UI
+
+(defun run ()
+ (flet ((b ()
+ (qnew "QToolButton"
+ "minimumSize" '(35 25)
+ "sizePolicy" #.(qnew "QSizePolicy(QSizePolicy::Policy,QSizePolicy::Policy)"
+ |QSizePolicy.Expanding| |QSizePolicy.Expanding|))))
+ (let* ((layout* (|layout| *main*))
+ (layout (if (qnull layout*) ; for multiple call of RUN
+ (qnew "QGridLayout(QWidget*)" *main*)
+ (qt-object-? layout*)))
+ (digits (make-array 10))
+ (plus (b)) (minus (b)) (multiply (b)) (divide (b)) (reci (b)) (sign (b))
+ (point (b)) (clear (b)) (back (b)) (words (b)) (equal (b)))
+ (dotimes (n 10)
+ (setf (svref digits n) (b)))
+ (x:do-with (|addWidget| layout)
+ (reci 2 0)
+ (divide 2 1)
+ (multiply 2 2)
+ (minus 2 3)
+ (clear 2 4)
+ (back 3 4)
+ (words 4 4)
+ (sign 5 3)
+ (point 6 3)
+ (*real* 0 0 1 5)
+ (*float* 1 0 1 5)
+ (plus 3 3 2 1)
+ (equal 5 4 2 1)
+ ((svref digits 0) 6 0 1 3))
+ (let ((n 0))
+ (dotimes (r 3)
+ (dotimes (c 3)
+ (|addWidget| layout (svref digits (incf n)) (- 5 r) c))))
+ (dolist (btn (list (list plus "+")
+ (list minus "-")
+ (list multiply "*")
+ (list divide "/")
+ (list reci "1/x" "R")
+ (list sign "+-" "S")
+ (list point ".")
+ (list clear "AC" "Delete")
+ (list back "<<" "Backspace")
+ (list words "blah" "B")
+ (list equal "=" "Return")))
+ (let ((w (first btn))
+ (s (second btn)))
+ (x:do-with (qset w)
+ ("text" s)
+ ("objectName" s)
+ ("shortcut" (qnew "QKeySequence(QString)" (or (third btn) s))))))
+ (dotimes (n 10)
+ (let ((w (svref digits n))
+ (s (princ-to-string n)))
+ (x:do-with (qset w)
+ ("text" s)
+ ("objectName" s)
+ ("shortcut" (qnew "QKeySequence(QString)" s)))))
+ (dolist (w (list *float* *real*))
+ (|setAlignment| w |Qt.AlignRight|))
+ (dotimes (n 10)
+ (qconnect (svref digits n) "clicked()" 'digit-clicked))
+ (dolist (w (list plus minus multiply divide))
+ (qconnect w "clicked()" 'operation-clicked))
+ (mapc (lambda (w fun)
+ (qconnect w "clicked()" fun))
+ (list clear back sign point reci words equal)
+ (list 'clear-clicked 'back-clicked 'sign-clicked 'point-clicked 'reci-clicked 'words-clicked 'equal-clicked))
+ (clear-display)
+ (|setFocus| *real*)
+ (x:do-with *main* |show| |raise|))))
+
+(run)
+
+;;; visual automation
+
+(defun prepare (buttons)
+ (flet ((normalize (string)
+ (string-trim " " (with-output-to-string (s)
+ (x:do-string (ch string)
+ (unless (char= #\Space ch)
+ (format s "~C " ch)))))))
+ (let ((buttons* (normalize buttons)))
+ (dolist (name (sort (mapcar (lambda (o) (|objectName| o))
+ (qfind-children *main* nil "QToolButton"))
+ '> :key 'length))
+ (setf buttons* (x:string-substitute name (normalize name) buttons*)))
+ (x:split buttons*))))
+
+(defun auto (buttons &optional (milliseconds 400))
+ "Run visually the passed BUTTONS (either one string or a list of button strings)."
+ (when (stringp buttons)
+ (setf buttons (prepare buttons)))
+ (when buttons
+ (|animateClick| (qfind-child *main* (first buttons)) milliseconds)
+ (qsingle-shot (* 2 milliseconds) (lambda () (auto (rest buttons) milliseconds)))))
+
+;;; example / eql calculator -a
+
+(defun qarg (argument)
+ (find argument (|arguments.QCoreApplication|) :test 'string=))
+
+(when (qarg "-a")
+ (auto "AC 1.25 + 3.75 = *= *= 1/x 1/x +- blah"))
diff --git a/examples/X-extras/cpp-move-blocks/lib.cpp b/examples/X-extras/cpp-move-blocks/lib.cpp
new file mode 100644
index 0000000..2210f6c
--- /dev/null
+++ b/examples/X-extras/cpp-move-blocks/lib.cpp
@@ -0,0 +1,24 @@
+#include "lib.h"
+#include "eql_fun.h"
+
+QT_BEGIN_NAMESPACE
+
+static qreal easingFunction(qreal progress) {
+ // see "../move-blocks.lisp"
+ return eql_fun("eql-user::custom-easing-function", QVariant::Double,
+ Q_ARG(qreal, progress)).toDouble(); }
+
+QEasingCurve* CPP::easingCurve() {
+ static QEasingCurve* curve = 0;
+ if(!curve) {
+ curve = new QEasingCurve(QEasingCurve::Custom);
+ curve->setCustomType(easingFunction); }
+ return curve; }
+
+QObject* ini() {
+ static CPP* cpp = 0;
+ if(!cpp) {
+ cpp = new CPP; }
+ return cpp; }
+
+QT_END_NAMESPACE
diff --git a/examples/X-extras/cpp-move-blocks/lib.h b/examples/X-extras/cpp-move-blocks/lib.h
new file mode 100644
index 0000000..36a0299
--- /dev/null
+++ b/examples/X-extras/cpp-move-blocks/lib.h
@@ -0,0 +1,25 @@
+#ifndef LIB_H
+#define LIB_H
+
+#include
+
+#ifdef Q_WS_WIN
+#define LIB_EXPORT __declspec(dllexport)
+#else
+#define LIB_EXPORT
+#endif
+
+QT_BEGIN_NAMESPACE
+
+extern "C" { LIB_EXPORT QObject* ini(); }
+
+class CPP : public QObject {
+ Q_OBJECT
+public:
+
+ Q_INVOKABLE QEasingCurve* easingCurve();
+};
+
+QT_END_NAMESPACE
+
+#endif
diff --git a/examples/X-extras/cpp-move-blocks/lib.pro b/examples/X-extras/cpp-move-blocks/lib.pro
new file mode 100644
index 0000000..b72a00c
--- /dev/null
+++ b/examples/X-extras/cpp-move-blocks/lib.pro
@@ -0,0 +1,13 @@
+TEMPLATE = lib
+CONFIG += plugin release
+INCLUDEPATH += ../../../src
+LIBS += -L../../.. -leql5
+DESTDIR = ./
+TARGET = easing_curve
+OBJECTS_DIR = ./tmp/
+MOC_DIR = ./tmp/
+
+include(../../../src/windows.pri)
+
+HEADERS += lib.h
+SOURCES += lib.cpp
diff --git a/examples/X-extras/cpp-qimage/lib.cpp b/examples/X-extras/cpp-qimage/lib.cpp
new file mode 100644
index 0000000..17cbe6f
--- /dev/null
+++ b/examples/X-extras/cpp-qimage/lib.cpp
@@ -0,0 +1,31 @@
+#include "lib.h"
+
+QT_BEGIN_NAMESPACE
+
+QObject* ini() {
+ static CPP* cpp = 0;
+ if(!cpp) {
+ cpp = new CPP; }
+ return cpp; }
+
+static void _toGrayscale(QImage* image) {
+ if(image) {
+ // stolen from Stack Overflow
+ for(int y = 0; y < image->height(); y++) {
+ uchar* scan = image->scanLine(y);
+ int depth = 4;
+ for(int x = 0; x < image->width(); x++) {
+ QRgb* rgbpixel = reinterpret_cast(scan + x * depth);
+ int gray = qGray(*rgbpixel);
+ *rgbpixel = QColor(gray, gray, gray).rgba(); }}}}
+
+QImage CPP::toGrayscale(const QImage& image) {
+ QImage image2 = image;
+ image2.detach();
+ _toGrayscale(&image2);
+ return image2; }
+
+void CPP::toGrayscaleReplace(QImage* image) {
+ _toGrayscale(image); }
+
+QT_END_NAMESPACE
diff --git a/examples/X-extras/cpp-qimage/lib.h b/examples/X-extras/cpp-qimage/lib.h
new file mode 100644
index 0000000..e33add9
--- /dev/null
+++ b/examples/X-extras/cpp-qimage/lib.h
@@ -0,0 +1,26 @@
+#ifndef LIB_H
+#define LIB_H
+
+#include
+
+#ifdef Q_WS_WIN
+#define LIB_EXPORT __declspec(dllexport)
+#else
+#define LIB_EXPORT
+#endif
+
+QT_BEGIN_NAMESPACE
+
+extern "C" { LIB_EXPORT QObject* ini(); }
+
+class CPP : public QObject {
+ Q_OBJECT
+public:
+
+ Q_INVOKABLE QImage toGrayscale(const QImage&);
+ Q_INVOKABLE void toGrayscaleReplace(QImage*);
+};
+
+QT_END_NAMESPACE
+
+#endif
diff --git a/examples/X-extras/cpp-qimage/lib.pro b/examples/X-extras/cpp-qimage/lib.pro
new file mode 100644
index 0000000..9a89f82
--- /dev/null
+++ b/examples/X-extras/cpp-qimage/lib.pro
@@ -0,0 +1,13 @@
+TEMPLATE = lib
+CONFIG += plugin release
+INCLUDEPATH += ../../../src
+LIBS += -L../../.. -leql5
+DESTDIR = ./
+TARGET = qimage
+OBJECTS_DIR = ./tmp/
+MOC_DIR = ./tmp/
+
+include(../../../src/windows.pri)
+
+HEADERS += lib.h
+SOURCES += lib.cpp
diff --git a/examples/X-extras/lcd.lisp b/examples/X-extras/lcd.lisp
new file mode 100644
index 0000000..e571c28
--- /dev/null
+++ b/examples/X-extras/lcd.lisp
@@ -0,0 +1,24 @@
+;;; LCD pixel color test (inspired by a "comp.lang.lisp" thread)
+
+#-qt-wrapper-functions ; see README-OPTIONAL.txt
+(load (in-home "src/lisp/all-wrappers"))
+
+(in-package :eql-user)
+
+(defun lcd-test ()
+ (let ((widget (qnew "QWidget(QWidget*,Qt::WindowFlags)" nil |Qt.WindowStaysOnTopHint|
+ "mouseTracking" t)))
+ (qoverride widget "mouseMoveEvent(QMouseEvent*)"
+ (lambda (event)
+ (qset-color widget |QPalette.Window|
+ (|fromHsv.QColor|
+ (floor (* 359 (/ (|x| event) (|width| widget))))
+ (floor (* 255 (/ (|y| event) (|height| widget))))
+ 255))))
+ (qoverride widget "mousePressEvent(QMouseEvent*)" (lambda (event) (qquit)))
+ (|setPos.QCursor| '(0 0))
+ (|showFullScreen| widget)
+ #+darwin
+ (|raise| widget)))
+
+(lcd-test)
diff --git a/examples/X-extras/make-qimage.lisp b/examples/X-extras/make-qimage.lisp
new file mode 100644
index 0000000..7c28316
--- /dev/null
+++ b/examples/X-extras/make-qimage.lisp
@@ -0,0 +1,547 @@
+;;;
+;;; Contributed by Mark Cox, please see LICENSE-MAKE-QIMAGE.txt
+;;;
+
+#-qt-wrapper-functions ; see README-OPTIONAL.txt
+(load (in-home "src/lisp/all-wrappers"))
+
+(defpackage "MAKE-QIMAGE-EXAMPLE"
+ (:use "COMMON-LISP"
+ "EQL")
+ (:documentation
+ "The MAKE-QIMAGE-EXAMPLE package tests the EQL:MAKE-QIMAGE function.
+
+The example creates many QImage objects with varying QImage::Format
+specifications. The data used by the QImage object is obtained from a
+Lisp created array."))
+
+(in-package "MAKE-QIMAGE-EXAMPLE")
+
+;; The qimage test database
+
+(defclass qimage-test ()
+ ((name
+ :initarg :name
+ :reader test-name)
+ (short-description
+ :initarg :short-description
+ :reader test-short-description)
+ (long-description
+ :initarg :long-description
+ :reader test-long-description)
+ (function
+ :initarg :function
+ :reader test-function))
+ (:documentation "An instance of the QIMAGE-TEST class encapsulates
+ the information needed to conduct a MAKE-QIMAGE test."))
+
+(defvar *qimage-tests* nil
+ "The database of qimage-test objects.")
+
+(defun remove-all-qimage-tests ()
+ "Remove all tests from the database."
+ (setf *qimage-tests* nil))
+
+(defun map-qimage-tests (function)
+ "Invoke FUNCTION once for each QIMAGE-TEST instance in the
+database."
+ (map nil #'(lambda (item)
+ (funcall function (cdr item)))
+ *qimage-tests*))
+
+(defun qimage-test (name)
+ "Return the QIMAGE-TEST instance with the given test NAME, or NIL if
+an instance cannot be found."
+ (declare (type symbol name))
+ (let ((v (assoc name *qimage-tests*)))
+ (when v
+ (cdr v))))
+
+(defun (setf qimage-test) (value name)
+ "Store a QIMAGE-TEST instance with in the test database."
+ (declare (type qimage-test value)
+ (type symbol name))
+ (assert (eql (test-name value) name))
+ (let ((v (assoc name *qimage-tests*)))
+ (cond
+ (v
+ (setf (cdr v) value))
+ (t
+ (push (cons name value) *qimage-tests*)
+ value))))
+
+(defun ensure-qimage-test (name &key short-description long-description function)
+ "Create and add a new QIMAGE-TEST object to the test database."
+ (setf (qimage-test name) (make-instance 'qimage-test
+ :name name
+ :short-description short-description
+ :long-description long-description
+ :function function)))
+
+(defmacro define-qimage-test (name-expression long-description &body body)
+ "A more convenient syntax for ENSURE-QIMAGE-TEST."
+ (destructuring-bind (symbol-name short-description) name-expression
+ `(ensure-qimage-test ',symbol-name
+ :short-description ,short-description
+ :long-description ,long-description
+ :function (lambda ()
+ ,@body))))
+
+;; Define the QImage tests.
+
+(defun make-checkerboard (&key (board-length 8) (block-length 8))
+ "Create an array with element type BIT initialised with a
+checkerboard pattern.
+
+The value of BOARD-LENGTH refers to the number of blocks along one
+side of the checkerboard. The value of BLOCK-LENGTH represents the
+side length of a block in pixels."
+ (let* ((width (* board-length block-length))
+ (height (* board-length block-length))
+ (board (make-array (list height width) :element-type 'bit :initial-element 0)))
+ (labels ((colour-square (row column)
+ (loop :for i :from (* row block-length) :below (* (1+ row) block-length) :do
+ (loop :for j :from (* column block-length) :below (* (1+ column) block-length) :do
+ (setf (aref board i j) 1))))
+ (colour-column-if (row predicate)
+ (dotimes (column board-length)
+ (when (funcall predicate column)
+ (colour-square row column)))))
+ (dotimes (row board-length)
+ (colour-column-if row (if (evenp row) #'evenp #'oddp)))
+ board)))
+
+(defun make-color-table-from-colors (&rest colors)
+ "Create a new color table from the list of COLORS. Each color in
+COLORS must be a (UNSIGNED-BYTE 32) value."
+ (assert (every #'(lambda (item)
+ (typep item '(unsigned-byte 32)))
+ colors))
+ (make-array (list (length colors)) :initial-contents colors))
+
+(defun indexed8-color-table/redscale ()
+ "Creates a color table where 8 bit integers refer to different
+shades of red."
+ (let ((rv (make-array 256)))
+ (dotimes (i (length rv))
+ (setf (aref rv i) (qrgb i 0 0)))
+ rv))
+
+(defun indexed8-color-table/bluescale ()
+ "Creates a color table where 8 bit integers refer to different
+shades of blue."
+ (let ((rv (make-array 256)))
+ (dotimes (i (length rv))
+ (setf (aref rv i) (qrgb 0 0 i)))
+ rv))
+
+(defun make-gradient-image (width height)
+ "Create an indexed8 gradient image. The color values are determined
+ by the pixel coordinate's distance to the center of the image. The
+ furthest point has the value 0 and the center point has the value
+ 255."
+ (assert (and (evenp width)
+ (evenp height)))
+ (let* ((center-x (/ width 2))
+ (center-y (/ height 2))
+ (maximum-distance (sqrt (+ (* center-x center-x)
+ (* center-y center-y))))
+ (rv (make-array (list height width) :element-type '(unsigned-byte 8))))
+ (labels ((distance-to-center (x y)
+ (let ((dx (- x center-x))
+ (dy (- y center-y)))
+ (sqrt (+ (* dx dx) (* dy dy)))))
+ (determine-color (x y)
+ (let ((v (round (* 255 (- 1 (/ (distance-to-center x y)
+ maximum-distance))))))
+ (min (max 0 v) 255))))
+ (dotimes (i height)
+ (dotimes (j width)
+ (setf (aref rv i j) (determine-color j i))))
+ rv)))
+
+(define-qimage-test (mono/default-color-table "Mono (default color table)")
+ "A checkerboard image created using a two dimensional array with element type BIT.
+
+The board is a 5 by 5 grid with each square containing 7 by 7
+pixels. The top left square should be white and the alternating color
+should be black."
+ (make-qimage (make-checkerboard :board-length 5 :block-length 7)
+ |QImage.Format_Mono|))
+
+(define-qimage-test (mono/color-table "Mono (custom color table)")
+ "An checkerboard image created using a two dimensional array with element type BIT.
+
+The board is a 8 by 8 grid with each square containing of 5 by 5
+pixels. The top left square should be green and the alternating color
+should be red."
+ (make-qimage (make-checkerboard :board-length 8 :block-length 5)
+ |QImage.Format_Mono|
+ :color-table (make-color-table-from-colors (qrgb 255 0 0) (qrgb 0 255 0))))
+
+(define-qimage-test (indexed8/default-color-table "Indexed8 (default color table)")
+ "A 100 by 100 gradient image created from a two dimensional array with element type (UNSIGNED-BYTE 8).
+
+The color table used produces an image that is white in the center and
+black in the corners."
+ (make-qimage (make-gradient-image 100 100)
+ |QImage.Format_Indexed8|))
+
+(define-qimage-test (indexed8/redscale-color-table "Indexed8 (redscale color table)")
+ "A 100 by 100 gradient image created from a two dimensional array with element type (UNSIGNED-BYTE 8).
+
+The color table used produces an image that is red in the center and
+black in the corners."
+ (make-qimage (make-gradient-image 100 100)
+ |QImage.Format_Indexed8|
+ :color-table (indexed8-color-table/redscale)))
+
+(define-qimage-test (rgb444 "RGB444")
+ "A 100 by 100 gradient image created from a two dimensional array with element type (UNSIGNED-BYTE 16). The QImage format is RGB444 (0x0RGB).
+
+The image contains the colors black, green, red and yellow in the top
+left, bottom right, top right and bottom right corners
+respectively. All other colors are interpolated."
+ (labels ((qrgb444 (r g b)
+ (declare (type (integer 0 15) r g b))
+ (let ((v 0))
+ (setf (ldb (byte 4 8) v) r
+ (ldb (byte 4 4) v) g
+ (ldb (byte 4 0) v) b)
+ v)))
+ (let ((data (make-array (list 100 100) :element-type '(unsigned-byte 16))))
+ (destructuring-bind (height width) (array-dimensions data)
+ (dotimes (i height)
+ (let ((green (round (* 15 (/ i height)))))
+ (dotimes (j width)
+ (let ((red (round (* 15 (/ j width)))))
+ (setf (aref data i j) (qrgb444 red green 0)))))))
+ (make-qimage data |QImage.Format_RGB444|))))
+
+(define-qimage-test (rgb32 "RGB32")
+ "A 100 by 100 gradient image created from a two dimensional array with element type (UNSIGNED-BYTE 32). The QImage format is RGB32 (0x00RRGGBB).
+
+The image contains the colors black, green, blue and cyan in the top
+left, bottom right, top right and bottom right corners
+respectively. All other colors are interpolated."
+ (let ((data (make-array (list 100 100) :element-type '(unsigned-byte 32))))
+ (destructuring-bind (height width) (array-dimensions data)
+ (dotimes (i height)
+ (let ((green (round (* 255 (/ i height)))))
+ (dotimes (j width)
+ (let ((blue (round (* 255 (/ j width)))))
+ (setf (aref data i j) (qrgb 0 green blue)))))))
+ (make-qimage data |QImage.Format_RGB32|)))
+
+(define-qimage-test (rgb888 "RGB888 (3 dimensional lisp array)")
+ "A 100 by 100 gradient image created using a three dimensional array with element type (UNSIGNED-BYTE 8). The QImage format is RGB888.
+
+The image contains the colors black, red, blue and purple in the top
+left, bottom right, top right and bottom right corners
+respectively. All other colors are interpolated."
+ (let ((data (make-array (list 100 100 3) :element-type '(unsigned-byte 8))))
+ (let ((height (array-dimension data 0))
+ (width (array-dimension data 1)))
+ (dotimes (i height)
+ (let ((red (round (* 255 (/ i height)))))
+ (dotimes (j width)
+ (let ((blue (round (* 255 (/ j width)))))
+ (setf (aref data i j 0) red
+ (aref data i j 1) 0
+ (aref data i j 2) blue))))))
+ (make-qimage data |QImage.Format_RGB888|)))
+
+;; the application protocol
+
+(defgeneric resize (widget width height)
+ (:documentation "Resize WIDGET to the specified WIDTH and HEIGHT."))
+
+(defgeneric show (widget)
+ (:documentation "Show the WIDGET."))
+
+(defgeneric description (window)
+ (:documentation "Return the description string displayed in WINDOW."))
+
+(defgeneric (setf description) (new-value window)
+ (:documentation "Change the description displayed in WINDOW."))
+
+(defgeneric image (window)
+ (:documentation "The image object currently displaed by WINDOW."))
+
+(defgeneric (setf image) (new-value window)
+ (:documentation "Change the image object displayed by WINDOW."))
+
+(defgeneric add-item (window short-description on-selection)
+ (:documentation "Add a selectable item to WINDOW. The item will be
+ displayed to the user using SHORT-DESCRIPTION. The function
+ ON-SELECTION is called when the item is selected by the user."))
+
+(defgeneric test-selected (application-window index)
+ (:documentation "This function is called by an instance of
+APPLICATION-WINDOW when the user selects a test."))
+
+(defun main ()
+ (let ((window (make-instance 'application-window)))
+ (map-qimage-tests #'(lambda (test)
+ (add-item window (test-short-description test)
+ (lambda ()
+ (setf (description window) (test-long-description test)
+ (image window) (funcall (test-function test)))))))
+ (test-selected window 0)
+ (resize window 800 600)
+ (show window)))
+
+;; GUI stuff
+
+;; - Double Slider
+
+(defclass double-slider ()
+ ((minimum-value
+ :initarg :minimum-value
+ :accessor minimum-value)
+ (maximum-value
+ :initarg :maximum-value
+ :accessor maximum-value)
+ (slider
+ :reader widget)
+ (value
+ :initarg :value
+ :accessor value)
+ (on-value-change
+ :initarg :on-value-change
+ :accessor on-value-change))
+ (:default-initargs
+ :minimum-value 0.1
+ :maximum-value 10
+ :number-of-steps 1000
+ :value 1
+ :orientation |Qt.Horizontal|
+ :on-value-change nil)
+ (:documentation "A double version of the Qt QSlider class."))
+
+(defun double-slider/from-int-value (double-slider int-value)
+ "Convert the INT-VALUE to the double value used by the
+DOUBLE-SLIDER."
+ (with-slots (slider) double-slider
+ (let* ((int-minimum (|minimum| slider))
+ (int-maximum (|maximum| slider))
+ (m (/ (- (maximum-value double-slider)
+ (minimum-value double-slider))
+ (- int-maximum int-minimum)))
+ (c (- (maximum-value double-slider)
+ (* m int-maximum))))
+ (+ (* m int-value) c))))
+
+(defun double-slider/to-int-value (double-slider value)
+ "Conver the double VALUE to an integer value that can be used by a
+QSlider instance."
+ (with-slots (slider) double-slider
+ (let* ((y1 (|maximum| slider))
+ (y2 (|minimum| slider))
+ (x1 (maximum-value double-slider))
+ (x2 (minimum-value double-slider))
+ (m (/ (- y1 y2) (- x1 x2)))
+ (c (- y1 (* m x1))))
+ (round (+ (* m value) c)))))
+
+(defmethod (setf value) :after (value (slider double-slider))
+ "Change the value displayed by the QSlider instance."
+ (|setValue| (widget slider) (double-slider/to-int-value slider value)))
+
+(defmethod (setf value) :around (value (slider double-slider))
+ "Call the ON-VALUE-CHANGE callback when the value of the
+DOUBLE-SLIDER changes."
+ (let ((value-before (value slider)))
+ (call-next-method)
+ (unless (= value-before (value slider))
+ (let ((fn (on-value-change slider)))
+ (when fn
+ (funcall fn value))))))
+
+(defmethod initialize-instance :after ((self double-slider) &key orientation number-of-steps)
+ (setf (minimum-value self) (min (value self) (minimum-value self))
+ (maximum-value self) (max (value self) (maximum-value self)))
+
+ (with-slots (slider) self
+ (setf slider (qnew "QSlider(Qt::Orientation,QWidget*)" orientation nil))
+ (|setMinimum| slider 0)
+ (|setMaximum| slider number-of-steps)
+ (|setValue| slider 0)
+ (qconnect slider "valueChanged(int)" (lambda (new-value)
+ (setf (value self) (double-slider/from-int-value self new-value)))))
+
+ (setf (value self) (value self)))
+
+;; image viewer widget
+
+(defclass image-viewer ()
+ ((zoom
+ :initarg :zoom
+ :accessor zoom)
+ (graphics-view
+ :reader widget)
+ (pixmap-item)
+ (image
+ :accessor image))
+ (:default-initargs
+ :zoom 1)
+ (:documentation "A widget for displaying QImage objects."))
+
+(defmethod (setf zoom) :around (new-value (self image-viewer))
+ "Change the transform of the graphics-view if the zoom value
+changes."
+ (with-slots (graphics-view ) self
+ (let ((current (zoom self)))
+ (call-next-method)
+ (unless (= current new-value)
+ (|setTransform| graphics-view (|fromScale.QTransform| new-value new-value))))))
+
+(defmethod (setf image) :after (new-value (self image-viewer))
+ "Change the pixmap displayed by the PIXMAP-ITEM."
+ (cond
+ ((null new-value)
+ (setf (image self) (qnew "QImage")))
+ (t
+ (with-slots (pixmap-item graphics-view) self
+ (|setPixmap| pixmap-item (|fromImage.QPixmap| (image self)))
+ (|setPos| pixmap-item
+ (/ (|width| (image self)) -2)
+ (/ (|height| (image self)) -2))
+ (|centerOn| graphics-view 0 0)))))
+
+(defmethod initialize-instance :after ((self image-viewer) &key)
+ (with-slots (window graphics-view pixmap-item text-item zoom-slider) self
+ (let ((graphics-scene (qnew "QGraphicsScene")))
+ (setf graphics-view (qnew "QGraphicsView"))
+ (setf pixmap-item (qnew "QGraphicsPixmapItem"))
+ (|addItem| graphics-scene pixmap-item)
+ (|setScene| graphics-view graphics-scene))))
+
+;; test list widget
+(defclass qimage-test-list-view ()
+ ((on-selection
+ :initarg :on-selection
+ :reader on-selection)
+ (list-view
+ :reader widget))
+ (:documentation "The view used by the user to select the different
+ QImage tests. The callback ON-SELECTION is invoked when a test is
+ selected."))
+
+(defgeneric model (view-object)
+ (:documentation "Return the model object used by VIEW-OBJECT."))
+
+(defgeneric (setf model) (value view-object)
+ (:documentation "Change the model object used by VIEW-OBJECT."))
+
+(defgeneric current-index (view-object)
+ (:documentation "Return the current selected row in view."))
+
+(defgeneric (setf current-index) (value view-object)
+ (:documentation "Change the currently selected row in view."))
+
+(defmethod initialize-instance :after ((self qimage-test-list-view) &key)
+ (with-slots (list-view) self
+ (setf list-view (qnew "QListView"))
+ (|setEditTriggers| list-view |QAbstractItemView.NoEditTriggers|)
+ (qconnect list-view "clicked(QModelIndex)" (lambda (index)
+ (when (on-selection self)
+ (funcall (on-selection self) (|row| index)))))))
+
+(defmethod model ((view-object qimage-test-list-view))
+ (|model| (widget view-object)))
+
+(defmethod (setf model) (new-value (view-object qimage-test-list-view))
+ (|setModel| (widget view-object) new-value))
+
+(defmethod current-index ((view-object qimage-test-list-view))
+ (|currentIndex| (widget view-object)))
+
+(defmethod (setf current-index) (value (view-object qimage-test-list-view))
+ (declare (type (integer 0) value))
+ (let* ((model (|model| (widget view-object)))
+ (model-index (|index| model value 0)))
+ (|setCurrentIndex| (widget view-object) model-index)))
+
+(defclass application-window ()
+ ((widget
+ :reader widget)
+ (image-viewer)
+ (zoom-slider)
+ (test-list-view)
+ (test-list-model)
+ (description)
+ (items
+ :initform nil))
+ (:documentation "The view used to display the image created by a QImage
+ test."))
+
+(defmethod image ((window application-window))
+ (with-slots (image-viewer) window
+ (image image-viewer)))
+
+(defmethod (setf image) (new-value (window application-window))
+ (with-slots (image-viewer) window
+ (setf (image image-viewer) new-value)))
+
+(defmethod (setf description) (new-value (window application-window))
+ (with-slots (description) window
+ (|setText| description new-value)))
+
+(defmethod test-selected ((application-window application-window) index)
+ (with-slots (items test-list-view) application-window
+ (setf (current-index test-list-view) index)
+ (funcall (elt items index))))
+
+(defmethod add-item ((window application-window) short-description on-selection)
+ (with-slots (test-list-model items) window
+ (|columnCount| test-list-model)
+ (|insertRow| test-list-model (|rowCount| test-list-model))
+ (|setData| test-list-model
+ (|index| test-list-model (1- (|rowCount| test-list-model)) 0)
+ (qnew "QVariant(QString)" short-description))
+ (setf items (append items (cons on-selection nil)))))
+
+(defmethod initialize-instance :after ((self application-window) &key)
+ (with-slots (widget image-viewer zoom-slider test-list-view test-list-model description) self
+ (setf widget (qnew "QWidget")
+ image-viewer (make-instance 'image-viewer)
+ zoom-slider (make-instance 'double-slider :on-value-change (lambda (new-zoom)
+ (setf (zoom image-viewer) new-zoom)))
+ test-list-view (make-instance 'qimage-test-list-view :on-selection (lambda (index)
+ (test-selected self index)))
+ test-list-model (qnew "QStringListModel")
+ description (qnew "QLabel"))
+
+ (|setWordWrap| description t)
+ (|setMaximumWidth| description 250)
+ (|setMinimumHeight| (widget test-list-view) 150)
+ (|setMaximumHeight| (widget test-list-view) 150)
+ (|setModel| (widget test-list-view) test-list-model)
+
+ (let ((layout (qnew "QHBoxLayout")))
+ (let ((v (qnew "QVBoxLayout")))
+ (|addWidget| v (qnew "QLabel" "text" "QImage format"))
+ (|addWidget| v (widget test-list-view))
+ (|addWidget| v description)
+ (|addStretch| v)
+ (|addLayout| layout v 0))
+ (let ((v (qnew "QVBoxLayout")))
+ (|addWidget| v (widget image-viewer))
+ (let ((h (qnew "QHBoxLayout")))
+ (|addStretch| h)
+ (|addWidget| h (Widget zoom-slider))
+ (|addLayout| v h))
+ (|addLayout| layout v 1))
+ (|setLayout| widget layout))))
+
+;; common method implementations
+
+(defmethod resize (object width height)
+ (|resize| (widget object) width height))
+
+(defmethod show (object)
+ (|show| (widget object)))
+
+(main)
+
diff --git a/examples/X-extras/move-blocks.lisp b/examples/X-extras/move-blocks.lisp
new file mode 100644
index 0000000..598c5fd
--- /dev/null
+++ b/examples/X-extras/move-blocks.lisp
@@ -0,0 +1,393 @@
+;;; This is a (slightely extended) port of the Qt example "moveblocks".
+;;; Depends on plugin in "cpp/", needed for custom easing curve function.
+;;;
+;;; Exploring the features is left as an exercise...
+
+#-qt-wrapper-functions ; see README-OPTIONAL.txt
+(load (in-home "src/lisp/all-wrappers"))
+
+(in-package :eql-user)
+
+(setf *break-on-errors* t)
+
+;;;
+;;; cpp plugin
+;;;
+
+(defvar *c++* (qload-c++ (in-home "examples/X-extras/cpp-move-blocks/easing_curve")))
+(defvar *custom-easing-curve* (! "easingCurve" (:qt *c++*)))
+
+(let ((sub 0)
+ (div 1)
+ function)
+ (defun custom-easing-function (progress)
+ (let ((y (ignore-errors
+ (eval (subst progress 'x function)))))
+ (if y
+ (/ (- y sub) div)
+ progress)))
+ (defun easing-function-edited ()
+ (labels ((call (x)
+ (ignore-errors (eval (subst x 'x function))))
+ (normalize ()
+ (setf sub (or (call 0) 0)
+ div (or (- (call 1) sub) 1))
+ (when (zerop div)
+ (setf div 1))))
+ (let* ((fun (ignore-errors
+ (read-from-string (format nil "(progn ~A)" (|toPlainText| *custom*)))))
+ (y (ignore-errors
+ (eval (subst 1 'x fun)))))
+ (when (numberp y)
+ (setf function fun)
+ (normalize)
+ (update-graph-pixmap *custom-easing-curve*))
+ (qset-color *custom* |QPalette.Base| (if y "white" "peachpuff"))))))
+
+;;;
+;;; user interface
+;;;
+
+(defvar *main* (qload-ui (in-home "examples/data/move-blocks.ui")))
+
+(defvar-ui *main*
+ *custom*
+ *duration*
+ *easing-curve*
+ *graph*
+ *items*
+ *pause*
+ *view*)
+
+(defun easing-curve-names ()
+ (let ((custom "Custom"))
+ (cons custom (sort (remove custom (mapcar 'car (cdadr (qenums "QEasingCurve" "Type"))) :test 'string=)
+ 'string<))))
+
+(defun ini-ui ()
+ ;; easing curve
+ (x:do-with *easing-curve*
+ (|setToolTip| "Change easing curve of selected items")
+ (|addItems| (easing-curve-names)))
+ (|setCurrentIndex| *easing-curve* (|findText| *easing-curve* "InElastic"))
+ (qconnect *easing-curve* "activated(QString)" 'change-easing-curve)
+ ;; custom easing curve function
+ (x:do-with *custom*
+ (|setFont| (qnew "QFont(QString,int)"
+ #+darwin "Monaco" #+darwin 12
+ #+linux "Monospace" #+linux 9
+ #+windows "Courier New" #+windows 10))
+ (|setPlainText| (format nil ";; \"Custom\" easing function~
+ ~%~
+ ~%(defun ease (s)~
+ ~% (- (* (expt x 3) (1+ s))~
+ ~% (* (expt x 2) s)))~
+ ~%~
+ ~%(ease (- (* 15 x) 7))")))
+ (qconnect *custom* "textChanged()" 'easing-function-edited)
+ (easing-function-edited)
+ ;; items
+ (x:do-with *items*
+ (|setColumnCount| 2)
+ (|setRootIsDecorated| nil)
+ (|setSelectionMode| |QAbstractItemView.ExtendedSelection|))
+ (|hide| (|header| *items*))
+ (|setStretchLastSection| (|header| *items*) t)
+ (qlater (lambda () (|resizeColumnToContents| *items* 0)))
+ ;; graph
+ (qlet ((curve "QEasingCurve(QEasingCurve::Type)" |QEasingCurve.OutElastic|))
+ (update-graph-pixmap curve :ini))
+ (qoverride *graph* "paintEvent(QPaintEvent*)" 'paint-graph)
+ ;; duration
+ (x:do-with (qset *duration*)
+ ("minimum" 1)
+ ("maximum" 4000)
+ ("value" 1500))
+ (qconnect *duration* "valueChanged(int)" 'change-duration)
+ ;; pause
+ (x:do-with (qset *pause*)
+ ("minimum" 1)
+ ("maximum" 1000)
+ ("value" 150))
+ (qconnect *pause* "valueChanged(int)" 'change-pause)
+ ;; sizes
+ (|setMinimumSize| *view* '(250 250)) ; initial size, see below
+ (|setMinimumWidth| *items* 200)
+ (|setMinimumWidth| *custom* 250)
+ (|resize| *main* '(0 0))
+ (qlater (lambda ()
+ (|show| *main*)
+ (|setMinimumSize| *view* '(10 10)))))
+
+(let ((n 0))
+ (defun add-to-items (color)
+ (let ((item (qnew "QTreeWidgetItem(QStringList)" (list (format nil "item ~D" (incf n))))))
+ (|setIcon| item 0 (qnew "QIcon(QPixmap)"
+ (x:let-it (qnew "QPixmap(int,int)" 10 10)
+ (|fill| x:it color))))
+ (|setText| item 1 (if (oddp n) "InElastic" "OutElastic")) ; initial values
+ (|addTopLevelItem| *items* item))))
+
+;;; graph pixmap (easing curve)
+
+(let* ((steps 70)
+ (bx 5)
+ (by 30)
+ (progress bx)
+ pixmap)
+ (defun update-graph-pixmap (curve &optional ini)
+ (when pixmap
+ (qdel pixmap))
+ (setf pixmap (qnew "QPixmap(int,int)" (+ (* 2 bx) steps) (+ (* 2 by) steps)))
+ (when ini
+ (|setFixedSize| *graph* (|size| pixmap)))
+ (qlet ((painter "QPainter(QPixmap*)" pixmap)
+ (brush1 "QBrush(QColor)" "lightgray")
+ (brush2 "QBrush(QColor)" "cornflowerblue")
+ (pen1 "QPen(QBrush,qreal,Qt::PenStyle)" brush1 1 |Qt.DashLine|)
+ (pen2 "QPen(QBrush,qreal)" brush2 2))
+ (|fill| pixmap "lightyellow")
+ (x:do-with painter
+ (|setRenderHint| |QPainter.Antialiasing|)
+ (|setPen| pen1)
+ (|drawLine| (list bx by (+ bx steps) by))
+ (|drawLine| (let ((y (+ steps by))) (list bx y (+ bx steps) y)))
+ (|setPen| pen2))
+ (let (p*)
+ (dotimes (x (1+ steps))
+ (let ((p (list (+ bx x) (- (+ by steps)
+ (* steps (|valueForProgress| curve (/ x steps)))))))
+ (|drawLine| painter (append (or p* p) p))
+ (setf p* p))))))
+ (defun paint-graph (event)
+ (qlet ((p "QPainter(QWidget*)" *graph*))
+ (|drawPixmap| p '(0 0) pixmap)
+ (when progress
+ (x:do-with p
+ (|setPen| "red")
+ (|drawLine| (list progress 0 progress (+ (* 2 by) steps)))))))
+ (defun update-graph-progress (ms)
+ (let ((max (|value| *duration*)))
+ (setf progress (if (= max ms)
+ nil
+ (+ bx (* steps (/ ms max))))))
+ (|update| *graph*)
+ (qcall-default)))
+
+;;;
+;;; move blocks
+;;;
+
+(defconstant +state-switch-event+ (+ |QEvent.User| 256))
+
+(defvar *timer* (qnew "QTimer"
+ "singleShot" t))
+
+;;; state-switch-event
+
+(let (event-rand)
+ (defun new-state-switch-event (rand)
+ (setf event-rand rand)
+ (qnew "QEvent(QEvent::Type)" +state-switch-event+))
+ (defun event-rand ()
+ event-rand))
+
+;;; state-switch-transition
+
+(defstruct (state-switch-transition (:conc-name transition-))
+ (q (qnew "QAbstractTransition"))
+ (rand 0))
+
+(defmethod the-qt-object ((object state-switch-transition))
+ (transition-q object))
+
+(defun new-state-switch-transition (rand)
+ (let ((trans (make-state-switch-transition :rand rand)))
+ (qoverride trans "eventTest(QEvent*)"
+ (lambda (event)
+ (and (= +state-switch-event+
+ (|type| event))
+ (= (transition-rand trans)
+ (event-rand)))))
+ trans))
+
+;;; state-switcher
+
+(defstruct (state-switcher (:conc-name :switcher-))
+ (q nil)
+ (state-count 0)
+ (last-index 0))
+
+(defmethod the-qt-object ((object state-switcher))
+ (switcher-q object))
+
+(defun new-state-switcher (machine name)
+ (let ((switch (make-state-switcher :q (qnew "QState(QState*)" machine
+ "objectName" name))))
+ (qoverride switch "onEntry(QEvent*)"
+ (lambda (event)
+ (let (n)
+ (x:while (= (setf n (1+ (random (switcher-state-count switch))))
+ (switcher-last-index switch)))
+ (setf (switcher-last-index switch) n)
+ (|postEvent| (|machine| switch)
+ (new-state-switch-event n)))))
+ switch))
+
+;;; main
+
+(defun new-graphics-rect-widget (color)
+ (let ((grect (qnew "QGraphicsWidget")))
+ (qoverride grect "paint(QPainter*,QStyleOptionGraphicsItem*,QWidget*)"
+ (lambda (painter s w)
+ (|fillRect| painter (|rect| grect) color)))
+ (add-to-items color) ; see *items*
+ grect))
+
+(defun create-geometry-state (parent objects rects)
+ (let ((result (qnew "QState(QState*)" parent)))
+ (mapc (lambda (object rect)
+ (|assignProperty| result object "geometry" (qnew "QVariant(QRect)" rect)))
+ objects rects)
+ result))
+
+(defun add-state (state-switcher state animation)
+ (let ((trans (new-state-switch-transition (incf (switcher-state-count state-switcher)))))
+ (x:do-with trans
+ (|setTargetState| state)
+ (|addAnimation| animation))
+ (|addTransition| state-switcher trans)))
+
+(defmacro push* (item list)
+ `(setf ,list (nconc ,list (list ,item))))
+
+(let (animations groups)
+ (defun add-property-animation (anim-group button property curve-type duration &optional pause)
+ (let ((anim (qnew "QPropertyAnimation(QObject*,QByteArray)" button (x:string-to-bytes property)))
+ (group (if pause
+ (let ((group (qnew "QSequentialAnimationGroup(QObject*)" anim-group)))
+ (|addPause| group pause)
+ (push* group groups)
+ group)
+ anim-group)))
+ (x:do-with anim
+ (|setDuration| duration)
+ (|setEasingCurve| (qnew "QEasingCurve(QEasingCurve::Type)" curve-type)))
+ (push* anim animations)
+ (|addAnimation| group anim)
+ anim))
+ (defun change-easing-curve (name)
+ (let ((type (symbol-value (intern (x:cc "QEasingCurve." name)))))
+ (dotimes (i (|topLevelItemCount| *items*))
+ (let ((item (|topLevelItem| *items* i))
+ (curve (if (string= "Custom" name)
+ *custom-easing-curve*
+ (qnew "QEasingCurve(QEasingCurve::Type)" type))))
+ (when (|isSelected| item)
+ (|setText| item 1 name)
+ (|setEasingCurve| (nth i animations) curve))
+ (update-graph-pixmap curve)))))
+ (defun change-duration (msec)
+ (dolist (anim animations)
+ (|setDuration| anim msec))
+ (update-timer))
+ (defun change-pause (msec)
+ (let ((n 0))
+ (dolist (group groups)
+ (let ((anim (|takeAnimation| group 1)))
+ (x:do-with group
+ (|clear|)
+ (|addPause| (* (incf n) msec))
+ (|addAnimation| anim)))))
+ (update-timer))
+ (defun update-timer ()
+ (|setInterval| *timer* (+ (|value| *duration*)
+ (* 4 (|value| *pause*))
+ 500))))
+
+(defun ini ()
+ (let* ((item1 (new-graphics-rect-widget "tomato"))
+ (item2 (new-graphics-rect-widget "lightgreen"))
+ (item3 (new-graphics-rect-widget "lightblue"))
+ (item4 (new-graphics-rect-widget "lightyellow"))
+ (items (list item1 item2 item3 item4))
+ (scene (qnew "QGraphicsScene"
+ "sceneRect" '(0 0 300 300)))
+ (machine (qnew "QStateMachine"))
+ (group (qnew "QState"
+ "objectName" "group"))
+ (anim-group (qnew "QParallelAnimationGroup")))
+ (|setScene| *view* scene)
+ (|setZValue| item2 1)
+ (|setZValue| item3 2)
+ (|setZValue| item4 3)
+ (x:do-with scene
+ (|setBackgroundBrush| (qnew "QBrush(QColor)" "darkslategray"))
+ (|addItem| item1)
+ (|addItem| item2)
+ (|addItem| item3)
+ (|addItem| item4))
+ (x:do-with *view*
+ (|setAlignment| (logior |Qt.AlignLeft| |Qt.AlignTop|))
+ (|setHorizontalScrollBarPolicy| |Qt.ScrollBarAlwaysOff|)
+ (|setVerticalScrollBarPolicy| |Qt.ScrollBarAlwaysOff|))
+ (let ((state1 (create-geometry-state group items
+ '((100 0 50 50)
+ (150 0 50 50)
+ (200 0 50 50)
+ (250 0 50 50))))
+ (state2 (create-geometry-state group items
+ '((250 100 50 50)
+ (250 150 50 50)
+ (250 200 50 50)
+ (250 250 50 50))))
+ (state3 (create-geometry-state group items
+ '((150 250 50 50)
+ (100 250 50 50)
+ (50 250 50 50)
+ (0 250 50 50))))
+ (state4 (create-geometry-state group items
+ '((0 150 50 50)
+ (0 100 50 50)
+ (0 50 50 50)
+ (0 0 50 50))))
+ (state5 (create-geometry-state group items
+ '((100 100 50 50)
+ (150 100 50 50)
+ (100 150 50 50)
+ (150 150 50 50))))
+ (state6 (create-geometry-state group items
+ '((50 50 50 50)
+ (200 50 50 50)
+ (50 200 50 50)
+ (200 200 50 50))))
+ (state7 (create-geometry-state group items
+ '((0 0 50 50)
+ (250 0 50 50)
+ (0 250 50 50)
+ (250 250 50 50))))
+ (state-switcher (new-state-switcher machine "stateSwitcher")))
+ (let ((anim (add-property-animation anim-group item1 "geometry" |QEasingCurve.OutElastic| 1500)))
+ (qoverride anim "updateCurrentTime(int)" 'update-graph-progress))
+ (add-property-animation anim-group item2 "geometry" |QEasingCurve.InElastic| 1500 150)
+ (add-property-animation anim-group item3 "geometry" |QEasingCurve.OutElastic| 1500 225)
+ (add-property-animation anim-group item4 "geometry" |QEasingCurve.InElastic| 1500 300)
+ (|setInterval| *timer* 2500)
+ (dolist (state (list state1 state2 state3 state4 state5 state6 state7))
+ (add-state state-switcher state anim-group))
+ (x:do-with group
+ (|setInitialState| state1)
+ (|addTransition| *timer* (qsignal "timeout()") state-switcher)))
+ (x:do-with machine
+ (|addState| group)
+ (|setInitialState| group)
+ (|start|))
+ (qconnect group "entered()" *timer* "start()")
+ (qoverride *view* "resizeEvent(QResizeEvent*)"
+ (lambda (event)
+ (|fitInView| *view* (|sceneRect| scene))
+ (qcall-default)))))
+
+(progn
+ (ini-ui)
+ (ini))
diff --git a/examples/X-extras/palindrome/README.txt b/examples/X-extras/palindrome/README.txt
new file mode 100644
index 0000000..0d82e47
--- /dev/null
+++ b/examples/X-extras/palindrome/README.txt
@@ -0,0 +1,27 @@
+INFO
+====
+
+One of the most fascinating palindromes, see:
+
+http://en.wikipedia.org/wiki/Sator_Square
+
+
+RUN
+===
+
+ eql palindrome 400 8/10 # optionally pass width / opacity
+
+
+HTML VERSION
+============
+
+Since this is a relatively complex application, it would be
+convenient to generate a 'lazy' (pre-calculated) Html5 version,
+using the
~A" (if (plusp dif) (make-string dif) "") num den)) + (|setEnabled| (qfind-child *main* "blah") (= 1 (denominator n)))))) + +(defun clear-display () + (setf *value1* 0 + *decimals* nil) + (display-number 0)) + +(defun words-clicked () + (qmsg (format nil "~R" *value1*))) + +(defun digit-clicked () + (when *reset* + (clear-display) + (setf *reset* nil)) + (let ((clicked (parse-integer (|text| (qsender))))) + (setf *value1* (if *decimals* + (+ (* clicked (expt 10 (- (incf *decimals*)))) + *value1*) + (+ clicked + (* 10 *value1*))))) + (display-number *value1*)) + +(defun back-clicked () + (when (and *decimals* (zerop *decimals*)) + (setf *decimals* nil)) + (setf *value1* (if *decimals* + (let ((n (expt 10 (decf *decimals*)))) + (/ (truncate (* n *value1*)) n)) + (truncate (/ *value1* 10)))) + (display-number *value1*)) + +(defun invert (operation) + (setf *value1* (funcall-protect operation *value1*)) + (display-number *value1*)) + +(defun sign-clicked () + (invert '-)) + +(defun reci-clicked () + (invert '/)) + +(defun point-clicked () + (setf *decimals* 0)) + +(defun clear-clicked () + (setf *value2* nil) + (clear-display) + (|adjustSize| *main*)) + +(defun operate () + (x:when-it (funcall-protect *operation* *value2* *value1*) + (setf *value2* x:it) + (display-number *value2*))) + +(defun operation-clicked () + (if *value2* + (operate) + (setf *value2* *value1*)) + (setf *operation* (intern (|text| (qsender))) + *reset* t)) + +(defun equal-clicked () + (when *value2* + (operate) + (shiftf *value1* *value2* nil) + (setf *reset* t))) + +;;; UI + +(defun run () + (flet ((b () + (qnew "QToolButton" + "minimumSize" '(35 25) + "sizePolicy" #.(qnew "QSizePolicy(QSizePolicy::Policy,QSizePolicy::Policy)" + |QSizePolicy.Expanding| |QSizePolicy.Expanding|)))) + (let* ((layout* (|layout| *main*)) + (layout (if (qnull layout*) ; for multiple call of RUN + (qnew "QGridLayout(QWidget*)" *main*) + (qt-object-? layout*))) + (digits (make-array 10)) + (plus (b)) (minus (b)) (multiply (b)) (divide (b)) (reci (b)) (sign (b)) + (point (b)) (clear (b)) (back (b)) (words (b)) (equal (b))) + (dotimes (n 10) + (setf (svref digits n) (b))) + (x:do-with (|addWidget| layout) + (reci 2 0) + (divide 2 1) + (multiply 2 2) + (minus 2 3) + (clear 2 4) + (back 3 4) + (words 4 4) + (sign 5 3) + (point 6 3) + (*real* 0 0 1 5) + (*float* 1 0 1 5) + (plus 3 3 2 1) + (equal 5 4 2 1) + ((svref digits 0) 6 0 1 3)) + (let ((n 0)) + (dotimes (r 3) + (dotimes (c 3) + (|addWidget| layout (svref digits (incf n)) (- 5 r) c)))) + (dolist (btn (list (list plus "+") + (list minus "-") + (list multiply "*") + (list divide "/") + (list reci "1/x" "R") + (list sign "+-" "S") + (list point ".") + (list clear "AC" "Delete") + (list back "<<" "Backspace") + (list words "blah" "B") + (list equal "=" "Return"))) + (let ((w (first btn)) + (s (second btn))) + (x:do-with (qset w) + ("text" s) + ("objectName" s) + ("shortcut" (qnew "QKeySequence(QString)" (or (third btn) s)))))) + (dotimes (n 10) + (let ((w (svref digits n)) + (s (princ-to-string n))) + (x:do-with (qset w) + ("text" s) + ("objectName" s) + ("shortcut" (qnew "QKeySequence(QString)" s))))) + (dolist (w (list *float* *real*)) + (|setAlignment| w |Qt.AlignRight|)) + (dotimes (n 10) + (qconnect (svref digits n) "clicked()" 'digit-clicked)) + (dolist (w (list plus minus multiply divide)) + (qconnect w "clicked()" 'operation-clicked)) + (mapc (lambda (w fun) + (qconnect w "clicked()" fun)) + (list clear back sign point reci words equal) + (list 'clear-clicked 'back-clicked 'sign-clicked 'point-clicked 'reci-clicked 'words-clicked 'equal-clicked)) + (clear-display) + (|setFocus| *real*) + (x:do-with *main* |show| |raise|)))) + +(run) + +;;; visual automation + +(defun prepare (buttons) + (flet ((normalize (string) + (string-trim " " (with-output-to-string (s) + (x:do-string (ch string) + (unless (char= #\Space ch) + (format s "~C " ch))))))) + (let ((buttons* (normalize buttons))) + (dolist (name (sort (mapcar (lambda (o) (|objectName| o)) + (qfind-children *main* nil "QToolButton")) + '> :key 'length)) + (setf buttons* (x:string-substitute name (normalize name) buttons*))) + (x:split buttons*)))) + +(defun auto (buttons &optional (milliseconds 400)) + "Run visually the passed BUTTONS (either one string or a list of button strings)." + (when (stringp buttons) + (setf buttons (prepare buttons))) + (when buttons + (|animateClick| (qfind-child *main* (first buttons)) milliseconds) + (qsingle-shot (* 2 milliseconds) (lambda () (auto (rest buttons) milliseconds))))) + +;;; example / eql calculator -a + +(defun qarg (argument) + (find argument (|arguments.QCoreApplication|) :test 'string=)) + +(when (qarg "-a") + (auto "AC 1.25 + 3.75 = *= *= 1/x 1/x +- blah")) diff --git a/examples/X-extras/cpp-move-blocks/lib.cpp b/examples/X-extras/cpp-move-blocks/lib.cpp new file mode 100644 index 0000000..2210f6c --- /dev/null +++ b/examples/X-extras/cpp-move-blocks/lib.cpp @@ -0,0 +1,24 @@ +#include "lib.h" +#include "eql_fun.h" + +QT_BEGIN_NAMESPACE + +static qreal easingFunction(qreal progress) { + // see "../move-blocks.lisp" + return eql_fun("eql-user::custom-easing-function", QVariant::Double, + Q_ARG(qreal, progress)).toDouble(); } + +QEasingCurve* CPP::easingCurve() { + static QEasingCurve* curve = 0; + if(!curve) { + curve = new QEasingCurve(QEasingCurve::Custom); + curve->setCustomType(easingFunction); } + return curve; } + +QObject* ini() { + static CPP* cpp = 0; + if(!cpp) { + cpp = new CPP; } + return cpp; } + +QT_END_NAMESPACE diff --git a/examples/X-extras/cpp-move-blocks/lib.h b/examples/X-extras/cpp-move-blocks/lib.h new file mode 100644 index 0000000..36a0299 --- /dev/null +++ b/examples/X-extras/cpp-move-blocks/lib.h @@ -0,0 +1,25 @@ +#ifndef LIB_H +#define LIB_H + +#include
+
+