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))