[graphic-forms-cvs] r216 - in trunk/src: tests/uitoolkit uitoolkit/graphics/plugins/default

[junrue at common-lisp.net]

Author: junrue
Date: Sun Aug 13 23:07:35 2006
New Revision: 216

Modified:
   trunk/src/tests/uitoolkit/drawing-tester.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/image-tester.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp
Log:
implemented icon file loading in default graphics plugin

Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp	Sun Aug 13 23:07:35 2006
@@ -362,7 +362,6 @@
     (setf (gfw:menu-bar *drawing-win*) menubar)
     (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310))
     (setf (gfw:text *drawing-win*) "Drawing Tester")
-#+load-imagemagick-plugin
     (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
     (gfw:show *drawing-win* t)))
 

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sun Aug 13 23:07:35 2006
@@ -253,6 +253,7 @@
                                 (:item "&Help" :dispatcher echo-md
                                                :submenu ((:item "&About" :dispatcher echo-md))))))
     (setf (gfw:menu-bar *event-tester-window*) menubar)
+    (setf (gfw:image *event-tester-window*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
     (gfw:show *event-tester-window* t)))
 
 (defun event-tester ()

Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp	Sun Aug 13 23:07:35 2006
@@ -109,6 +109,7 @@
     (setf menubar (gfw:defmenu ((:item "&File"
                                  :submenu ((:item "E&xit" :callback #'exit-image-fn))))))
     (setf (gfw:menu-bar *image-win*) menubar)
+    (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
     (gfw:show *image-win* t)))
 
 (defun image-tester ()

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Aug 13 23:07:35 2006
@@ -441,6 +441,7 @@
     (dotimes (i 3)
       (add-layout-tester-widget 'gfw:button :push-button))
     (setf (gfw:text *layout-tester-win*) "Layout Tester")
+    (setf (gfw:image *layout-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
     (gfw:pack *layout-tester-win*)
     (gfw:show *layout-tester-win* t)))
 

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Sun Aug 13 23:07:35 2006
@@ -246,6 +246,7 @@
                                                       (:item "&Mini Frame"  :callback #'create-miniframe-win)
                                                       (:item "&Palette"     :callback #'create-palette-win))))))
     (setf (gfw:menu-bar *main-win*) menubar)
+    (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
     (gfw:show *main-win* t)))
 
 (defun windlg ()

Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp	(original)
+++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp	Sun Aug 13 23:07:35 2006
@@ -45,13 +45,15 @@
 (defmacro bitmap-pixel-row-length (width bit-count)
   `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3))
 
-(defun load-bmp-data (stream)
-  (let* ((header (read-value 'BITMAPFILEHEADER stream))
-         (info (read-value 'BASE-BITMAPINFOHEADER stream))
+(defun load-bmp-data (stream &optional no-header-p half-height-p)
+  (unless no-header-p
+    (read-value 'BITMAPFILEHEADER stream))
+  (let* ((info (read-value 'BASE-BITMAPINFOHEADER stream))
          (data (make-instance 'default-data-plugin :handle info)))
-    (declare (ignore header))
     (unless (= (biCompression info) gfs::+bi-rgb+)
       (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented"))
+    (if half-height-p
+      (setf (biHeight info) (/ (biHeight info) 2)))
 
     ;; load color table
     ;;
@@ -93,7 +95,13 @@
     (list data)))
 
 (defun load-icon-data (stream)
-  (declare (ignore stream)))
+  (let ((offsets (loop for i upto (1- (idCount (read-value 'ICONDIR stream)))
+                       for entry = (read-value 'ICONDIRENTRY stream)
+                       collect (ideImageOffset entry))))
+    (loop for offset in offsets
+          append (progn
+                   (file-position stream offset)
+                   (load-bmp-data stream t t)))))
 
 (defun loader (path)
   (let* ((file-type (pathname-type path))