Examples

You can run the examples with:

(asdf:oos 'asdf:load-op :cl-smoke.qt.examples)
(qt.examples:launcher)

Example 3.4. Repl

Use a qt:string-list-model with a qt:list-view to show evaluated lisp expressions.

;;; Copyright 2009 Tobias Rautenkranz
;;; License: X11 license

(in-package :qt.examples)

(defclass repl (qt:widget)
  ((model :reader model
          :initform (make-instance 'qt:string-list-model))
   (output :reader output
           :initform (make-instance 'qt:list-view))
   (input :reader input
          :initform (make-instance 'qt:line-edit)))
  (:metaclass cxx:class))

(defun append-list-model (list-model string)
  "Appends STRING to LIST-MODEL."
  (let ((index (cxx:row-count list-model)))
    (unless (cxx:insert-row list-model index)
      (error "insert-row ~A for ~A failed." index list-model))
    (unless (cxx:set-data list-model (cxx:index list-model index) string)
      (error "set-data failed."))))

(defmethod initialize-instance :after ((repl repl) &rest args)
  (declare (ignore args))
  (setf (cxx:model (output repl)) (model repl))
  (qt:connect (qt:get-signal (input repl) "returnPressed()")
              #'(lambda ()
                  (append-list-model ;; Input
                   (model repl)
                   (format nil "> ~A" (cxx:text (input repl))))
                  (append-list-model ;; return value
                   (model repl)
                   (write-to-string
                    (handler-case (eval (read-from-string
                                         (cxx:text (input repl))))
                      (error (condition) condition))))
                  (cxx:clear (input repl))))
  (let ((layout (make-instance 'qt:vbox-layout)))
    (cxx:add-widget layout (output repl))
    (cxx:add-widget layout (input repl))
    (setf (cxx:layout repl) layout))
  (cxx:set-focus (input repl)))

(defun repl ()
  "Lisp REPL"
  (qt:with-app ()
    (let ((repl (make-instance 'repl)))
      (cxx:show repl)
      (qt:exec))))


Example 3.5. Class Browser

Qt Classes browser using :cl-smoke.qt.webkit to display the API doc and a custom qt:list-model for the qt:list-view of the available classes.

;;; Copyright 2009 Tobias Rautenkranz
;;; License: X11 license

(in-package :qt.examples)

(defclass classes-model (qt:abstract-list-model)
  ((items :reader items :initarg :items
          :initform (make-array 0 :adjustable t
                                :fill-pointer t)))
  (:metaclass cxx:class))

(defmethod cxx:row-count ((list classes-model) parent)
  (length (items list)))

(defmethod cxx:data ((list classes-model) index role)
  (if (and (cxx:is-valid index)
           (< (cxx:row index) (length (items list)))
           (= role (value qt:+display-role+)))
      (string-downcase (class-name (aref (items list) (cxx:row index))))
      (qt:make-variant)))

(defun class-at (model-index)
  (aref (items (cxx:model model-index)) (cxx:row model-index)))

(defclass class-browser (qt:splitter)
  ((classes :accessor classes
            :initform (make-instance 'classes-model))
   (classes-list :reader classes-list
                 :initform (make-instance 'qt:list-view))
   (info :reader class-info
         :initform (make-instance 'qt:label))
   (web-view :reader web-view
             :initform (make-instance 'qt:web-view)))
  (:metaclass cxx:class))

(defun setup-class-list (classes)
  (do-external-symbols (symbol :qt)
    (let ((class (find-class symbol nil)))
      (when (and (not (null class))
                 (typep class (find-class 'smoke::smoke-standard-class)))
        (vector-push-extend class
                            (items classes)))))
  (sort (items classes) #'(lambda (class1 class2)
                            (string< (class-name class1)
                                     (class-name class2)))))

(defmethod initialize-instance :after ((browser class-browser) &rest args)
  (declare (ignore args))
  (let* ((w (make-instance 'qt:widget))
         (layout (make-instance 'qt:vbox-layout)))
    (cxx:add-widget layout (classes-list browser))
    (let ((search (make-instance 'qt:line-edit)))
      (cxx:add-widget layout search)
      (qt:connect (qt:get-signal search "textChanged(QString)")
                  #'(lambda (text)
                      ;; FIXME since the class list is sorted we could do better
                      (cxx:keyboard-search (classes-list browser)
                                           text))))
    (let ((scroll (make-instance 'qt:scroll-area)))
      (setf (cxx:widget scroll) (class-info browser)
            (cxx:widget-resizable scroll) t)
      (cxx:add-widget layout scroll))
    (setf (cxx:layout w) layout)
    (cxx:add-widget browser w))
  (cxx:add-widget browser (web-view browser))
  (qt:do-delayed-initialize
    (setup-class-list (classes browser))
    (setf (cxx:uniform-item-sizes (classes-list browser)) t
          (cxx:selection-mode (classes-list browser)) qt:abstract-item-view.+single-selection+
          (cxx:model (classes-list browser)) (classes browser)
          (cxx:word-wrap (class-info browser)) t
          (cxx:window-title browser) "CL Qt Classes")
    (qt:connect (qt:get-signal (cxx:selection-model (classes-list browser))
                               "currentChanged(QModelIndex, QModelIndex)")
                #'(lambda (current previous)
                    (declare (ignore previous))
                    (set-info (class-info browser)
                              (web-view browser) current)))))

(defun set-info (info web-view model-index)
  (let* ((class (class-at model-index)))
    (cxx:load web-view (format nil "http://qt.nokia.com/doc/~A/~(~A~).html" 
                               (subseq (qt:q-version) 0 3)
                               (remove #\: (smoke:name class) :count 1)))
    (cxx:set-text info
                  (format nil "<h1>qt:~A</h1>
<p>~A</p>
<h2>Direct Superclasses</h2>
<ul>
~{ <li>~A</li> ~}
</ul>
<h2>Direct Subclasses</h2>
<ul>
~{ <li>~A</li>~}
</ul>
"
                          (string-downcase (class-name class))
                          (smoke:name class)
                          (mapcar #'(lambda (c) (string-downcase (class-name c)))
                                  (closer-mop:class-direct-superclasses class))
                          (mapcar #'(lambda (c) (string-downcase (class-name c)))
                                  (closer-mop:class-direct-subclasses class))))))

(defun class-browser ()
  "Qt Class Browser"
  (qt:with-app ()
    (let ((browser (make-instance 'class-browser)))
      (cxx:show browser)
      (qt:exec))))