src/class-browser.lisp
Sun Apr 5 17:36:46 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.examples/src/class-browser.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.examples/src/class-browser.lisp 2014-10-30 07:39:41.000000000 +0100
@@ -0,0 +1,117 @@
+(in-package :qt.examples)
+(declaim (optimize (debug 3)))
+
+(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) &rest args
+ &aux (parent (first args)))
+ (declare (ignore parent))
+ (length (items list)))
+
+(defmethod cxx:data ((list classes-model) &rest args
+ &aux (index (first args))
+ (role (second args)))
+ (if (and (cxx:is-valid index)
+ (< (cxx:row index) (length (items list)))
+ (= role (value qt:+display-role+)))
+ (qt:make-variant (string-downcase
+ (class-name (aref (items list) (cxx:row index)))))
+ (make-instance 'qt: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.webkit:web-view)))
+ (:metaclass smoke::smoke-wrapper-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))
+ (setup-class-list (classes browser))
+
+ (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)))
+ (cxx:set-widget scroll (class-info browser))
+ (cxx:set-widget-resizable scroll t)
+ (cxx:add-widget layout scroll))
+ (cxx:set-layout w layout)
+ (cxx:add-widget browser w))
+ (cxx:add-widget browser (web-view browser))
+ (cxx:load (web-view browser) (make-instance 'qt:url
+ :args '("http://doc.trolltech.com/4.5")))
+ (cxx:set-uniform-item-sizes (classes-list browser) t)
+ (cxx:set-selection-mode (classes-list browser) qt:abstract-item-view.+single-selection+)
+ (cxx:set-model (classes-list browser) (classes browser))
+ (cxx:set-word-wrap (class-info browser) t)
+ (cxx:set-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
+ (make-instance 'qt:url
+ :args (list (format nil "http://doc.trolltech.com/~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))))