is the version of Graphic-Forms. Double-click on the
43 | CHM file and start enjoying the Programming Reference :-)
44 |
45 |
46 | More information about configuring DocBook and xsltproc, as well
47 | as a quick tutorial on the whole process, see these links:
48 |
49 | http://www.pnotepad.org/devlog/archives/000173.html
50 | http://www.codeproject.com/winhelp/docbook_howto.asp
51 |
52 | [the end]
53 |
--------------------------------------------------------------------------------
/docs/manual/legal.xml:
--------------------------------------------------------------------------------
1 |
6 |
7 | Legal Notices
8 |
9 | Copyright © 2006-2007, Jack D. Unrue <jdunrue at gmail dot com>
10 |
11 |
12 | Redistribution and use in source and binary forms, with or without
13 | modification, are permitted provided that the following conditions are met:
14 |
15 |
16 | 1. Redistributions of source code must retain the above copyright notice,
17 | this list of conditions and the following disclaimer.
18 |
19 |
20 | 2. Redistributions in binary form must reproduce the above copyright
21 | notice, this list of conditions and the following disclaimer in the
22 | documentation and/or other materials provided with the distribution.
23 |
24 |
25 | 3. Neither the names of the authors nor the names of its contributors may
26 | be used to endorse or promote products derived from this software without
27 | specific prior written permission.
28 |
29 |
30 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
31 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
32 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
33 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE
34 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
35 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
36 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
37 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
38 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
39 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
40 |
41 |
42 | Trademarks
43 |
44 | Windows® is a registered trademark of Microsoft Corporation. Allegro CL®
45 | is a registered trademark of Franz Inc. LispWorks® is a registered trademark of
46 | LispWorks Ltd. All other trademarks used are owned by their respective owners.
47 |
48 |
49 |
--------------------------------------------------------------------------------
/docs/manual/packages.xml:
--------------------------------------------------------------------------------
1 |
2 |
7 |
8 |
9 |
10 |
11 |
12 | The symbols in this package correspond to custom components built on top
13 | of the rest of the library which don't necessarily have an immediate
14 | native peer.
15 |
16 |
17 |
21 |
22 |
23 |
24 |
25 | This package exports the symbols corresponding to graphics meta-data
26 | and drawing operations. This package and GFW together comprise the bulk
27 | of the public API.
28 |
29 |
30 |
34 |
35 |
36 |
37 |
38 | The symbols in this package correspond to system-level functionality,
39 | including CFFI declarations for functions and data types. Additional
40 | symbols represent key classes, functions, and conditions.
41 | The majority of Graphic-Forms is built on top of this package.
42 |
43 |
44 |
48 |
49 |
50 |
51 |
52 | This package contains symbols for user interface widget classes,
53 | event-handling methods, and management functions. This package and
54 | GFG together constitute the bulk of the public API.
55 |
56 |
57 |
61 |
62 |
63 |
64 |
--------------------------------------------------------------------------------
/docs/manual/Makefile:
--------------------------------------------------------------------------------
1 | # -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*-
2 | #
3 | # Makefile
4 | #
5 | # Copyright (c) 2006-2007, Jack D. Unrue
6 | #
7 |
8 | VERSION = 0.9
9 |
10 | CHM-DEPS = gfc-package-tmp.xml gfg-package-tmp.xml gfs-package-tmp.xml \
11 | gfw-package-tmp.xml constants.xml api.xml \
12 | catalog.xml glossary.xml graphic-forms.xml image-data-plugins.xml \
13 | introduction.xml legal.xml protocols.xml miscellaneous-topics.xml
14 |
15 | COMMON-DEPS = symbols.xsl packages.xsl clhs-table.xml win32-api-table.xml \
16 | packages.xml
17 |
18 | GFC-PKG-DEPS = gfc-class-symbols-tmp.xml gfc-function-symbols-tmp.xml gfc-macro-symbols-tmp.xml
19 |
20 | GFG-PKG-DEPS = gfg-class-symbols-tmp.xml gfg-function-symbols-tmp.xml gfg-macro-symbols-tmp.xml
21 |
22 | GFS-PKG-DEPS = gfs-class-symbols-tmp.xml gfs-function-symbols-tmp.xml gfs-macro-symbols-tmp.xml
23 |
24 | GFW-PKG-DEPS = gfw-class-symbols-tmp.xml gfw-function-symbols-tmp.xml gfw-macro-symbols-tmp.xml
25 |
26 | XSLT-PROC = xsltproc --nonet
27 |
28 | graphic-forms-$(VERSION).chm: $(CHM-DEPS)
29 | cat graphic-forms.xml | sed -e 's/VERSION/$(VERSION)/g' > tmp.xml
30 | $(XSLT-PROC) --stringparam version $(VERSION) graphic-forms.xsl tmp.xml
31 | -hhc htmlhelp.hhp; exit 0 # muffle Error Ignored msg due to hhc exit value 1
32 | find . \( -name "*~" -o -name "*.html" -o -name "*.hhk" -o -name "*.hhc" -o -name "*.hhp" \) -exec rm {} \;
33 |
34 | %-symbols-tmp.xml: %-symbols.xml $(COMMON-DEPS)
35 | $(XSLT-PROC) --output $@ symbols.xsl $*-symbols.xml
36 |
37 | gfc-package-tmp.xml: $(GFC-PKG-DEPS) $(COMMON-DEPS)
38 | $(XSLT-PROC) --stringparam nickname gfc --output $@ packages.xsl packages.xml
39 |
40 | gfg-package-tmp.xml: $(GFG-PKG-DEPS) $(COMMON-DEPS)
41 | $(XSLT-PROC) --stringparam nickname gfg --output $@ packages.xsl packages.xml
42 |
43 | gfs-package-tmp.xml: $(GFS-PKG-DEPS) $(COMMON-DEPS)
44 | $(XSLT-PROC) --stringparam nickname gfs --output $@ packages.xsl packages.xml
45 |
46 | gfw-package-tmp.xml: $(GFW-PKG-DEPS) $(COMMON-DEPS)
47 | $(XSLT-PROC) --stringparam nickname gfw --output $@ packages.xsl packages.xml
48 |
49 | clean:
50 | find . \( -name "*-tmp.xml" -o -name "tmp.xml" \) -exec rm {} \;
51 | find . \( -name "*~" -o -name "*.html" -o -name "*.hhk" -o -name "*.hhc" -o -name "*.hhp" \) -exec rm {} \;
52 |
53 | scrub: clean
54 | find . -name "*.chm" -exec rm {} \;
55 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/list-item.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (defun lb-insert-item (hwnd index label hbmp)
8 | (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box
9 | (let ((text (or label "")))
10 | (cffi:with-foreign-string (str-ptr text)
11 | (let ((retval (gfs::send-message hwnd gfs::+lb-insertstring+ index (cffi:pointer-address str-ptr))))
12 | (if (< retval 0)
13 | (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval)))))))
14 |
15 | (defun lb-item-height (hwnd)
16 | (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0)))
17 | (if (< height 0)
18 | (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed"))
19 | height))
20 |
21 | (defun lb-item-text-length (hwnd index)
22 | (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0)))
23 | (if (< length 0)
24 | (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed"))
25 | length))
26 |
27 | (defun lb-item-text (hwnd index &optional buffer-size)
28 | (if (or (null buffer-size) (<= buffer-size 0))
29 | (setf buffer-size (lb-item-text-length hwnd index)))
30 | (cffi:with-foreign-pointer-as-string (str-ptr (1+ buffer-size))
31 | (if (< (gfs::send-message hwnd gfs::+lb-gettext+ index (cffi:pointer-address str-ptr)) 0)
32 | (error 'gfs:win32-error :detail "LB_GETTEXT failed"))
33 | (cffi:foreign-string-to-lisp str-ptr)))
34 |
35 | ;;;
36 | ;;; methods
37 | ;;;
38 |
39 | (defmethod gfs:dispose ((self list-item))
40 | (let ((hwnd (gfs:handle self)))
41 | (unless (or (null hwnd) (cffi:null-pointer-p hwnd))
42 | (let ((owner (get-widget (thread-context) hwnd)))
43 | (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner)))
44 | (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0)))))
45 | (call-next-method))
46 |
47 | (defmethod select ((self list-item) flag)
48 | (let ((owner (owner self)))
49 | (if flag
50 | (lb-select-item owner (item-index owner self))
51 | (lb-deselect-item owner (item-index owner self)))))
52 |
53 | (defmethod selected-p ((self list-item))
54 | (let ((owner (owner self)))
55 | (> (gfs::send-message (gfs:handle self) gfs::+lb-getsel+ (item-index owner self) 0) 0)))
56 |
57 | (defmethod text ((self list-item))
58 | (let ((hwnd (gfs:handle self)))
59 | (if (or (null hwnd) (cffi:null-pointer-p hwnd))
60 | ""
61 | (lb-item-text hwnd (item-index (get-widget (thread-context) hwnd) self)))))
62 |
--------------------------------------------------------------------------------
/src/demos/unblocked/unblocked-model.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (eval-when (:compile-toplevel :load-toplevel :execute)
4 | (defconstant +max-tile-kinds+ 6)
5 | (defconstant +horz-tile-count+ 17)
6 | (defconstant +vert-tile-count+ 12)
7 | (defconstant +max-levels+ 21))
8 |
9 | (defvar *points-needed-table* (loop for level from 1 to +max-levels+
10 | collect (* 250 level level)))
11 |
12 | (defun lookup-level-reached (score)
13 | (loop for entry in *points-needed-table*
14 | for level from 1
15 | until (> entry score)
16 | finally (return level)))
17 |
18 | (defun compute-new-game-tiles ()
19 | (collapse-tiles (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+))))
20 |
21 | (defun accept-shape-p (shape)
22 | (let ((size (shape-size shape))
23 | (kind (shape-kind shape)))
24 | (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+))))
25 |
26 | (defclass unblocked-game-model ()
27 | ((score
28 | :accessor score-of
29 | :initform 0)
30 | (shape-data
31 | :accessor shape-data-of
32 | :initform nil)
33 | (original-tiles
34 | :accessor original-tiles-of
35 | :initform nil)
36 | (active-tiles
37 | :accessor active-tiles-of
38 | :initform nil)))
39 |
40 | (defvar *game* (make-instance 'unblocked-game-model))
41 |
42 | (defun model-new ()
43 | (let ((tiles (compute-new-game-tiles)))
44 | (setf (score-of *game*) 0
45 | (original-tiles-of *game*) tiles
46 | (active-tiles-of *game*) tiles)))
47 |
48 | (defun model-rollback ()
49 | (setf (score-of *game*) 0
50 | (active-tiles-of *game*) (original-tiles-of *game*)))
51 |
52 | (defun model-tiles ()
53 | (active-tiles-of *game*))
54 |
55 | (defun update-model-score (shape-data)
56 | (incf (score-of *game*) (* 5 (length shape-data))))
57 |
58 | (defun update-model-tiles (shape-data)
59 | (setf (active-tiles-of *game*)
60 | (if shape-data
61 | (progn
62 | (loop with tmp = (clone-tiles (active-tiles-of *game*))
63 | for pnt in shape-data do (set-tile tmp pnt 0)
64 | finally (return (collapse-tiles tmp))))
65 | (original-tiles-of *game*))))
66 |
67 | (defun regenerate-model-tiles ()
68 | (setf (active-tiles-of *game*) (compute-new-game-tiles)))
69 |
70 | (defun model-level ()
71 | (lookup-level-reached (score-of *game*)))
72 |
73 | (defun game-points-needed ()
74 | (- (nth (1- (model-level)) *points-needed-table*) (score-of *game*)))
75 |
76 | (defun model-score ()
77 | (score-of *game*))
78 |
--------------------------------------------------------------------------------
/docs/website/style.css:
--------------------------------------------------------------------------------
1 |
2 | .header {
3 | font-size: medium;
4 | color:#fafa00;
5 | background-image: url("gradient.png");
6 | background-repeat: repeat-fixed;
7 | background-attachment: fixed;
8 | padding: 1mm 1mm 1mm 5mm;
9 | }
10 |
11 | .footer {
12 | font-size: small;
13 | font-style: italic;
14 | text-align: right;
15 | color:#fafa00;
16 | background-image: url("gradient.png");
17 | background-repeat: repeat-fixed;
18 | background-attachment: fixed;
19 | padding: 1mm 1mm 1mm 1mm;
20 | }
21 |
22 | .footer a:link {
23 | font-weight:bold;
24 | color:#ffffff;
25 | }
26 |
27 | .footer a:visited {
28 | font-weight:bold;
29 | color:#ffffff;
30 | }
31 |
32 | :link.footerleft {
33 | font-weight:bold;
34 | float: left;
35 | color:#ffffff;
36 | }
37 |
38 | :visited.footerleft {
39 | font-weight:bold;
40 | float: left;
41 | color:#ffffff;
42 | }
43 |
44 | .check {font-size: x-small;
45 | text-align:right;}
46 |
47 | .check a:link { font-weight:bold;
48 | color:#a0a0ff;
49 | text-decoration:underline; }
50 |
51 | .check a:visited { font-weight:bold;
52 | color:#a0a0ff;
53 | text-decoration:underline; }
54 |
55 | .check a:hover { font-weight:bold;
56 | color:#000000;
57 | text-decoration:underline; }
58 |
59 | div.NavBar {
60 | padding: 4px 0px 4px 0px;
61 | float: right;
62 | font-weight:bold;
63 | }
64 |
65 | .barfirst {
66 | padding: 0px 5px 0px 5px;
67 | margin: 0px 3px 0px 0px;
68 | border-width: 0px 0px 0px 1px;
69 | border-style: none none none solid;
70 | }
71 |
72 | .barcenter {
73 | padding: 0px 5px 0px 5px;
74 | margin: 0px 3px 0px 0px;
75 | border-width: 0px 0px 0px 1px;
76 | border-style: none none none solid;
77 | }
78 |
79 | .barlast {
80 | padding: 0px 5px 0px 5px;
81 | border-width: 0px 0px 0px 1px;
82 | border-style: none none none solid;
83 | }
84 |
85 | :hover.barfirst {
86 | padding: 0px 5px 0px 5px;
87 | margin: 0px 3px 0px 0px;
88 | border-width: 0px 0px 0px 1px;
89 | border-style: none none none solid;
90 | background-color:#e4e4e4;
91 | }
92 |
93 | :hover.barcenter {
94 | padding: 0px 5px 0px 5px;
95 | margin: 0px 3px 0px 0px;
96 | border-width: 0px 0px 0px 1px;
97 | border-style: none none none solid;
98 | background-color:#e4e4e4;
99 | }
100 |
101 | :hover.barlast {
102 | padding: 0px 5px 0px 5px;
103 | border-width: 0px 0px 0px 1px;
104 | border-style: none none none solid;
105 | background-color:#e4e4e4;
106 | }
107 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/item.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (defun create-item-with-callback (howner class-symbol thing disp)
8 | (let ((item nil))
9 | (cond
10 | ((null disp)
11 | (setf item (make-instance class-symbol :data thing :handle howner)))
12 | ((functionp disp)
13 | (setf item (make-instance class-symbol :data thing :handle howner :callback disp)))
14 | ((typep disp 'gfw:event-dispatcher)
15 | (setf item (make-instance class-symbol :data thing :handle howner :dispatcher disp)))
16 | (t
17 | (error 'gfs:toolkit-error
18 | :detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
19 | item))
20 |
21 | (defun items-equal (item1 item2)
22 | (= (item-id item1) (item-id item2)))
23 |
24 | ;;;
25 | ;;; methods
26 | ;;;
27 |
28 | (defmethod check :before ((self item) flag)
29 | (declare (ignore flag))
30 | (if (gfs:null-handle-p (gfs:handle self))
31 | (error 'gfs:toolkit-error :detail "null owner handle")))
32 |
33 | (defmethod checked-p :before ((self item))
34 | (if (gfs:null-handle-p (gfs:handle self))
35 | (error 'gfs:toolkit-error :detail "null owner handle")))
36 |
37 | (defmethod gfs:dispose ((self item))
38 | (let ((hwnd (gfs:handle self)))
39 | (unless (or (null hwnd) (cffi:null-pointer-p hwnd))
40 | (let ((owner (get-widget (thread-context) hwnd)))
41 | (if owner
42 | (setf (slot-value owner 'items)
43 | (remove self (slot-value owner 'items) :test #'items-equal))))))
44 | (delete-tc-item (thread-context) self)
45 | (setf (slot-value self 'gfs:handle) nil))
46 |
47 | (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys)
48 | (setf (item-id self) (increment-item-id (thread-context)))
49 | (when callback
50 | (unless (typep callback 'function)
51 | (error 'gfs:toolkit-error :detail ":callback value must be a function"))
52 | (setf (dispatcher self)
53 | (make-instance (define-dispatcher (class-name (class-of self)) callback)))))
54 |
55 | (defmethod owner ((self item))
56 | (let ((hwnd (gfs:handle self)))
57 | (if (gfs:null-handle-p hwnd)
58 | (error 'gfs:toolkit-error :detail "null owner widget handle"))
59 | (let ((widget (get-widget (thread-context) hwnd)))
60 | (if (null widget)
61 | (error 'gfs:toolkit-error :detail "no owner widget"))
62 | widget)))
63 |
64 | (defmethod print-object ((self item) stream)
65 | (print-unreadable-object (self stream :type t)
66 | (format stream "id: ~d " (item-id self))
67 | (format stream "data: ~a " (data-of self))
68 | (format stream "handle: ~x " (gfs:handle self))
69 | (format stream "dispatcher: ~a" (dispatcher self))))
70 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/timer.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (defun clamp-delay-values (init-delay delay)
8 | "Adjust delay settings based on system-defined limits."
9 | ;;
10 | ;; SetTimer is going to impose them anyway, so might as
11 | ;; well make the slot values agree with reality.
12 | ;; On original WinXP (pre-SP1) and earlier, delay values less
13 | ;; than USER_TIMER_MINIMUM get set to 1ms, which MS rectified
14 | ;; in later releases.
15 | ;;
16 | (when (and (> init-delay 0) (< init-delay gfs::+user-timer-minimum+))
17 | (setf init-delay gfs::+user-timer-minimum+))
18 | (when (> init-delay gfs::+user-timer-maximum+)
19 | (setf init-delay gfs::+user-timer-maximum+))
20 | (when (and (> delay 0) (< delay gfs::+user-timer-minimum+))
21 | (setf delay gfs::+user-timer-minimum+))
22 | (when (> delay gfs::+user-timer-maximum+)
23 | (setf delay gfs::+user-timer-maximum+))
24 | (values init-delay delay))
25 |
26 | (defun reset-timer-to-delay (timer delay)
27 | (multiple-value-bind (init-delay clamped)
28 | (clamp-delay-values 0 delay)
29 | (declare (ignore init-delay))
30 | (let ((tc (thread-context))
31 | (id (id-of timer)))
32 | (when (zerop id)
33 | (setf (slot-value timer 'id) (increment-widget-id tc))
34 | (put-timer tc timer))
35 | (if (zerop (gfs::set-timer (utility-hwnd tc) (id-of timer) clamped (cffi:null-pointer)))
36 | (error 'gfs:win32-error :detail "set-timer failed")))
37 | clamped))
38 |
39 | ;;;
40 | ;;; methods
41 | ;;;
42 |
43 | (defmethod (setf delay-of) :around (value (self timer))
44 | (setf (slot-value self 'delay) (reset-timer-to-delay self value)))
45 |
46 | (defmethod gfs:dispose ((self timer))
47 | (let ((tc (thread-context)))
48 | (delete-timer tc self)
49 | (gfs::kill-timer (utility-hwnd tc) (id-of self))))
50 |
51 | (defmethod initialize-instance :after ((self timer) &key)
52 | (if (null (delay-of self))
53 | (error 'gfs:toolkit-error :detail ":delay value required"))
54 | (if (null (initial-delay-of self))
55 | (setf (slot-value self 'initial-delay) (delay-of self)))
56 | (multiple-value-bind (init-delay delay)
57 | (clamp-delay-values (initial-delay-of self) (delay-of self))
58 | (setf (slot-value self 'initial-delay) init-delay)
59 | (setf (slot-value self 'delay) delay)))
60 |
61 | (defmethod enable ((self timer) flag)
62 | (if flag
63 | (progn
64 | ;; use init-delay as the elapse interval for the very first
65 | ;; tick; the interval will be adjusted (or the timer killed)
66 | ;; as part of processing the first event
67 | ;;
68 | (let ((init-delay (initial-delay-of self)))
69 | (if (> init-delay 0)
70 | (reset-timer-to-delay self init-delay)
71 | (setf (delay-of self) (delay-of self)))))
72 | (gfs:dispose self)))
73 |
74 | (defmethod enabled-p ((self timer))
75 | (get-timer (thread-context) (id-of self)))
76 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/event-source.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | (defparameter *callback-info* '((gfw:event-activate . (gfw:event-source))
4 | (gfw:event-arm . (gfw:event-source))
5 | (gfw:event-modify . (gfw:event-source))
6 | (gfw:event-select . (gfw:event-source))
7 | (gfw:event-scroll . (gfw:event-source symbol symbol))))
8 |
9 | (defun make-specializer-list (disp-class arg-info)
10 | (let ((tmp (mapcar #'find-class arg-info)))
11 | (push disp-class tmp)
12 | tmp))
13 |
14 | (defun define-dispatcher-for-callbacks (callbacks)
15 | (let ((*print-gensym* nil)
16 | (class (c2mop:ensure-class (gentemp "EDCLASS" :gfgen)
17 | :direct-superclasses '(event-dispatcher))))
18 | (loop for pair in callbacks
19 | do (let* ((method-sym (car pair))
20 | (fn (cdr pair))
21 | (arg-info (cdr (assoc method-sym *callback-info*)))
22 | (args nil))
23 | `(unless (or (symbolp ,fn) (functionp ,fn))
24 | (error 'gfs:toolkit-error
25 | :detail "callback must be function or symbol naming function"))
26 | (if (null arg-info)
27 | (error 'gfs:toolkit-error :detail (format nil
28 | "unsupported event method for callbacks: ~a"
29 | method-sym)))
30 | (dotimes (i (1+ (length arg-info)))
31 | (push (gentemp "ARG" :gfgen) args))
32 | (c2mop:ensure-method (ensure-generic-function method-sym :lambda-list args)
33 | `(lambda ,args (funcall ,fn ,@args))
34 | :specializers (make-specializer-list class arg-info))))
35 | class))
36 |
37 | (defun define-dispatcher (classname callback)
38 | (let ((proto (c2mop:class-prototype (find-class classname))))
39 | (define-dispatcher-for-callbacks `((,(callback-event-name-of proto) . ,callback)))))
40 |
41 | ;;;
42 | ;;; methods
43 | ;;;
44 |
45 | (defmethod initialize-instance :after ((self event-source) &key callbacks dispatcher &allow-other-keys)
46 | (unless (or dispatcher (null callbacks))
47 | (let ((class (define-dispatcher-for-callbacks callbacks)))
48 | (setf (dispatcher self) (make-instance (class-name class))))))
49 |
50 | (defmethod owner :before ((self event-source))
51 | (if (gfs:disposed-p self)
52 | (error 'gfs:disposed-error)))
53 |
54 | (defmethod parent :before ((self event-source))
55 | (if (gfs:disposed-p self)
56 | (error 'gfs:disposed-error)))
57 |
58 | (defmethod print-object ((self event-source) stream)
59 | (print-unreadable-object (self stream :type t)
60 | (format stream "handle: ~x " (gfs:handle self))
61 | (format stream "dispatcher: ~a " (dispatcher self))))
62 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/README.txt:
--------------------------------------------------------------------------------
1 |
2 | Here is some information on the test programs available in this directory.
3 | You must first load the Graphic-Forms systems as described in the top-level
4 | README file.
5 |
6 |
7 | How To Run Purpose
8 | ------------------------------------------------------------------------------
9 |
10 | (gft:drawing-tester) Provides a test case for each major drawing operation,
11 | with variations for pen style, pen width, foreground,
12 | and background color settings. Text mode also shows
13 | features like tab expansion, mnemonics, and transparent
14 | text.
15 |
16 | (gft:event-tester) Verifies that events are being delivered and processed.
17 | Mouse events are visible if you press any button while
18 | moving the mouse (of course, mouse move events do not
19 | require a button press). Keyboard events are shown if
20 | you type keys. Mousing over the menus and menu items
21 | shows menu arming events. Also, this is one of the
22 | test cases for setting menu options via DEFMENU.
23 |
24 | (gft:hello-world) A very basic sanity check that we are able to create
25 | a window and repaint it when needed.
26 |
27 | (gft:image-tester) Tests the display of bitmaps in various sizes and
28 | color depths, also showing transparency masks and the
29 | resulting transparent backgrounds. Also, if you've
30 | loaded the ImageMagick plugin as described in the
31 | top-level README, you'll see a PNG image as well.
32 |
33 | (gft:layout-tester) Tests the flow layout manager. Explore the menu tree
34 | to see what operations are possible. Try changing
35 | layout settings and then resize the window.
36 |
37 | (gft:scroll-tester) Provides test cases for scrolling. Simple grid mode
38 | displays a numbered, scrollable grid, where the
39 | step size is 1 pixel. Text mode tests integral
40 | scrolling and resizing support. When switching from
41 | the simple grid to text mode, clicking on the window
42 | border gets the window to reset to the proper boundary.
43 |
44 | (gft:widget-tester) This is a start at a generic widget-testing program.
45 | Currently displays buttons, a check box, list boxes,
46 | sliders, and scrollbars. This is also a test case for
47 | heap layout.
48 |
49 | (gft:windlg) Provides a way to exercise custom dialogs, system
50 | dialogs, and several window styles. Note that the
51 | Borderless window is dismissed when you click within
52 | it using the mouse.
53 |
54 |
55 | [the end]
56 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/defwindow.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | (defvar *layout-initargs* (make-hash-table))
4 | (progn
5 | (setf (gethash :border *layout-initargs*)
6 | '(:bottom-margin :horizontal-margins :left-margin
7 | :margins :right-margin :top-margin :vertical-margins))
8 | (setf (gethash :flow *layout-initargs*)
9 | '(:bottom-margin :horizontal-margins :left-margin
10 | :margins :right-margin :spacing :style :top-margin
11 | :vertical-margins))
12 | (setf (gethash :heap *layout-initargs*)
13 | '(:bottom-margin :horizontal-margins :left-margin
14 | :margins :right-margin :top-child :top-margin
15 | :vertical-margins)))
16 |
17 | (defun filter-initargs (arg-plist valid-keywords)
18 | "This function filters a putative list of initargs against a list of
19 | allowed keywords. The first return value is the list of valid initargs
20 | with unrecognized keywords and duplicates removed. The second return value
21 | is a list of the invalid keywords (and their values) that were removed."
22 | (let ((clean-args nil)
23 | (bad-args (copy-seq arg-plist)))
24 | (loop for keyword in valid-keywords
25 | do (let ((value (getf arg-plist keyword)))
26 | (when value
27 | (push value clean-args)
28 | (push keyword clean-args)
29 | (loop for result = (remf bad-args keyword)
30 | while result))))
31 | (values clean-args bad-args)))
32 |
33 | (defun filter-style-keywords (input-keywords valid-keywords)
34 | "This function filters a putative list of style keywords against a list of
35 | allowed style keywords. The first return value is the list of valid keywords
36 | with unrecognized keywords and duplicates removed. The second return value
37 | is a list of the invalid keywords that were removed."
38 | (let ((ok-keywords nil)
39 | (bad-keywords nil))
40 | (loop for input in input-keywords
41 | do (if (find input valid-keywords)
42 | (push input ok-keywords)
43 | (push input bad-keywords)))
44 | (values ok-keywords bad-keywords)))
45 |
46 | #|
47 | (let ((style-form (getf form :style)))
48 | |#
49 |
50 | (defun extract-layout-definition (form)
51 | (let ((layout-form (getf form :layout)))
52 | (when layout-form
53 | (let ((valid-keywords (gethash (first form) *layout-initargs*)))
54 | (if (endp valid-keywords)
55 | (error 'gfs:toolkit-error
56 | :format-control "form ~a is not a layout definition"
57 | :format-arguments (list form)))
58 | (filter-initargs (rest form) valid-keywords)))))
59 |
60 | #|
61 | (defun rewrite-panel-form (form)
62 | (unless (eql (first form) :panel)
63 | (error 'gfs:toolkit-error
64 | :format-control "form ~a is not a panel definition"
65 | :format-arguments (list form)))
66 | (let ((style (extract-panel-style form))
67 | (layout (
68 | |#
69 |
--------------------------------------------------------------------------------
/src/demos/unblocked/unblocked-controller.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defconstant +revealed-duration+ 2000) ; millis
4 |
5 | (defun ctrl-start-game ()
6 | (model-new)
7 | (update-status-bar "Ready.")
8 | (update-panel (get-scoreboard-panel))
9 | (update-panel (get-tiles-panel)))
10 |
11 | (defun ctrl-restart-game ()
12 | (model-rollback)
13 | (update-status-bar "Ready.")
14 | (update-panel (get-scoreboard-panel))
15 | (update-panel (get-tiles-panel)))
16 |
17 | (defun ctrl-reveal-move ()
18 | (let ((shape (find-shape (model-tiles) #'accept-shape-p)))
19 | (cond
20 | (shape
21 | (let ((shape-pnts (shape-tile-points shape))
22 | (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+
23 | :delay 0
24 | :dispatcher (gfw:dispatcher (get-unblocked-win)))))
25 | (draw-tiles-directly (get-tiles-panel) shape-pnts +max-tile-kinds+)
26 | (gfw:enable timer t)))
27 | (t
28 | (gfs::message-box (gfs:handle (get-unblocked-win))
29 | "There are no remaining shapes."
30 | "Sorry!"
31 | (logior gfs::+mb-ok+ gfs::+mb-iconinformation+)
32 | 0)))))
33 |
34 | (defun ctrl-start-selection (shape-pnts panel point button)
35 | (let* ((tiles (model-tiles))
36 | (tile-pnt (window->tiles point))
37 | (tile-kind (obtain-tile tiles tile-pnt))
38 | (tmp-table (make-hash-table :test #'equalp)))
39 | (unless (or (null shape-pnts) (find tile-pnt shape-pnts :test #'eql-point))
40 | (draw-tiles-directly panel shape-pnts tile-kind))
41 | (if (and (eql button :left-button) (> tile-kind 0))
42 | (shape-tiles tiles tile-pnt tmp-table))
43 | (cond
44 | ((> (hash-table-count tmp-table) 1)
45 | (let ((shape-pnts (shape-tile-points tmp-table)))
46 | (draw-tiles-directly panel shape-pnts +max-tile-kinds+)
47 | (values tile-kind shape-pnts)))
48 | (t (values nil nil)))))
49 |
50 | (defun ctrl-finish-selection (shape-pnts shape-kind panel point button)
51 | (let ((tile-pnt (window->tiles point)))
52 | (when (and (eql button :left-button) shape-pnts)
53 | (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point))
54 | (let ((prev-level (model-level))
55 | (orig-score (score-of *game*)))
56 | (update-model-score shape-pnts)
57 | (update-status-bar (format nil
58 | "Removed ~d tiles for ~d points."
59 | (length shape-pnts)
60 | (- (score-of *game*) orig-score)))
61 | (if (> (model-level) prev-level)
62 | (progn
63 | (regenerate-model-tiles)
64 | (update-status-bar "Ready."))
65 | (update-model-tiles shape-pnts))
66 | (update-panel (get-scoreboard-panel))
67 | (update-panel (get-tiles-panel)))
68 | (draw-tiles-directly panel shape-pnts shape-kind)))))
69 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/scroll-tester.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *scroll-tester-win* nil)
4 |
5 | (defun scroll-tester-exit (disp item)
6 | (declare (ignore disp item))
7 | (gfs:dispose *scroll-tester-win*)
8 | (setf *scroll-tester-win* nil)
9 | (gfw:shutdown 0))
10 |
11 | (defclass scroll-tester-events (gfw:scrolling-helper) ())
12 |
13 | (defmethod gfw:event-close ((disp scroll-tester-events) window)
14 | (declare (ignore window))
15 | (scroll-tester-exit disp nil))
16 |
17 | (defun scroll-tester-internal ()
18 | (setf *default-pathname-defaults* (merge-pathnames "uitoolkit/" *gf-tests-dir*))
19 | (let ((layout (make-instance 'gfw:heap-layout))
20 | (icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))))
21 | (setf *scroll-tester-win* (make-instance 'gfw:top-level
22 | :dispatcher (make-instance 'scroll-tester-events)
23 | :layout layout
24 | :style '(:workspace :horizontal-scrollbar :vertical-scrollbar)))
25 | (setf (gfw:image *scroll-tester-win*) icons)
26 | (let* ((grid-panel (make-scroll-grid-panel *scroll-tester-win*))
27 | (text-panel (make-scroll-text-panel *scroll-tester-win*))
28 | (select-grid (lambda (disp item)
29 | (declare (ignore disp item))
30 | (setf (gfw:top-child-of layout) grid-panel)
31 | (gfw:layout *scroll-tester-win*)
32 | (set-grid-scroll-params *scroll-tester-win*)))
33 | (select-text (lambda (disp item)
34 | (declare (ignore disp item))
35 | (setf (gfw:top-child-of layout) text-panel)
36 | (gfw:layout *scroll-tester-win*)
37 | (set-text-scroll-params *scroll-tester-win*)))
38 | (manage-tests-menu (lambda (disp menu)
39 | (declare (ignore disp))
40 | (let ((top (gfw::obtain-top-child *scroll-tester-win*))
41 | (items (gfw:items-of menu)))
42 | (gfw:check (elt items 0) (eql top grid-panel))
43 | (gfw:check (elt items 1) (eql top text-panel)))))
44 | (menubar (gfw:defmenu ((:item "&File"
45 | :submenu ((:item "E&xit" :callback #'scroll-tester-exit)))
46 | (:item "&Tests" :callback manage-tests-menu
47 | :submenu ((:item "&Simple Grid" :callback select-grid)
48 | (:item "&Text" :callback select-text)))))))
49 | (setf (gfw:menu-bar *scroll-tester-win*) menubar
50 | (gfw:top-child-of layout) grid-panel))
51 | (setf (gfw:text *scroll-tester-win*) "Scroll Tester"
52 | (gfw:size *scroll-tester-win*) (gfs:make-size :width 300 :height 275))
53 | (set-grid-scroll-params *scroll-tester-win*)
54 | (gfw:show *scroll-tester-win* t)))
55 |
56 | (defun scroll-tester ()
57 | (gfw:startup "Scroll Tester" #'scroll-tester-internal))
58 |
--------------------------------------------------------------------------------
/src/uitoolkit/graphics/graphics-constants.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.graphics)
2 |
3 | ;;; The following are transcribed from WinGDI.h;
4 | ;;; specify one of them as the value of the char-set
5 | ;;; slot in the font-data structure.
6 | ;;;
7 | (defconstant +ansi-charset+ 0)
8 | (defconstant +default-charset+ 1)
9 | (defconstant +symbol-charset+ 2)
10 | (defconstant +shiftjis-charset+ 128)
11 | (defconstant +hangeul-charset+ 129)
12 | (defconstant +hangul-charset+ 129)
13 | (defconstant +gb2312-charset+ 134)
14 | (defconstant +chinesebig5-charset+ 136)
15 | (defconstant +oem-charset+ 255)
16 | (defconstant +johab-charset+ 130)
17 | (defconstant +hebrew-charset+ 177)
18 | (defconstant +arabic-charset+ 178)
19 | (defconstant +greek-charset+ 161)
20 | (defconstant +turkish-charset+ 162)
21 | (defconstant +vietnamese-charset+ 163)
22 | (defconstant +thai-charset+ 222)
23 | (defconstant +easteurope-charset+ 238)
24 | (defconstant +russian-charset+ 204)
25 | (defconstant +mac-charset+ 77)
26 | (defconstant +baltic-charset+ 186)
27 |
28 | ;;; The following are from WinUser.h; specify one of
29 | ;;; them as the value of the :system keyword arg when
30 | ;;; creating an icon-bundle
31 | ;;;
32 | (defconstant +application-icon+ 32512)
33 | (defconstant +error-icon+ 32513)
34 | (defconstant +information-icon+ 32516)
35 | (defconstant +question-icon+ 32514)
36 | (defconstant +warning-icon+ 32515)
37 |
38 |
39 | ;;; The following are from WinUser.h; specify one of
40 | ;;; them as the value of the :system keyword arg when
41 | ;;; creating an image.
42 | ;;;
43 | (defconstant +app-starting-cursor+ gfs::+ocr-appstarting+)
44 | (defconstant +crosshair-cursor+ gfs::+ocr-cross+)
45 | (defconstant +default-cursor+ gfs::+ocr-normal+)
46 | (defconstant +hand-cursor+ gfs::+ocr-hand+)
47 | (defconstant +help-cursor+ 32651)
48 | (defconstant +ibeam-cursor+ gfs::+ocr-ibeam+)
49 | (defconstant +no-cursor+ gfs::+ocr-no+)
50 | (defconstant +size-all-cursor+ gfs::+ocr-sizeall+)
51 | (defconstant +size-nesw-cursor+ gfs::+ocr-sizenesw+)
52 | (defconstant +size-ns-cursor+ gfs::+ocr-sizens+)
53 | (defconstant +size-nwse-cursor+ gfs::+ocr-sizenwse+)
54 | (defconstant +size-we-cursor+ gfs::+ocr-sizewe+)
55 | (defconstant +up-arrow-cursor+ gfs::+ocr-up+)
56 | (defconstant +wait-cursor+ gfs::+ocr-wait+)
57 |
58 | ;;; Device context color mixing
59 | (defconstant +R2-BLACK+ 1)
60 | (defconstant +R2-COPYPEN+ 13)
61 | (defconstant +R2-MASKNOTPEN+ 3)
62 | (defconstant +R2-MASKPEN+ 9)
63 | (defconstant +R2-MASKPENNOT+ 5)
64 | (defconstant +R2-MERGENOTPEN+ 12)
65 | (defconstant +R2-MERGEPEN+ 15)
66 | (defconstant +R2-MERGEPENNOT+ 14)
67 | (defconstant +R2-NOP+ 11)
68 | (defconstant +R2-NOT+ 6)
69 | (defconstant +R2-NOTCOPYPEN+ 4)
70 | (defconstant +R2-NOTMASKPEN+ 8)
71 | (defconstant +R2-NOTMERGEPEN+ 2)
72 | (defconstant +R2-NOTXORPEN+ 10)
73 | (defconstant +R2-WHITE+ 16)
74 | (defconstant +R2-XORPEN+ 7)
75 |
--------------------------------------------------------------------------------
/src/demos/demo-utils.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defclass demo-about-dialog-events (gfw:event-dispatcher) ())
4 |
5 | (defmethod gfw:event-close ((disp demo-about-dialog-events) (dlg gfw:dialog))
6 | (call-next-method)
7 | (gfs:dispose dlg))
8 |
9 | (defun about-demo (owner image-path title desc)
10 | (let* ((image (make-instance 'gfg:image :file image-path))
11 | (dlg (make-instance 'gfw:dialog :owner owner
12 | :dispatcher (make-instance 'demo-about-dialog-events)
13 | :layout (make-instance 'gfw:flow-layout
14 | :margins 8
15 | :spacing 8)
16 | :style '(:owner-modal)
17 | :text title))
18 | (label (make-instance 'gfw:label :parent dlg))
19 | (text-panel (make-instance 'gfw:panel
20 | :layout (make-instance 'gfw:flow-layout
21 | :margins 0
22 | :spacing 2
23 | :style '(:vertical))
24 | :parent dlg))
25 | (line1 (make-instance 'gfw:label
26 | :parent text-panel
27 | :text desc))
28 | (line2 (make-instance 'gfw:label
29 | :parent text-panel
30 | :text " "))
31 | (line3 (make-instance 'gfw:label
32 | :parent text-panel
33 | :text (format nil "Copyright (C) 2006-2007 by Jack D. Unrue")))
34 | (line4 (make-instance 'gfw:label
35 | :parent text-panel
36 | :text "All Rights Reserved."))
37 | (line5 (make-instance 'gfw:label
38 | :parent text-panel
39 | :text " "))
40 | (line6 (make-instance 'gfw:label
41 | :parent text-panel
42 | :text " "))
43 | (btn-panel (make-instance 'gfw:panel
44 | :parent dlg
45 | :layout (make-instance 'gfw:flow-layout
46 | :margins 0
47 | :spacing 0
48 | :style '(:vertical :normalize))))
49 | (close-btn (make-instance 'gfw:button
50 | :callback (lambda (disp btn)
51 | (declare (ignore disp btn))
52 | (gfs:dispose dlg))
53 | :style '(:default-button)
54 | :text "Close"
55 | :parent btn-panel)))
56 | (declare (ignore line1 line2 line3 line4 line5 line6 close-btn))
57 | (unwind-protect
58 | (gfg:with-image-transparency (image (gfs:make-point))
59 | (setf (gfw:image label) image))
60 | (gfs:dispose image))
61 | (gfw:pack dlg)
62 | (gfw:center-on-owner dlg)
63 | (gfw:show dlg t)))
64 |
--------------------------------------------------------------------------------
/src/uitoolkit/system/datastructs.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.system)
2 |
3 | (defstruct point (x 0) (y 0) (z 0))
4 |
5 | (defstruct size (width 0) (height 0) (depth 0))
6 |
7 | (defstruct rectangle (location (make-point)) (size (make-size)))
8 |
9 | (defstruct span (start 0) (end 0))
10 |
11 | (declaim (inline create-rectangle))
12 | (defun create-rectangle (&key (height 0) (width 0) (x 0) (y 0))
13 | (make-rectangle :location (make-point :x x :y y)
14 | :size (make-size :width width :height height)))
15 |
16 | (declaim (inline location))
17 | (defun location (rect)
18 | (rectangle-location rect))
19 |
20 | (defun (setf location) (pnt rect)
21 | (setf (rectangle-location rect) pnt))
22 |
23 | (declaim (inline size))
24 | (defun size (size)
25 | (rectangle-size size))
26 |
27 | (defun (setf size) (size rect)
28 | (setf (rectangle-size rect) size))
29 |
30 | (declaim (inline empty-span-p))
31 | (defun empty-span-p (span)
32 | (= (span-start span) (span-end span)))
33 |
34 | (defun equal-point-p (point1 point2)
35 | (and (= (point-x point1) (point-x point2))
36 | (= (point-y point1) (point-y point2))))
37 |
38 | (defun equal-size-p (size1 size2)
39 | (and (= (size-width size1) (size-width size2))
40 | (= (size-height size1) (size-height size2))))
41 |
42 | (defmethod cffi:free-translated-object (ptr (type point-pointer-type) param)
43 | (declare (ignore param))
44 | (cffi:foreign-free ptr))
45 |
46 | (defmethod cffi:free-translated-object (ptr (type rect-pointer-type) param)
47 | (declare (ignore param))
48 | (cffi:foreign-free ptr))
49 |
50 | (defmethod cffi:translate-from-foreign (ptr (type point-pointer-type))
51 | (if (cffi:null-pointer-p ptr)
52 | (make-point)
53 | (cffi:with-foreign-slots ((x y) ptr (:struct point))
54 | (make-point :x x :y y))))
55 |
56 | ;; TODO: CFFI has changed?
57 | (defmethod cffi:translate-from-foreign (ptr (type point-tclass))
58 | (if (cffi:null-pointer-p ptr)
59 | (make-point)
60 | (cffi:with-foreign-slots ((x y) ptr (:struct point))
61 | (make-point :x x :y y))))
62 |
63 | (defmethod cffi:translate-from-foreign (ptr (type rect-pointer-type))
64 | (if (cffi:null-pointer-p ptr)
65 | (make-rectangle)
66 | (cffi:with-foreign-slots ((left top right bottom) ptr (:struct rect))
67 | (let ((pnt (make-point :x left :y top))
68 | (size (make-size :width (- right left) :height (- bottom top))))
69 | (make-rectangle :location pnt :size size)))))
70 |
71 | (defmethod cffi:translate-to-foreign ((lisp-pnt point) (type point-pointer-type))
72 | (let ((ptr (cffi:foreign-alloc '(:struct point))))
73 | (cffi:with-foreign-slots ((x y) ptr (:struct point))
74 | (setf x (point-x lisp-pnt)
75 | y (point-y lisp-pnt)))
76 | ptr))
77 |
78 | (defmethod cffi:translate-to-foreign ((lisp-pnt point) (type point-tclass))
79 | (let ((ptr (cffi:foreign-alloc '(:struct point))))
80 | (cffi:with-foreign-slots ((x y) ptr (:struct point))
81 | (setf x (point-x lisp-pnt)
82 | y (point-y lisp-pnt)))
83 | ptr))
84 |
85 | (defmethod cffi:translate-to-foreign ((lisp-rect rectangle) (type rect-pointer-type))
86 | (let ((ptr (cffi:foreign-alloc '(:struct rect)))
87 | (pnt (location lisp-rect))
88 | (size (size lisp-rect)))
89 | (cffi:with-foreign-slots ((left top right bottom) ptr (:struct rect))
90 | (setf left (gfs:point-x pnt)
91 | top (gfs:point-y pnt)
92 | right (+ (gfs:point-x pnt) (gfs:size-width size))
93 | bottom (+ (gfs:point-y pnt) (gfs:size-height size))))
94 | ptr))
95 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/test-utils.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *child-size-1* (gfs:make-size :width 25 :height 5))
4 | (defvar *child-size-2* (gfs:make-size :width 20 :height 10))
5 | (defvar *child-size-3* (gfs:make-size :width 40 :height 40))
6 |
7 | (defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin)
8 | (let ((layout (make-instance 'gfw:flow-layout
9 | :style style
10 | :spacing (or spacing 0)
11 | :left-margin (or left-margin 0)
12 | :top-margin (or top-margin 0)
13 | :right-margin (or right-margin 0)
14 | :bottom-margin (or bottom-margin 0))))
15 | (loop for kid in kids do (gfw::append-layout-item layout kid))
16 | layout))
17 |
18 | (defun make-border-layout (kids &optional left-margin top-margin right-margin bottom-margin)
19 | (let ((layout (make-instance 'gfw:border-layout
20 | :left-margin (or left-margin 0)
21 | :top-margin (or top-margin 0)
22 | :right-margin (or right-margin 0)
23 | :bottom-margin (or bottom-margin 0))))
24 | (loop for kid in kids
25 | for region in '(:top :right :bottom :left :center)
26 | when kid
27 | do (progn
28 | (gfw::append-layout-item layout kid)
29 | (setf (gfw:layout-attribute layout kid region) t)))
30 | layout))
31 |
32 | (defun validate-image (image expected-size expected-depth)
33 | (declare (ignore expected-depth))
34 | (assert-false (null image))
35 | (assert-false (gfs:disposed-p image))
36 | ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed
37 | (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)))
38 |
39 | (defun validate-rects (entries expected-rects)
40 | (assert-equal (length expected-rects) (length entries))
41 | (let ((actual-rects (loop for entry in entries collect (cdr entry))))
42 | (mapc #'(lambda (expected actual)
43 | (let ((pnt-a (gfs:location actual))
44 | (sz-a (gfs:size actual)))
45 | (assert-equal (first expected) (gfs:point-x pnt-a))
46 | (assert-equal (second expected) (gfs:point-y pnt-a))
47 | (assert-equal (third expected) (gfs:size-width sz-a))
48 | (assert-equal (fourth expected) (gfs:size-height sz-a))))
49 | expected-rects
50 | actual-rects)))
51 |
52 | (defmacro define-layout-test (name width-hint height-hint
53 | expected-width expected-height
54 | customizer expected-rects
55 | factory &rest factory-args)
56 | (let ((layout (gensym))
57 | (size (gensym))
58 | (dummy (gensym))
59 | (data (gensym)))
60 | `(define-test ,name
61 | (let* ((,layout (apply ,factory (list ,@factory-args)))
62 | (,dummy (if ,customizer (funcall ,customizer ,layout)))
63 | (,size (gfw::compute-size ,layout *mock-container* ,width-hint ,height-hint))
64 | (,data (gfw::compute-layout ,layout *mock-container* ,width-hint ,height-hint)))
65 | (declare (ignore ,dummy))
66 | (assert-equal ,expected-width (gfs::size-width ,size))
67 | (assert-equal ,expected-height (gfs::size-height ,size))
68 | (validate-rects ,data ,expected-rects)))))
69 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/heap-layout.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (defun obtain-top-child (window)
8 | (let* ((layout (layout-of window))
9 | (top (top-child-of layout)))
10 | (if top
11 | top
12 | (car (first (compute-layout layout window -1 -1))))))
13 |
14 | ;;;
15 | ;;; methods
16 | ;;;
17 |
18 | (defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint)
19 | (cleanup-disposed-items self)
20 | (let ((size (gfs:make-size)))
21 | (mapc (lambda (item)
22 | (let ((kid-size (preferred-size (first item) width-hint height-hint)))
23 | (setf (gfs:size-width size) (max (gfs:size-width size)
24 | (gfs:size-width kid-size))
25 | (gfs:size-height size) (max (gfs:size-height size)
26 | (gfs:size-height kid-size)))))
27 | (data-of self))
28 | (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self)))
29 | (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self)))
30 | size))
31 |
32 | (defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint)
33 | (declare (ignore width-hint height-hint))
34 | (cleanup-disposed-items self)
35 | (let ((size (client-size container))
36 | (sbar (if (or (typep container 'top-level) (typep container 'dialog))
37 | (status-bar-of container))))
38 | (if sbar
39 | (decf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1))))
40 | (let* ((horz-margin (+ (left-margin-of self) (right-margin-of self)))
41 | (vert-margin (+ (top-margin-of self) (bottom-margin-of self)))
42 | (bounds (gfs:create-rectangle :x (left-margin-of self)
43 | :y (top-margin-of self)
44 | :width (- (gfs:size-width size)
45 | horz-margin)
46 | :height (- (gfs:size-height size)
47 | vert-margin))))
48 | (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))))
49 |
50 | (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint)
51 | (if (layout-p container)
52 | (let ((top (top-child-of self))
53 | (kid-specs (compute-layout self container width-hint height-hint)))
54 | (let ((spec (if top
55 | (find-if (lambda (x) (eql x top)) kid-specs :key #'car)
56 | (progn
57 | (setf top (car (first kid-specs)))
58 | (first kid-specs)))))
59 | (if spec
60 | (let ((bounds (cdr spec)))
61 | (setf (gfs:size bounds) (gfs::clamp-size (gfs:size bounds)
62 | (slot-value top 'min-size)
63 | (slot-value top 'max-size)))
64 | (setf (cdr spec) bounds))))
65 | (arrange-hwnds kid-specs (lambda (item)
66 | (if (eql top item)
67 | (logior +window-pos-flags+ gfs::+swp-showwindow+)
68 | (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))))
69 |
70 | (defmethod (setf top-child-of) :after (child (self heap-layout))
71 | (unless (typep child 'widget)
72 | (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass")))
73 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/widget-constants.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 |
4 | (defconstant +vk-lbutton+ 1)
5 | (defconstant +vk-rbutton+ 2)
6 | (defconstant +vk-cancel+ 3)
7 | (defconstant +vk-mbutton+ 4)
8 |
9 | (defconstant +vk-break+ #x03)
10 | (defconstant +vk-backspace+ #x08)
11 | (defconstant +vk-tab+ #x09)
12 | (defconstant +vk-clear+ #x0C) ; numpad-5 when numlock off
13 | (defconstant +vk-return+ #x0D)
14 | (defconstant +vk-shift+ #x10)
15 | (defconstant +vk-control+ #x11)
16 | (defconstant +vk-alt+ #x12)
17 | (defconstant +vk-pause+ #x13)
18 | (defconstant +vk-caps-lock+ #x14)
19 | (defconstant +vk-escape+ #x1B)
20 | (defconstant +vk-page-up+ #x21)
21 | (defconstant +vk-page-down+ #x22)
22 | (defconstant +vk-end+ #x23)
23 | (defconstant +vk-home+ #x24)
24 | (defconstant +vk-left+ #x25)
25 | (defconstant +vk-up+ #x26)
26 | (defconstant +vk-right+ #x27)
27 | (defconstant +vk-down+ #x28)
28 | (defconstant +vk-insert+ #x2D)
29 | (defconstant +vk-delete+ #x2E)
30 | (defconstant +vk-help+ #x2F)
31 | (defconstant +vk-left-win+ #x5B)
32 | (defconstant +vk-right-win+ #x5C)
33 | (defconstant +vk-applications+ #x5D)
34 | (defconstant +vk-numpad-0+ #x60)
35 | (defconstant +vk-numpad-1+ #x61)
36 | (defconstant +vk-numpad-2+ #x62)
37 | (defconstant +vk-numpad-3+ #x63)
38 | (defconstant +vk-numpad-4+ #x64)
39 | (defconstant +vk-numpad-5+ #x65)
40 | (defconstant +vk-numpad-6+ #x66)
41 | (defconstant +vk-numpad-7+ #x67)
42 | (defconstant +vk-numpad-8+ #x68)
43 | (defconstant +vk-numpad-9+ #x69)
44 | (defconstant +vk-numpad-*+ #x6A)
45 | (defconstant +vk-numpad-++ #x6B)
46 | (defconstant +vk-numpad--+ #x6D)
47 | (defconstant +vk-numpad-.+ #x6E)
48 | (defconstant +vk-numpad-/+ #x6F)
49 | (defconstant +vk-numpad-f1+ #x70)
50 | (defconstant +vk-numpad-f2+ #x71)
51 | (defconstant +vk-numpad-f3+ #x72)
52 | (defconstant +vk-numpad-f4+ #x73)
53 | (defconstant +vk-numpad-f5+ #x74)
54 | (defconstant +vk-numpad-f6+ #x75)
55 | (defconstant +vk-numpad-f7+ #x76)
56 | (defconstant +vk-numpad-f8+ #x77)
57 | (defconstant +vk-numpad-f9+ #x78)
58 | (defconstant +vk-numpad-f10+ #x79)
59 | (defconstant +vk-numpad-f11+ #x7A)
60 | (defconstant +vk-numpad-f12+ #x7B)
61 | (defconstant +vk-num-lock+ #x90)
62 | (defconstant +vk-scroll-lock+ #x91)
63 | (defconstant +vk-left-shift+ #xA0)
64 | (defconstant +vk-right-shift+ #xA1)
65 | (defconstant +vk-left-control+ #xA2)
66 | (defconstant +vk-right-control+ #xA3)
67 | (defconstant +vk-left-alt+ #xA4)
68 | (defconstant +vk-right-alt+ #xA5)
69 |
70 | (eval-when (:compile-toplevel :load-toplevel :execute)
71 | (defconstant +default-child-style+ (logior gfs::+ws-child+
72 | gfs::+ws-tabstop+
73 | gfs::+ws-visible+))
74 | (defconstant +default-widget-width+ 64)
75 | (defconstant +default-widget-height+ 64)
76 | (defconstant +estimated-text-size+ 32) ; bytes
77 | (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+
78 | gfs::+swp-noownerzorder+
79 | gfs::+swp-noactivate+
80 | gfs::+swp-nocopybits+)))
81 |
82 | (defvar *empty-rect* (gfs:make-rectangle))
83 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/mock-objects.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defconstant +max-widget-size+ 5000)
4 | (defconstant +default-container-width+ 300)
5 | (defconstant +default-container-height+ 200)
6 |
7 | (defvar *default-hwnd* (cffi:make-pointer #xFFFFFFFF))
8 |
9 | ;;;
10 | ;;; stand-in for a window, used as parent of mock-widget
11 | ;;;
12 |
13 | (defclass mock-container (gfw:layout-managed)
14 | ((location
15 | :accessor location-of
16 | :initarg :location
17 | :initform (gfs:make-point))
18 | (size
19 | :accessor size-of
20 | :initarg :size
21 | :initform (gfs:make-size :width +default-container-width+ :height +default-container-height+))
22 | (visibility
23 | :accessor visibility-of
24 | :initarg :visibility
25 | :initform t)))
26 |
27 | (defvar *mock-container* (make-instance 'mock-container))
28 |
29 | (defmethod gfw:visible-p ((self mock-container))
30 | (visibility-of self))
31 |
32 | ;;;
33 | ;;; stand-in for widgets that would be children of windows, to be organized
34 | ;;; via layout managers
35 | ;;;
36 |
37 | (defclass mock-widget (gfw:widget)
38 | ((visibility
39 | :accessor visibility-of
40 | :initform t)
41 | (actual-size
42 | :accessor actual-size-of
43 | :initarg :actual-size
44 | :initform (gfs:make-size))
45 | (max-size
46 | :initarg :max-size
47 | :initform (gfs:make-size :width +max-widget-size+ :height +max-widget-size+))
48 | (min-size
49 | :initarg :min-size
50 | :initform (gfs:make-size))))
51 |
52 | (defmethod initialize-instance :after ((self mock-widget) &key handle &allow-other-keys)
53 | (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*)))
54 |
55 | (defmethod gfw:location ((self mock-widget))
56 | (gfs:make-point))
57 |
58 | (defmethod gfw:minimum-size ((self mock-widget))
59 | (gfs:make-size :width (gfs:size-width (slot-value self 'min-size))
60 | :height (gfs:size-height (slot-value self 'min-size))))
61 |
62 | (defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint)
63 | (let ((size (gfs:make-size))
64 | (min-size (slot-value self 'min-size)))
65 | (if (< width-hint 0)
66 | (setf (gfs:size-width size) (gfs:size-width min-size))
67 | (setf (gfs:size-width size) width-hint))
68 | (if (< height-hint 0)
69 | (setf (gfs:size-height size) (gfs:size-height min-size))
70 | (setf (gfs:size-height size) height-hint))
71 | size))
72 |
73 | (defmethod gfw:text-baseline ((self mock-widget))
74 | (floor (* (gfs:size-height (slot-value self 'min-size)) 3) 4))
75 |
76 | (defmethod gfw:visible-p ((self mock-widget))
77 | (visibility-of self))
78 |
79 | ;;;
80 | ;;; infrastructure for item-manager unit tests
81 | ;;;
82 |
83 | (defclass mock-item (gfw:item) ())
84 |
85 | (defclass mock-item-manager (gfw:widget gfw:item-manager) ())
86 |
87 | (defmethod initialize-instance :after ((self mock-item-manager) &key handle items &allow-other-keys)
88 | (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*))
89 | (if items
90 | (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item))))
91 |
92 | (defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled classname)
93 | (declare (ignore disabled checked classname))
94 | (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp)))
95 | (vector-push-extend item (slot-value self 'gfw::items))
96 | item))
97 |
98 | (defmethod (setf gfw:items-of) (new-items (self mock-item-manager))
99 | (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) new-items 'mock-item)))
100 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/image-tester.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *image-win* nil)
4 | (defvar *happy-image* nil)
5 | (defvar *bw-image* nil)
6 | (defvar *comp-image* nil)
7 | (defvar *folder-image* nil)
8 | (defvar *true-image* nil)
9 |
10 | (defclass image-events (gfw:event-dispatcher) ())
11 |
12 | (defun dispose-images ()
13 | (loop for var in '(*happy-image* *bw-image* *folder-image* *true-image* *comp-image*)
14 | do (unless (null (symbol-value var))
15 | (gfs:dispose (symbol-value var))
16 | (setf (symbol-value var) nil))))
17 |
18 | (defmethod gfw:event-close ((d image-events) window)
19 | (declare (ignore window))
20 | (dispose-images)
21 | (gfs:dispose *image-win*)
22 | (setf *image-win* nil)
23 | (gfw:shutdown 0))
24 |
25 | (defun draw-test-image (gc image origin pixel-pnt)
26 | (gfg:draw-image gc image origin)
27 | (incf (gfs:point-x origin) 36)
28 | (gfg:with-image-transparency (image pixel-pnt)
29 | (gfg:draw-image gc (gfg:transparency-mask image) origin)
30 | (incf (gfs:point-x origin) 36)
31 | (gfg:draw-image gc image origin)))
32 |
33 | (defmethod gfw:event-paint ((d image-events) window gc rect)
34 | (declare (ignore window rect))
35 | (let ((pnt (gfs:make-point))
36 | (pixel-pnt1 (gfs:make-point))
37 | (pixel-pnt2 (gfs:make-point :x 15 :y 0))
38 | (pixel-pnt3 (gfs:make-point :x 31 :y 31)))
39 | (declare (ignorable pixel-pnt3))
40 | (draw-test-image gc *happy-image* pnt pixel-pnt1)
41 | (setf (gfs:point-x pnt) 0)
42 | (incf (gfs:point-y pnt) 36)
43 | (draw-test-image gc *bw-image* pnt pixel-pnt1)
44 | (setf (gfs:point-x pnt) 0)
45 | (incf (gfs:point-y pnt) 36)
46 | (draw-test-image gc *true-image* pnt pixel-pnt2)
47 | #+load-imagemagick-plugin
48 | (progn
49 | (setf (gfs:point-x pnt) 112)
50 | (setf (gfs:point-y pnt) 0)
51 | (draw-test-image gc *folder-image* pnt pixel-pnt1)
52 | (setf (gfs:point-x pnt) 112)
53 | (incf (gfs:point-y pnt) 36)
54 | (draw-test-image gc *comp-image* pnt pixel-pnt3))))
55 |
56 | (defun exit-image-fn (disp item)
57 | (declare (ignorable disp item))
58 | (dispose-images)
59 | (gfs:dispose *image-win*)
60 | (setf *image-win* nil)
61 | (gfw:shutdown 0))
62 |
63 | (defun load-images ()
64 | (let ((*default-pathname-defaults* (merge-pathnames "uitoolkit/" *gf-tests-dir*)))
65 | (setf *happy-image* (make-instance 'gfg:image :file "happy.bmp")
66 | *bw-image* (make-instance 'gfg:image :file "blackwhite20x16.bmp")
67 | *true-image* (make-instance 'gfg:image :file "truecolor16x16.bmp"))
68 |
69 | #+load-imagemagick-plugin
70 | (progn
71 | (setf *folder-image* (make-instance 'gfg:image :file "open-folder.gif")
72 | *comp-image* (make-instance 'gfg:image :file "computer.png")))))
73 |
74 | (defun image-tester-internal ()
75 | (load-images)
76 | (let ((menubar nil))
77 | (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events)
78 | :style '(:workspace)))
79 | (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200))
80 | (setf (gfw:text *image-win*) "Image Tester")
81 | (setf menubar (gfw:defmenu ((:item "&File"
82 | :submenu ((:item "E&xit" :callback #'exit-image-fn))))))
83 | (setf (gfw:menu-bar *image-win*) menubar)
84 | (setf (gfw:image *image-win*)
85 | (make-instance 'gfg:icon-bundle :file (merge-pathnames "uitoolkit/default.ico" *gf-tests-dir*)))
86 | (gfw:show *image-win* t)))
87 |
88 | (defun image-tester ()
89 | (gfw:startup "Image Tester" #'image-tester-internal))
90 |
--------------------------------------------------------------------------------
/docs/website/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | Graphic-Forms project
6 | Introduction
26 |
27 | Graphic-Forms is a user interface library implemented in
28 | Common Lisp focusing on the
29 | Windows platform. Graphic-Forms is licensed under the
30 | terms of the
31 | BSD License .
32 |
33 | Long-term goals for this project may include implementing an application
34 | framework on top of the toolkit, a rapid UI development language, a
35 | UI design tool, or some combination thereof.
36 |
37 | Status
38 |
39 | The current version is
40 |
41 | 0.9.0 , released on xx xxxxxxx 2007.
42 |
43 | Graphic-Forms is in the alpha stage of development,
44 | meaning new features are still being added and existing features require
45 | considerable testing. Be advised that significant API and behavior changes
46 | are likely for at least several more releases.
47 |
48 | The supported Lisp implementations are:
49 |
55 |
56 | Mailing Lists
57 |
68 |
69 | Trademarks Microsoft .
71 | Allegro CL® is a registered trademark of Franz Inc .
72 | LispWorks® is a registered trademark of LispWorks Ltd . All other
73 | trademarks used are owned by their respective owners.
74 |
75 |
78 |
79 |
83 |
84 |
85 |
86 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/flow-layout-unit-tests.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *child-size-2*)
4 | (make-instance 'mock-widget :min-size *child-size-2*)
5 | (make-instance 'mock-widget :min-size *child-size-2*)))
6 | (defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *child-size-2*)
7 | (make-instance 'mock-widget :min-size *child-size-1*)
8 | (make-instance 'mock-widget :min-size *child-size-2*)))
9 |
10 | (define-layout-test flow-layout-test1
11 | -1 -1 60 10
12 | nil
13 | '((0 0 20 10) (20 0 20 10) (40 0 20 10))
14 | #'make-flow-layout *flow-uniform-kids* '(:horizontal))
15 |
16 | (define-layout-test flow-layout-test2
17 | -1 -1 20 30
18 | nil
19 | '((0 0 20 10) (0 10 20 10) (0 20 20 10))
20 | #'make-flow-layout *flow-uniform-kids* '(:vertical))
21 |
22 | (define-layout-test flow-layout-test3
23 | 45 -1 40 20
24 | nil
25 | '((0 0 20 10) (20 0 20 10) (0 10 20 10))
26 | #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))
27 |
28 | (define-layout-test flow-layout-test4
29 | -1 25 40 20
30 | nil
31 | '((0 0 20 10) (0 10 20 10) (20 0 20 10))
32 | #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap))
33 |
34 | (define-layout-test flow-layout-test5
35 | 45 18 40 20
36 | nil
37 | '((0 0 20 10) (20 0 20 10) (0 10 20 10))
38 | #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))
39 |
40 | (define-layout-test flow-layout-test6
41 | 30 25 40 20
42 | nil
43 | '((0 0 20 10) (0 10 20 10) (20 0 20 10))
44 | #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap))
45 |
46 | (define-layout-test flow-layout-test7
47 | -1 -1 68 10
48 | nil
49 | '((0 0 20 10) (24 0 20 10) (48 0 20 10))
50 | #'make-flow-layout *flow-uniform-kids* '(:horizontal) 4)
51 |
52 | (define-layout-test flow-layout-test8
53 | -1 -1 20 38
54 | nil
55 | '((0 0 20 10) (0 14 20 10) (0 28 20 10))
56 | #'make-flow-layout *flow-uniform-kids* '(:vertical) 4)
57 |
58 | (define-layout-test flow-layout-test9
59 | 45 18 44 24
60 | nil
61 | '((0 0 20 10) (24 0 20 10) (0 14 20 10))
62 | #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)
63 |
64 | (define-layout-test flow-layout-test10
65 | 30 25 44 24
66 | nil
67 | '((0 0 20 10) (0 14 20 10) (24 0 20 10))
68 | #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)
69 |
70 | (define-layout-test flow-layout-test11
71 | -1 -1 63 13
72 | nil
73 | '((3 3 20 10) (23 3 20 10) (43 3 20 10))
74 | #'make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)
75 |
76 | (define-layout-test flow-layout-test12
77 | -1 -1 23 33
78 | nil
79 | '((0 0 20 10) (0 10 20 10) (0 20 20 10))
80 | #'make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)
81 |
82 | (define-layout-test flow-layout-test13
83 | -1 -1 75 10
84 | nil
85 | '((0 0 25 10) (25 0 25 10) (50 0 25 10))
86 | #'make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))
87 |
88 | (define-layout-test flow-layout-test14
89 | -1 -1 25 30
90 | nil
91 | '((0 0 25 10) (0 10 25 10) (0 20 25 10))
92 | #'make-flow-layout *flow-mixed-kids* '(:vertical :normalize))
93 |
--------------------------------------------------------------------------------
/src/demos/unblocked/scoreboard-panel.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defparameter *level-label* "Level:")
4 | (defparameter *points-needed-label* "Points Needed:")
5 | (defparameter *score-label* "Score:")
6 |
7 | (defconstant +scoreboard-text-margin+ 2)
8 |
9 | (defvar *text-color* (gfg:make-color :red 237 :green 232 :blue 14))
10 |
11 | (defvar *scoreboard-label-font-data* (gfg:make-font-data :face-name "Tahoma"
12 | :point-size 14
13 | :style '(:bold)))
14 | (defvar *scoreboard-value-font-data* (gfg:make-font-data :face-name "Tahoma"
15 | :point-size 14))
16 |
17 | (defclass scoreboard-panel-events (double-buffered-event-dispatcher)
18 | ((label-font
19 | :accessor label-font-of
20 | :initform nil)
21 | (value-font
22 | :accessor value-font-of
23 | :initform nil)))
24 |
25 | (defmethod dispose ((self scoreboard-panel-events))
26 | (let ((tmp-font (label-font-of self)))
27 | (unless (null tmp-font)
28 | (gfs:dispose tmp-font)
29 | (setf (label-font-of self) nil))
30 | (setf tmp-font (value-font-of self))
31 | (unless (null tmp-font)
32 | (gfs:dispose tmp-font)
33 | (setf (label-font-of self) nil)))
34 | (call-next-method))
35 |
36 | (defun compute-scoreboard-size ()
37 | (let* ((gc (make-instance 'gfg:graphics-context))
38 | (font (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*))
39 | (metrics (gfg:metrics gc font))
40 | (buffer-size (gfs:make-size)))
41 | (unwind-protect
42 | (progn
43 | (setf (gfs:size-width buffer-size) (* (+ (length *points-needed-label*)
44 | 2 ; space between label and value
45 | 9) ; number of value characters
46 | (gfg:average-char-width metrics)))
47 | (setf (gfs:size-height buffer-size) (* (gfg:height metrics) 4)))
48 |
49 | (gfs:dispose font)
50 | (gfs:dispose gc))
51 | buffer-size))
52 |
53 | (defmethod initialize-instance :after ((self scoreboard-panel-events) &key buffer-size)
54 | (declare (ignorable buffer-size))
55 | (gfw:with-graphics-context (gc)
56 | (setf (label-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*))
57 | (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*))))
58 |
59 | (defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value)
60 | (let* ((metrics (gfg:metrics gc label-font))
61 | (text-pnt (gfs:make-point :x +scoreboard-text-margin+ :y (* row (gfg:height metrics))))
62 | (value-text (format nil "~:d" value)))
63 | (setf (gfg:font gc) label-font)
64 | (setf (gfg:foreground-color gc) *text-color*)
65 | (gfg:draw-text gc label-text text-pnt)
66 | (setf (gfg:font gc) value-font)
67 | (setf (gfs:point-x text-pnt) (- (- (gfs:size-width image-size) +scoreboard-text-margin+)
68 | (gfs:size-width (gfg:text-extent gc value-text))))
69 | (gfg:draw-text gc value-text text-pnt)))
70 |
71 | (defmethod update-buffer ((self scoreboard-panel-events))
72 | (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
73 | (label-font (label-font-of self))
74 | (value-font (value-font-of self))
75 | (image-size (gfg:size (image-buffer-of self))))
76 | (unwind-protect
77 | (progn
78 | (clear-buffer self gc)
79 | (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (model-score))
80 | (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (model-level))
81 | (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed)))
82 | (gfs:dispose gc))))
83 |
84 | (defclass scoreboard-panel (gfw:panel) ())
85 |
86 | (defmethod gfw:preferred-size ((self scoreboard-panel) width-hint height-hint)
87 | (declare (ignore width-hint height-hint))
88 | (let ((size (gfg:size (image-buffer-of (gfw:dispatcher self)))))
89 | (gfs:make-size :width (+ (gfs:size-width size) 2) :height (+ (gfs:size-height size) 2))))
90 |
--------------------------------------------------------------------------------
/graphic-forms-uitoolkit.asd:
--------------------------------------------------------------------------------
1 | (defsystem graphic-forms-uitoolkit
2 | :description "Graphic-Forms UI Toolkit"
3 | :depends-on ("cffi"
4 | "lw-compat"
5 | "closer-mop"
6 | "com.gigamonkeys.macro-utilities"
7 | "com.gigamonkeys.binary-data")
8 | :components
9 | ((:file "config")
10 | (:module "src"
11 | :depends-on ("config")
12 | :components
13 | ((:file "packages")
14 | (:module "uitoolkit"
15 | :depends-on ("packages")
16 | :components
17 | ((:module "system"
18 | :serial t
19 | :components
20 | (#+sbcl
21 | (:file "sbcl-callback-hacking")
22 | (:file "system-constants")
23 | (:file "system-classes")
24 | (:file "system-conditions") ; not a very good place
25 | (:file "system-generics")
26 | (:file "system-types")
27 | (:file "datastructs")
28 | (:file "clib")
29 | (:file "comctl32")
30 | (:file "comdlg32")
31 | (:file "shell32")
32 | (:file "gdi32")
33 | (:file "kernel32")
34 | (:file "user32")
35 | (:file "native-object")
36 | (:file "system-utils")
37 | (:file "metrics")))
38 | (:module "graphics"
39 | :depends-on ("system")
40 | :components
41 | ((:file "graphics-constants")
42 | (:file "graphics-classes")
43 | (:file "graphics-generics")
44 | (:file "color"
45 | :depends-on ("graphics-classes"))
46 | (:file "palette"
47 | :depends-on ("graphics-classes"))
48 | (:file "image-data"
49 | :depends-on ("graphics-classes"))
50 | (:file "image"
51 | :depends-on ("graphics-classes" "graphics-generics"))
52 | (:file "icon-bundle"
53 | :depends-on ("graphics-constants" "image"))
54 | (:file "cursor"
55 | :depends-on ("graphics-classes" "image"))
56 | (:file "font-data")
57 | (:file "font")
58 | (:file "graphics-context")
59 | (:module "plugins"
60 | :components
61 | ((:file "graphics-plugin-packages")
62 | #-skip-default-plugin (:module "default"
63 | :serial t
64 | :components
65 | ((:file "file-formats")
66 | (:file "default-data-plugin")))
67 | #+load-imagemagick-plugin (:module "imagemagick"
68 | :serial t
69 | :components
70 | ((:file "magick-core-types")
71 | (:file "magick-core-api")
72 | (:file "magick-data-plugin"
73 | :depends-on ("magick-core-types" "magick-core-api"))))))))
74 | (:module "widgets"
75 | :depends-on ("graphics")
76 | :serial t
77 | :components
78 | ((:file "widget-constants")
79 | (:file "widget-classes")
80 | (:file "layout-classes")
81 | (:file "thread-context") ; require defun in top-level.lisp
82 | (:file "message-generics")
83 | (:file "event-generics")
84 | (:file "layout-generics")
85 | (:file "widget-generics")
86 | (:file "display")
87 | (:file "event-source")
88 | (:file "widget-utils")
89 | (:file "timer")
90 | (:file "item")
91 | (:file "widget")
92 | (:file "color-dialog")
93 | (:file "file-dialog")
94 | (:file "font-dialog")
95 | (:file "control") ; require append-layout-item, subclass-wndproc
96 | (:file "edit")
97 | (:file "label")
98 | (:file "button")
99 | (:file "item-manager")
100 | (:file "list-item") ; require lb-select-item lb-deselect-item
101 | (:file "list-box")
102 | (:file "menu")
103 | (:file "menu-item")
104 | (:file "defmenu")
105 | (:file "progress-bar")
106 | (:file "event") ; require set-window-origin
107 | (:file "scrolling-helper") ; require obtain-top-child
108 | (:file "scrollbar")
109 | (:file "slider")
110 | (:file "status-bar")
111 | (:file "window") ; require arrang-hwnds
112 | (:file "root-window")
113 | (:file "top-level")
114 | (:file "panel")
115 | (:file "dialog")
116 | (:file "layout")
117 | (:file "border-layout")
118 | (:file "heap-layout")
119 | (:file "flow-layout")
120 | (:file "defwindow")))))))))
121 |
122 | (defmethod perform :after ((op load-op) (c (eql (find-system :graphic-forms-uitoolkit))))
123 | (pushnew :graphic-forms *features*))
124 |
--------------------------------------------------------------------------------
/src/uitoolkit/graphics/plugins/default/file-formats.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.graphics.default)
2 |
3 | (eval-when (:compile-toplevel :load-toplevel :execute)
4 | (use-package :com.gigamonkeys.binary-data))
5 |
6 | ;;;
7 | ;;; fundamental binary types used by image definitions
8 | ;;;
9 |
10 | ;; This utility was copied from Peter Seibel's id3v2 package,
11 | ;; renamed to signify that it is for big-endian values.
12 | ;;
13 | (define-binary-type unsigned-integer-be (bytes bits-per-byte)
14 | (:reader (in)
15 | (loop with value = 0
16 | for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
17 | (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
18 | finally (return value)))
19 | (:writer (out value)
20 | (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte
21 | do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))
22 |
23 | ;; This utility is based on the same unsigned-integer binary type,
24 | ;; but this one is for little-endian types.
25 | ;;
26 | (define-binary-type unsigned-integer-le (bytes bits-per-byte)
27 | (:reader (in)
28 | (loop with value = 0
29 | for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do
30 | (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
31 | finally (return value)))
32 | (:writer (out value)
33 | (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte
34 | do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))
35 |
36 | ;;; aliases for single-byte and 32-bit types with names
37 | ;;; matching the GDI docs
38 | ;;;
39 | (define-binary-type BYTE () (unsigned-integer-le :bytes 1 :bits-per-byte 8))
40 | (define-binary-type DWORD () (unsigned-integer-le :bytes 4 :bits-per-byte 8))
41 | (define-binary-type FXPT2DOT30 () (unsigned-integer-le :bytes 4 :bits-per-byte 8))
42 | (define-binary-type LONG () (unsigned-integer-le :bytes 4 :bits-per-byte 8))
43 | (define-binary-type WORD () (unsigned-integer-le :bytes 2 :bits-per-byte 8))
44 |
45 | ;;;
46 | ;;; Win32 GDI Bitmap Formats
47 | ;;;
48 |
49 | (define-binary-class BITMAPFILEHEADER ()
50 | ((bfType WORD)
51 | (bfSize DWORD)
52 | (bfReserved1 WORD)
53 | (bfReserved2 WORD)
54 | (bfOffBits DWORD)))
55 |
56 | (define-binary-class CIEXYZ ()
57 | ((ciexyzX FXPT2DOT30)
58 | (ciexyzY FXPT2DOT30)
59 | (ciexyzZ FXPT2DOT30)))
60 |
61 | (define-binary-class CIEXYZTRIPLE ()
62 | ((ciexyzRed CIEXYZ)
63 | (ciexyzGreen CIEXYZ)
64 | (ciexyzBlue CIEXYZ)))
65 |
66 | (define-tagged-binary-class BASE-BITMAPINFOHEADER ()
67 | ((biSize DWORD)
68 | (biWidth LONG)
69 | (biHeight LONG)
70 | (biPlanes WORD)
71 | (biBitCount WORD)
72 | (biCompression DWORD)
73 | (biSizeImage DWORD)
74 | (biXPelsPerMeter LONG)
75 | (biYPelsPerMeter LONG)
76 | (biClrUsed DWORD)
77 | (biClrImportant DWORD))
78 | (:dispatch
79 | (ecase biSize
80 | (40 'BITMAPINFOHEADER)
81 | (120 'BITMAPV4HEADER)
82 | (124 'BITMAPV5HEADER))))
83 |
84 | (define-binary-class BITMAPINFOHEADER (BASE-BITMAPINFOHEADER) ())
85 |
86 | (define-binary-class BITMAPV4HEADER (BASE-BITMAPINFOHEADER)
87 | ((bv4RedMask DWORD)
88 | (bv4GreenMask DWORD)
89 | (bv4BlueMask DWORD)
90 | (bv4AlphaMask DWORD)
91 | (bv4CSType DWORD)
92 | (bv4Endpoints CIEXYZTRIPLE)
93 | (bv4GammaRed DWORD)
94 | (bv4GammaGreen DWORD)
95 | (bv4GammaBlue DWORD)))
96 |
97 | (define-binary-class BITMAPV5HEADER (BITMAPV4HEADER)
98 | ((bv5Intent DWORD)
99 | (bv5ProfileData DWORD)
100 | (bv5ProfileSize DWORD)
101 | (bv5Reserved DWORD)))
102 |
103 | (define-binary-class RGBQUAD ()
104 | ((rgbBlue BYTE)
105 | (rgbGreen BYTE)
106 | (rgbRed BYTE)
107 | (rgbReserved BYTE)))
108 |
109 | ;;;
110 | ;;; Win32 GDI Icon Formats
111 | ;;;
112 |
113 | (define-binary-class ICONDIR ()
114 | ((idReserved WORD)
115 | (idType WORD)
116 | (idCount WORD))) ; ICONDIRENTRY array read separately
117 |
118 | (define-binary-class ICONDIRENTRY ()
119 | ((ideWidth BYTE)
120 | (ideHeight BYTE)
121 | (ideColorCount BYTE)
122 | (ideReserved BYTE)
123 | (idePlanes WORD)
124 | (ideBitCount WORD)
125 | (ideBytesInRes DWORD)
126 | (ideImageOffset DWORD)))
127 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/scroll-grid-panel.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:graphic-forms.uitoolkit.tests)
2 |
3 | (defconstant +grid-cell-extent+ 50)
4 | (defconstant +grid-half-extent+ 25)
5 |
6 | (defvar *grid-model-size* (gfs:make-size :width 15 :height 10)) ; grid cells
7 |
8 | (defvar *grid-char-size* (gfs:make-size))
9 |
10 | (defclass scroll-grid-panel-events (gfw:event-dispatcher) ())
11 |
12 | (defun select-grid (disp item)
13 | (declare (ignore disp item)))
14 |
15 | (defun make-scroll-grid-panel (parent)
16 | (setf *default-pathname-defaults* (merge-pathnames "uitoolkit/" *gf-tests-dir*))
17 | (let ((panel-size (gfs:make-size :width (1+ (* (gfs:size-width *grid-model-size*) +grid-cell-extent+))
18 | :height (1+ (* (gfs:size-height *grid-model-size*) +grid-cell-extent+))))
19 | (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events)
20 | :parent parent)))
21 | (setf (gfw:maximum-size panel) panel-size
22 | (gfw:minimum-size panel) panel-size)
23 | (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size)))
24 | (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2)
25 | (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2))
26 | (setf (gfw:cursor-of panel)
27 | (make-instance 'gfg:cursor
28 | :file (merge-pathnames "custom.cur")))
29 | panel))
30 |
31 | (defun set-grid-scroll-params (window)
32 | (let* ((disp (gfw:dispatcher window))
33 | (panel (gfw::obtain-top-child window))
34 | (panel-size (gfw:size panel))
35 | (scrollbar (gfw:obtain-horizontal-scrollbar window)))
36 | (setf (gfw:outer-limit scrollbar) (gfs:size-width panel-size))
37 | (setf (gfw:thumb-position scrollbar) 0)
38 | (setf scrollbar (gfw:obtain-vertical-scrollbar window))
39 | (setf (gfw:outer-limit scrollbar) (gfs:size-height panel-size))
40 | (setf (gfw:thumb-position scrollbar) 0)
41 | (setf (gfw:step-increments disp) (gfs:make-size :width 1 :height 1))
42 | (setf (slot-value disp 'gfw::viewport-origin) (gfs:make-point))
43 | (gfw:event-resize disp window (gfw:size window) :restored)))
44 |
45 | (defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect)
46 | (declare (ignore window))
47 | (gfg:clear gc gfg:*color-button-face*)
48 | (setf (gfg:foreground-color gc) gfg:*color-black*
49 | (gfg:pen-style gc) '(:solid :flat-endcap))
50 | (let* ((pnt (gfs:location rect))
51 | (size (gfs:size rect))
52 | (first-row (floor (gfs:point-y pnt) +grid-cell-extent+))
53 | (last-row (floor (+ (gfs:point-y pnt) (gfs:size-height size)) +grid-cell-extent+))
54 | (first-col (floor (gfs:point-x pnt) +grid-cell-extent+))
55 | (last-col (floor (+ (gfs:point-x pnt) (gfs:size-width size)) +grid-cell-extent+))
56 | (lr-pnt (gfs:make-point :x (* +grid-cell-extent+ (gfs:size-width *grid-model-size*))
57 | :y (* +grid-cell-extent+ (gfs:size-height *grid-model-size*)))))
58 | (loop for row from first-row upto last-row
59 | for start-pnt = (gfs:make-point :y (* row +grid-cell-extent+))
60 | do (progn
61 | (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x lr-pnt)
62 | :y (gfs:point-y start-pnt)))
63 | (loop for col from first-col upto last-col
64 | for text = (format nil "~d ~d" col row)
65 | for start-pnt = (gfs:make-point :x (* col +grid-cell-extent+))
66 | for text-pnt = (gfs:make-point :x (+ (* col +grid-cell-extent+)
67 | (- +grid-half-extent+
68 | (gfs:size-width *grid-char-size*)))
69 | :y (+ (* row +grid-cell-extent+)
70 | (- +grid-half-extent+
71 | (gfs:size-height *grid-char-size*))))
72 | do (progn
73 | (if (= row first-row)
74 | (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x start-pnt)
75 | :y (gfs:point-y lr-pnt))))
76 | (gfg:draw-text gc text text-pnt '(:transparent))))))))
77 |
--------------------------------------------------------------------------------
/src/demos/unblocked/tiles-panel.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *unblocked-dir* (merge-pathnames "src/demos/unblocked/" *gf-dir*))
4 |
5 | (eval-when (:compile-toplevel :load-toplevel :execute)
6 | (defconstant +tile-bmp-width+ 24)
7 | (defconstant +tile-bmp-height+ 24))
8 |
9 | (defun tiles->window (pnt)
10 | (let ((xpos (1+ (* (gfs:point-x pnt) +tile-bmp-width+)))
11 | (ypos (1+ (* (- (1- +vert-tile-count+) (gfs:point-y pnt)) +tile-bmp-height+)))
12 | (size (gfw:client-size (get-tiles-panel))))
13 | (if (or (>= xpos (gfs:size-width size)) (>= ypos (gfs:size-height size)))
14 | nil
15 | (gfs:make-point :x xpos :y ypos))))
16 |
17 | (defun window->tiles (pnt)
18 | (let ((xpos (floor (1- (gfs:point-x pnt)) +tile-bmp-width+))
19 | (ypos (- +vert-tile-count+ (1+ (floor (1- (gfs:point-y pnt)) +tile-bmp-height+)))))
20 | (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+))
21 | nil
22 | (gfs:make-point :x xpos :y ypos))))
23 |
24 | (defclass tiles-panel-events (double-buffered-event-dispatcher)
25 | ((tile-image-table
26 | :accessor tile-image-table-of
27 | :initform (make-hash-table :test #'equal))
28 | (shape-kind
29 | :accessor shape-kind-of
30 | :initform 0)
31 | (shape-pnts
32 | :accessor shape-pnts-of
33 | :initform nil)))
34 |
35 | (defun draw-tiles-directly (panel shape-pnts kind)
36 | (gfw:with-graphics-context (gc panel)
37 | (let ((image-table (tile-image-table-of (gfw:dispatcher panel))))
38 | (loop for pnt in shape-pnts
39 | do (let ((image (gethash kind image-table)))
40 | (gfg:draw-image gc image (tiles->window pnt)))))))
41 |
42 | (defmethod dispose ((self tiles-panel-events))
43 | (let ((table (tile-image-table-of self)))
44 | (maphash #'(lambda (kind image)
45 | (declare (ignore kind))
46 | (gfs:dispose image))
47 | table))
48 | (setf (tile-image-table-of self) nil)
49 | (setf (shape-pnts-of self) nil)
50 | (call-next-method))
51 |
52 | (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size)
53 | (declare (ignorable buffer-size))
54 | (let ((*default-pathname-defaults* (parse-namestring *unblocked-dir*))
55 | (table (tile-image-table-of self))
56 | (kind 1))
57 | (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp"
58 | "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp")
59 | do (let ((image (make-instance 'gfg:image)))
60 | (gfg:load image (merge-pathnames filename))
61 | (setf (gethash kind table) image)
62 | (incf kind)))))
63 |
64 | (defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button)
65 | (multiple-value-bind (shape-kind shape-pnts)
66 | (ctrl-start-selection (shape-pnts-of self) panel point button)
67 | (if shape-pnts
68 | (progn
69 | (setf (shape-kind-of self) shape-kind
70 | (shape-pnts-of self) shape-pnts)
71 | (gfw:capture-mouse panel))
72 | (progn
73 | (draw-tiles-directly panel (shape-pnts-of self) (shape-kind-of self))
74 | (setf (shape-kind-of self) 0)
75 | (setf (shape-pnts-of self) nil)))))
76 |
77 | (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button)
78 | (gfw:release-mouse)
79 | (ctrl-finish-selection (shape-pnts-of self) (shape-kind-of self) panel point button)
80 | (setf (shape-kind-of self) 0)
81 | (setf (shape-pnts-of self) nil))
82 |
83 | (defmethod update-buffer ((self tiles-panel-events))
84 | (gfw:with-graphics-context (gc (image-buffer-of self))
85 | (let ((image-table (tile-image-table-of self)))
86 | (clear-buffer self gc)
87 | (map-tiles #'(lambda (pnt kind)
88 | (unless (= kind 0)
89 | (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
90 | (model-tiles)))))
91 |
92 | (defclass tiles-panel (gfw:panel) ())
93 |
94 | (defmethod gfs:dispose ((self tiles-panel))
95 | (dispose (gfw:dispatcher self))
96 | (call-next-method))
97 |
98 | (defmethod gfw:preferred-size ((self tiles-panel) width-hint height-hint)
99 | (declare (ignore width-hint height-hint))
100 | (let ((size (gfg:size (image-buffer-of (gfw:dispatcher self)))))
101 | (gfs:make-size :width (+ (gfs:size-width size) 2) :height (+ (gfs:size-height size) 2))))
102 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/border-layout-unit-tests.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
4 | (make-instance 'mock-widget :min-size *child-size-2*) ; right
5 | (make-instance 'mock-widget :min-size *child-size-1*) ; bottom
6 | (make-instance 'mock-widget :min-size *child-size-2*) ; left
7 | (make-instance 'mock-widget :min-size *child-size-3*))) ; center
8 |
9 | (defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
10 | (make-instance 'mock-widget :min-size *child-size-2*) ; right
11 | (make-instance 'mock-widget :min-size *child-size-1*) ; bottom
12 | (make-instance 'mock-widget :min-size *child-size-2*) ; left
13 | nil))
14 |
15 | (defvar *top-right-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
16 | (make-instance 'mock-widget :min-size *child-size-2*) ; right
17 | nil nil nil))
18 |
19 | (defvar *top-bottom-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
20 | nil
21 | (make-instance 'mock-widget :min-size *child-size-1*) ; bottom
22 | nil nil))
23 |
24 | (defvar *center-border-kid* (list nil nil nil nil
25 | (make-instance 'mock-widget :min-size *child-size-3*)))
26 |
27 | ;;;
28 | ;;; NOTE: the rects to be validated in each test must be specified in the
29 | ;;; the following order: center, top, left, bottom, right
30 | ;;;
31 |
32 | (define-layout-test border-layout-test1
33 | -1 -1 80 50
34 | nil
35 | '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40))
36 | #'make-border-layout *all-border-kids*)
37 |
38 | (define-layout-test border-layout-test2
39 | -1 -1 40 20
40 | nil
41 | '((0 0 40 5) (0 5 20 10) (0 15 40 5) (20 5 20 10))
42 | #'make-border-layout *outer-border-kids*)
43 |
44 | (define-layout-test border-layout-test3
45 | -1 -1 40 40
46 | nil
47 | '((0 0 40 40))
48 | #'make-border-layout *center-border-kid*)
49 |
50 | (define-layout-test border-layout-test4
51 | -1 -1 25 15
52 | nil
53 | '((0 0 25 5) (0 5 20 10))
54 | #'make-border-layout *top-right-border-kids*)
55 |
56 | (define-layout-test border-layout-test5
57 | -1 -1 25 10
58 | nil
59 | '((0 0 25 5) (0 5 25 5))
60 | #'make-border-layout *top-bottom-border-kids*)
61 |
62 | (define-layout-test border-layout-test6
63 | 26 -1 26 50
64 | nil
65 | '((6 5 13 40) (0 0 26 5) (0 5 6 40) (0 45 26 5) (19 5 6 40))
66 | #'make-border-layout *all-border-kids*)
67 |
68 | (define-layout-test border-layout-test7
69 | -1 -1 90 58
70 | nil
71 | '((24 8 40 40) (4 3 80 5) (4 8 20 40) (4 48 80 5) (64 8 20 40))
72 | #'make-border-layout *all-border-kids* 4 3 6 5)
73 |
74 | (defun border-layout-spacing (layout)
75 | (loop for pair in (gfw::data-of layout)
76 | for widget = (first pair)
77 | for key = (first (second pair))
78 | do (case key
79 | ;; note - we leave :center region with default spacing
80 | (:top (setf (gfw:layout-attribute layout widget :leading-spacing) 2))
81 | (:left (setf (gfw:layout-attribute layout widget :trailing-spacing) 3))
82 | (:right (setf (gfw:layout-attribute layout widget :spacing) 4))
83 | (:bottom (setf (gfw:layout-attribute layout widget :center-spacing) 5)))))
84 |
85 | (define-layout-test border-layout-test8
86 | -1 -1 80 50
87 | #'border-layout-spacing
88 | '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40))
89 | #'make-border-layout *all-border-kids*)
90 |
--------------------------------------------------------------------------------
/src/uitoolkit/graphics/graphics-classes.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.graphics)
2 |
3 | (eval-when (:compile-toplevel :load-toplevel :execute)
4 | (defstruct color
5 | (red 0)
6 | (green 0)
7 | (blue 0))
8 |
9 | (defstruct font-data
10 | (char-set 0)
11 | (face-name "")
12 | (point-size 10)
13 | (style nil))
14 |
15 | (defstruct font-metrics
16 | (ascent 0)
17 | (descent 0)
18 | (leading 0)
19 | (avg-char-width 0)
20 | (max-char-width 0))
21 |
22 | (defmacro ascent (metrics)
23 | `(gfg::font-metrics-ascent ,metrics))
24 |
25 | (defmacro descent (metrics)
26 | `(gfg::font-metrics-descent ,metrics))
27 |
28 | (defmacro leading (metrics)
29 | `(gfg::font-metrics-leading ,metrics))
30 |
31 | (defmacro height (metrics)
32 | (let ((tmp-metrics (gensym)))
33 | `(let ((,tmp-metrics ,metrics))
34 | (+ (gfg::font-metrics-ascent ,tmp-metrics)
35 | (gfg::font-metrics-descent ,tmp-metrics)))))
36 |
37 | (defmacro average-char-width (metrics)
38 | `(gfg::font-metrics-avg-char-width ,metrics))
39 |
40 | (defmacro maximum-char-width (metrics)
41 | `(gfg::font-metrics-max-char-width ,metrics))
42 |
43 | (defstruct palette
44 | (red-mask 0)
45 | (green-mask 0)
46 | (blue-mask 0)
47 | (red-shift 0)
48 | (green-shift 0)
49 | (blue-shift 0)
50 | (direct nil)
51 | (table nil)) ; vector of COLOR structs
52 |
53 | (defmacro color-table (data)
54 | `(gfg::palette-table ,data)))
55 |
56 | (defclass cursor (gfs:native-object)
57 | ((shared
58 | :reader sharedp
59 | :initarg :shared
60 | :initform nil))
61 | (:documentation "This class wraps a native cursor handle."))
62 |
63 | (defclass image-data-plugin (gfs:native-object) ()
64 | (:documentation "Base class for image data plugin implementations."))
65 |
66 | (defclass image-data ()
67 | ((data-plugin
68 | :reader data-plugin-of
69 | :initarg :data-plugin
70 | :initform nil))
71 | (:documentation "This class maintains image attributes, color, and pixel data."))
72 |
73 | (defclass font (gfs:native-object) ()
74 | (:documentation "This class wraps a native font handle."))
75 |
76 | (defclass graphics-context (gfs:native-object)
77 | ((dc-destructor
78 | :accessor dc-destructor-of
79 | :initform nil)
80 | (widget-handle
81 | :accessor widget-handle-of
82 | :initform nil)
83 | (surface-size
84 | :accessor surface-size-of
85 | :initarg :surface-size
86 | :initform nil)
87 | (logbrush-style
88 | :accessor logbrush-style-of
89 | :initform gfs::+bs-solid+)
90 | (logbrush-color
91 | :accessor logbrush-color-of
92 | :initform 0)
93 | (logbrush-hatch
94 | :accessor logbrush-hatch-of
95 | :initform gfs::+hs-bdiagonal+)
96 | (miter-limit
97 | :accessor miter-limit
98 | :initform 10.0)
99 | (pen-style
100 | :accessor pen-style
101 | :initform '(:solid))
102 | (pen-width
103 | :accessor pen-width
104 | :initform 1)
105 | (pen-handle
106 | :accessor pen-handle-of
107 | :initform (cffi:null-pointer)))
108 | (:documentation "This class represents the context associated with drawing primitives."))
109 |
110 | (defclass icon-bundle (gfs:native-object) ()
111 | (:documentation "This class encapsulates a set of Win32 icon handles."))
112 |
113 | (defclass image (gfs:native-object)
114 | ((transparency-pixel
115 | :accessor transparency-pixel-of
116 | :initarg :transparency-pixel
117 | :initform nil))
118 | (:documentation "This class encapsulates a Win32 bitmap handle."))
119 |
120 | (defmacro blue-mask (data)
121 | `(gfg::palette-blue-mask ,data))
122 |
123 | (defmacro blue-shift (data)
124 | `(gfg::palette-blue-shift ,data))
125 |
126 | (defmacro direct (data flag)
127 | `(setf (gfg::palette-direct ,data) ,flag))
128 |
129 | (defmacro green-mask (data)
130 | `(gfg::palette-green-mask ,data))
131 |
132 | (defmacro green-shift (data)
133 | `(gfg::palette-green-shift ,data))
134 |
135 | (defmacro red-mask (data)
136 | `(gfg::palette-red-mask ,data))
137 |
138 | (defmacro red-shift (data)
139 | `(gfg::palette-red-shift ,data))
140 |
141 | (defclass pattern (gfs:native-object) ()
142 | (:documentation "This class represents a pattern to be used with a brush."))
143 |
144 | (defclass transform (gfs:native-object) ()
145 | (:documentation "This class specifies how coordinates are transformed."))
146 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/color-dialog.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:graphic-forms.uitoolkit.widgets)
2 |
3 | (eval-when (:compile-toplevel :load-toplevel :execute)
4 | (defconstant +custom-color-array-size+ 16))
5 |
6 | ;;;
7 | ;;; helper functions
8 | ;;;
9 |
10 | (defun obtain-chosen-color (dlg)
11 | (let ((cc-ptr (gfs:handle dlg)))
12 | (if (cffi:null-pointer-p cc-ptr)
13 | (error 'gfs:disposed-error))
14 | (cffi:with-foreign-slots ((gfs::result gfs::ccolors) cc-ptr (:struct gfs::choosecolor))
15 | (values (gfg:rgb->color gfs::result)
16 | (loop for index to (1- +custom-color-array-size+)
17 | collect (gfg:rgb->color (cffi:mem-aref gfs::ccolors 'gfs::colorref index)))))))
18 |
19 | (defmacro with-color-dialog ((owner style color custom-colors &key initial-color initial-custom-colors) &body body)
20 | (let ((dlg (gensym)))
21 | `(let ((,color nil)
22 | (,custom-colors nil)
23 | (,dlg (make-instance 'color-dialog
24 | :initial-custom-colors ,initial-custom-colors
25 | :initial-color ,initial-color
26 | :owner ,owner
27 | :style ,style)))
28 | (unwind-protect
29 | (unless (zerop (show ,dlg t))
30 | (multiple-value-bind (tmp-color tmp-custom)
31 | (obtain-chosen-color ,dlg)
32 | (setf ,color tmp-color
33 | ,custom-colors tmp-custom)
34 | ,@body))
35 | (gfs:dispose ,dlg)))))
36 |
37 | ;;;
38 | ;;; methods
39 | ;;;
40 |
41 | (defmethod compute-style-flags ((self color-dialog) &rest extra-data)
42 | (let ((std-flags (logior gfs::+cc-anycolor+ gfs::+cc-preventfullopen+ (if extra-data gfs::+cc-rgbinit+ 0))))
43 | (loop for sym in (style-of self)
44 | do (ecase sym
45 | (:allow-custom-colors
46 | (setf std-flags (logand std-flags (lognot gfs::+cc-preventfullopen+))))
47 | (:display-solid-only)
48 | (setf std-flags (logior std-flags gfs::+cc-solidcolor+))))
49 | (values std-flags 0)))
50 |
51 | (defmethod gfs:dispose ((self color-dialog))
52 | (let ((cc-ptr (gfs:handle self)))
53 | (unless (cffi:null-pointer-p cc-ptr)
54 | (cffi:with-foreign-slots ((gfs::ccolors) cc-ptr (:struct gfs::choosecolor))
55 | (unless (cffi:null-pointer-p gfs::ccolors)
56 | (cffi:foreign-free gfs::ccolors)))
57 | (cffi:foreign-free cc-ptr)
58 | (setf (slot-value self 'gfs:handle) nil))))
59 |
60 | (defmethod initialize-instance :after ((self color-dialog) &key initial-color initial-custom-colors owner &allow-other-keys)
61 | (if (null owner)
62 | (error 'gfs:toolkit-error :detail ":owner initarg is required"))
63 | (if (gfs:disposed-p owner)
64 | (error 'gfs:disposed-error))
65 | (let ((cc-ptr (cffi:foreign-alloc '(:struct gfs::choosecolor)))
66 | (colors-ptr (cffi:foreign-alloc 'gfs::colorref :count +custom-color-array-size+))
67 | (index 0)
68 | (default-rgb (gfg:color->rgb gfg:*color-black*)))
69 | (loop for color in initial-custom-colors
70 | when (< index +custom-color-array-size+)
71 | do (progn
72 | (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) (gfg:color->rgb color))
73 | (incf index)))
74 | (loop until (>= index +custom-color-array-size+)
75 | do (progn
76 | (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) default-rgb)
77 | (incf index)))
78 | (multiple-value-bind (std-style ex-style)
79 | (compute-style-flags self initial-color)
80 | (declare (ignore ex-style))
81 | (cffi:with-foreign-slots ((gfs::ccsize gfs::howner gfs::hinst gfs::result
82 | gfs::ccolors gfs::flags gfs::cdata gfs::hookfn gfs::templname)
83 | cc-ptr (:struct gfs::choosecolor))
84 | (setf gfs::ccsize (cffi:foreign-type-size '(:struct gfs::choosecolor))
85 | gfs::howner (gfs:handle owner)
86 | gfs::hinst (cffi:null-pointer)
87 | gfs::result (gfg:color->rgb (or initial-color (gfg:make-color)))
88 | gfs::ccolors colors-ptr
89 | gfs::flags std-style
90 | gfs::cdata 0
91 | gfs::hookfn (cffi:null-pointer)
92 | gfs::templname (cffi:null-pointer))))
93 | (setf (slot-value self 'gfs:handle) cc-ptr)))
94 |
95 | (defmethod show ((self color-dialog) flag)
96 | (declare (ignore flag))
97 | (show-common-dialog self #'gfs::choose-color))
98 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/button.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | (defconstant +horizontal-button-text-margin+ 7)
4 | (defconstant +vertical-button-text-margin+ 5)
5 |
6 | ;;;
7 | ;;; methods
8 | ;;;
9 |
10 | (defmethod check ((self button) flag)
11 | (let ((bits (if flag gfs::+bst-checked+ gfs::+bst-unchecked+)))
12 | (gfs::send-message (gfs:handle self) gfs::+bm-setcheck+ bits 0)))
13 |
14 | (defmethod checked-p ((self button))
15 | (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0)))
16 | (= (logand bits gfs::+bst-checked+) gfs::+bst-checked+)))
17 |
18 | (defmethod compute-style-flags ((self button) &rest extra-data)
19 | (declare (ignore extra-data))
20 | (let ((std-flags +default-child-style+)
21 | (style (style-of self)))
22 | (loop for sym in style
23 | do (cond
24 | ;; primary button styles
25 | ;;
26 | ((eq sym :check-box)
27 | (setf std-flags (logior std-flags gfs::+bs-autocheckbox+)))
28 | ((eq sym :default-button)
29 | (setf std-flags (logior std-flags gfs::+bs-defpushbutton+)))
30 | ((or (eq sym :push-button) (eq sym :cancel-button))
31 | (setf std-flags (logior std-flags gfs::+bs-pushbutton+)))
32 | ((eq sym :radio-button)
33 | (setf std-flags (logior std-flags gfs::+bs-autoradiobutton+)))
34 | ((eq sym :toggle-button)
35 | (setf std-flags (logior std-flags gfs::+bs-autocheckbox+ gfs::+bs-pushlike+)))
36 | ((eq sym :tri-state)
37 | (setf std-flags (logior std-flags gfs::+bs-auto3state+)))))
38 | (if (null style)
39 | (logior std-flags gfs::+bs-pushbutton+))
40 | (values std-flags 0)))
41 |
42 | (defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys)
43 | (let ((id (cond
44 | ((find :default-button (style-of self))
45 | gfs::+idok+)
46 | ((find :cancel-button (style-of self))
47 | gfs::+idcancel+)
48 | (t
49 | (increment-widget-id (thread-context))))))
50 | (create-control self parent text gfs::+icc-standard-classes+ id)
51 | (if (test-native-style self gfs::+bs-defpushbutton+)
52 | (gfs::send-message (gfs:handle parent)
53 | gfs::+dm-setdefid+
54 | (cffi:pointer-address (gfs:handle self))
55 | 0))))
56 |
57 | (defmethod preferred-size ((self button) width-hint height-hint)
58 | (let ((text-size (widget-text-size self #'text gfs::+dt-singleline+))
59 | (size (gfs:make-size))
60 | (b-width (* (border-width self) 2))
61 | (need-cb-size (intersection '(:check-box :radio-button :tri-state) (style-of self)))
62 | (cb-size (check-box-size)))
63 | (cond
64 | ((>= width-hint 0)
65 | (setf (gfs:size-width size) width-hint))
66 | (need-cb-size
67 | (setf (gfs:size-width size) (+ +horizontal-button-text-margin+
68 | (gfs:size-width cb-size)
69 | (gfs:size-width text-size))))
70 | (t
71 | (setf (gfs:size-width size) (+ b-width
72 | (* +horizontal-button-text-margin+ 2)
73 | (gfs:size-width text-size)))))
74 | (cond
75 | ((>= height-hint 0)
76 | (setf (gfs:size-height size) height-hint))
77 | (need-cb-size
78 | (setf (gfs:size-height size) (+ (* +vertical-button-text-margin+ 2)
79 | (max (gfs:size-height text-size)
80 | (gfs:size-height cb-size)))))
81 | (t
82 | (setf (gfs:size-height size) (+ b-width
83 | (* +vertical-button-text-margin+ 2)
84 | (gfs:size-height text-size)))))
85 | size))
86 |
87 | (defmethod select ((self button) flag)
88 | (check self flag))
89 |
90 | (defmethod selected-p ((self button))
91 | (checked-p self))
92 |
93 | (defmethod text ((self button))
94 | (get-widget-text self))
95 |
96 | (defmethod (setf text) (str (self button))
97 | (set-widget-text self str))
98 |
99 | (defmethod text-baseline ((self button))
100 | (widget-text-baseline self +vertical-button-text-margin+))
101 |
102 | (defmethod update-native-style ((self button) flags)
103 | (gfs::send-message (gfs:handle self) gfs::+bm-setstyle+ flags 1)
104 | flags)
105 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/scroll-text-panel.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:graphic-forms.uitoolkit.tests)
2 |
3 | (defvar *text-to-draw* "ABCDEFGHIJKLMNOPQRSTUVWXYZ[]0123456789{}")
4 |
5 | (defvar *text-model-size* (gfs:make-size :width 100 :height 100)) ; character cells
6 |
7 | (defvar *text-panel-font-data* (gfg:make-font-data :face-name "Lucida Console"
8 | :point-size 10))
9 |
10 | (defclass scroll-text-panel-events (gfw:event-dispatcher)
11 | ((font
12 | :accessor font-of
13 | :initform nil)))
14 |
15 | (defun draw-text-chunk (gc metrics row first-col last-col)
16 | (let* ((col-diff (1+ (- last-col first-col)))
17 | (text-len (length *text-to-draw*))
18 | (text-start (mod first-col text-len))
19 | (text-end (mod last-col text-len))
20 | (ch-width (gfg:average-char-width metrics))
21 | (ch-height (gfg:height metrics))
22 | (pnt (gfs:make-point :x (* ch-width first-col)
23 | :y (* ch-height row))))
24 | (cond
25 | ((and (<= col-diff text-len) (<= text-start text-end))
26 | (gfg:draw-text gc (subseq *text-to-draw* text-start (1+ text-end)) pnt))
27 | ((or (> col-diff text-len) (> text-start text-end))
28 | (gfg:draw-text gc (subseq *text-to-draw* text-start text-len) pnt)
29 | (incf (gfs:point-x pnt) (* (- text-len text-start) ch-width))
30 | (dotimes (i (floor col-diff text-len))
31 | (gfg:draw-text gc *text-to-draw* pnt)
32 | (incf (gfs:point-x pnt) (* text-len ch-width)))
33 | (gfg:draw-text gc (subseq *text-to-draw* 0 (1+ text-end)) pnt)))))
34 |
35 | (defun make-scroll-text-panel (parent)
36 | (let* ((disp (make-instance 'scroll-text-panel-events))
37 | (panel (make-instance 'gfw:panel :dispatcher disp :parent parent)))
38 | (gfw:with-graphics-context (gc panel)
39 | (let* ((metrics (gfg:metrics gc (font-of disp)))
40 | (panel-size (gfs:make-size :width (* (gfs:size-width *text-model-size*)
41 | (gfg:average-char-width metrics))
42 | :height (* (gfs:size-height *text-model-size*)
43 | (gfg:height metrics)))))
44 | (setf (gfw:maximum-size panel) panel-size
45 | (gfw:minimum-size panel) panel-size)))
46 | panel))
47 |
48 | (defun set-text-scroll-params (window)
49 | (let* ((disp (gfw:dispatcher window))
50 | (panel (gfw::obtain-top-child window))
51 | (panel-size (gfw:size panel)))
52 | (gfw:with-graphics-context (gc panel)
53 | (let ((metrics (gfg:metrics gc (font-of (gfw:dispatcher panel))))
54 | (scrollbar (gfw:obtain-horizontal-scrollbar window)))
55 | (setf (gfw:outer-limit scrollbar) (gfs:size-width panel-size))
56 | (setf (gfw:thumb-position scrollbar) 0)
57 | (setf scrollbar (gfw:obtain-vertical-scrollbar window))
58 | (setf (gfw:outer-limit scrollbar) (gfs:size-height panel-size))
59 | (setf (gfw:thumb-position scrollbar) 0)
60 | (setf (gfw:step-increments disp) (gfs:make-size :width (gfg:average-char-width metrics)
61 | :height (gfg:height metrics)))))
62 | (setf (slot-value disp 'gfw::viewport-origin) (gfs:make-point))
63 | (gfw:event-resize disp window (gfw:size window) :restored)))
64 |
65 | (defmethod initialize-instance ((self scroll-text-panel-events) &key)
66 | (gfw:with-graphics-context (gc)
67 | (setf (font-of self) (make-instance 'gfg:font :gc gc :data *text-panel-font-data*))))
68 |
69 | (defmethod gfw:event-dispose ((disp scroll-text-panel-events) (panel gfw:panel))
70 | (let ((font (font-of disp)))
71 | (if font
72 | (gfs:dispose font))
73 | (setf (font-of disp) nil)))
74 |
75 | (defmethod gfw:event-paint ((disp scroll-text-panel-events) window gc rect)
76 | (declare (ignore window))
77 | (gfg:clear gc gfg:*color-white*)
78 | (setf (gfg:foreground-color gc) gfg:*color-black*
79 | (gfg:font gc) (font-of disp))
80 | (let* ((metrics (gfg:metrics gc (font-of disp)))
81 | (pnt (gfs:location rect))
82 | (size (gfs:size rect))
83 | (first-row (floor (gfs:point-y pnt) (gfg:height metrics)))
84 | (last-row (floor (+ (gfs:point-y pnt) (gfs:size-height size)) (gfg:height metrics)))
85 | (first-col (floor (gfs:point-x pnt) (gfg:average-char-width metrics)))
86 | (last-col (floor (+ (gfs:point-x pnt) (gfs:size-width size)) (gfg:average-char-width metrics))))
87 | (setf (gfs:point-x pnt) (* first-col (gfg:average-char-width metrics)))
88 | (loop for row from first-row upto last-row
89 | do (draw-text-chunk gc metrics row first-col last-col))))
90 |
91 |
--------------------------------------------------------------------------------
/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.graphics.imagemagick)
2 |
3 | (defclass magick-data-plugin (gfg:image-data-plugin) ()
4 | (:documentation "ImageMagick library plugin for the graphics package."))
5 |
6 | (defun loader (path)
7 | (unless *magick-initialized*
8 | (initialize-magick (cffi:null-pointer))
9 | (setf *magick-initialized* t))
10 | (if (gethash (string-downcase (pathname-type path)) gfg:*image-file-types*)
11 | (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex)
12 | (let ((images-ptr (read-image info ex)))
13 | (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
14 | (error 'gfs:toolkit-error :detail (format nil
15 | "exception reason: ~s"
16 | (cffi:foreign-slot-value ex 'exception-info 'reason))))
17 | (loop for ptr = images-ptr then (get-next-image-in-list ptr)
18 | while (and ptr (not (gfs:null-handle-p ptr)))
19 | collect (make-instance 'magick-data-plugin :handle ptr))))
20 | nil))
21 |
22 | (push #'loader gfg::*image-plugins*)
23 |
24 | (defmethod gfg:depth ((self magick-data-plugin))
25 | ;; FIXME: further debugging of non-true-color format required throughout
26 | ;; this plugin, reverting back to assumption of 32bpp for now.
27 | #|
28 | (let ((handle (gfs:handle self)))
29 | (if (null handle)
30 | (error 'gfs:disposed-error))
31 | (cffi:foreign-slot-value handle 'magick-image 'depth)))
32 | |#
33 | 32)
34 |
35 | (defmethod gfs:dispose ((self magick-data-plugin))
36 | (let ((victim (gfs:handle self)))
37 | (unless (or (null victim) (cffi:null-pointer-p victim))
38 | (destroy-image victim)))
39 | (setf (slot-value self 'gfs:handle) nil))
40 |
41 | (defmethod gfg:copy-pixels ((self magick-data-plugin) pixels-pointer)
42 | (let* ((handle (gfs:handle self))
43 | (im-size (gfg:size self))
44 | (pixel-count (* (gfs:size-width im-size) (gfs:size-height im-size)))
45 | (pix-tmp (get-image-pixels handle 0 0 (gfs:size-width im-size) (gfs:size-height im-size))))
46 | (dotimes (i pixel-count)
47 | (cffi:with-foreign-slots ((blue green red reserved)
48 | (cffi:mem-aptr pix-tmp '(:struct pixel-packet) i) (:struct pixel-packet))
49 | (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
50 | (cffi:mem-aref pixels-pointer '(:struct gfs::rgbquad) i) (:struct gfs::rgbquad))
51 | (setf gfs::rgbreserved 0
52 | gfs::rgbred (scale-quantum-to-byte red)
53 | gfs::rgbgreen (scale-quantum-to-byte green)
54 | gfs::rgbblue (scale-quantum-to-byte blue))))))
55 | pixels-pointer)
56 |
57 | (defmethod gfg:size ((self magick-data-plugin))
58 | (let ((handle (gfs:handle self))
59 | (size (gfs:make-size)))
60 | (if (or (null handle) (cffi:null-pointer-p handle))
61 | (error 'gfs:disposed-error))
62 | (cffi:with-foreign-slots ((rows columns) handle magick-image)
63 | (setf (gfs:size-height size) rows)
64 | (setf (gfs:size-width size) columns))
65 | size))
66 |
67 | (defmethod (setf gfg:size) (size (self magick-data-plugin))
68 | (let ((handle (gfs:handle self))
69 | (new-handle (cffi:null-pointer))
70 | (ex (acquire-exception-info)))
71 | (if (or (null handle) (cffi:null-pointer-p handle))
72 | (error 'gfs:disposed-error))
73 | (unwind-protect
74 | (progn
75 | (setf new-handle (resize-image handle
76 | (gfs:size-width size)
77 | (gfs:size-height size)
78 | (cffi:foreign-enum-value 'filter-types :lanczos)
79 | 1.0 ex))
80 | (if (gfs:null-handle-p new-handle)
81 | (error 'gfs:toolkit-error :detail (format nil
82 | "could not resize: ~a"
83 | (cffi:foreign-slot-value ex
84 | 'exception-info
85 | 'reason))))
86 | (setf (slot-value self 'gfs:handle) new-handle)
87 | (destroy-image handle))
88 | (destroy-exception-info ex)))
89 | size)
90 |
91 | (defmethod cffi:translate-to-foreign ((lisp-obj magick-data-plugin)
92 | (type gfs::bitmapinfo-pointer-type))
93 | ;; FIXME: assume true-color for now
94 | ;;
95 | (gfg::make-initial-bitmapinfo lisp-obj))
96 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/item-manager.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (defun make-items-array (&optional (count 7))
8 | (make-array count :fill-pointer 0 :adjustable t))
9 |
10 | (defun call-text-provider (manager thing)
11 | (let ((func (text-provider-of manager))
12 | (*print-readably* nil))
13 | (cond
14 | ((stringp thing)
15 | thing)
16 | ((null func)
17 | (format nil "~a" thing))
18 | (t
19 | (funcall func thing)))))
20 |
21 | (defun copy-item-sequence (handle new-items item-class)
22 | (let ((tc (thread-context))
23 | (replacements (make-items-array)))
24 | (cond
25 | ((null new-items)
26 | replacements)
27 | ((vectorp new-items)
28 | (dotimes (i (length new-items))
29 | (let ((item (elt new-items i)))
30 | (if (typep item item-class)
31 | (progn
32 | (setf (slot-value item 'gfs:handle) handle)
33 | (vector-push-extend item replacements))
34 | (let ((tmp (make-instance item-class :handle handle :data item)))
35 | (put-item tc tmp)
36 | (vector-push-extend tmp replacements)))))
37 | replacements)
38 | ((listp new-items)
39 | (loop for item in new-items
40 | do (if (typep item item-class)
41 | (progn
42 | (setf (slot-value item 'gfs:handle) handle)
43 | (vector-push-extend item replacements))
44 | (let ((tmp (make-instance item-class :handle handle :data item)))
45 | (put-item tc tmp)
46 | (vector-push-extend tmp replacements))))
47 | replacements)
48 | (t
49 | (error 'gfs:toolkit-error :detail (format nil "invalid data structure type: ~a" new-items))))))
50 |
51 | ;;;
52 | ;;; methods
53 | ;;;
54 |
55 | (defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled classname)
56 | (declare (ignore thing disp checked disabled classname))
57 | (if (gfs:disposed-p self)
58 | (error 'gfs:disposed-error)))
59 |
60 | (defmethod delete-all ((self item-manager))
61 | (let ((items (slot-value self 'items)))
62 | (dotimes (i (length items))
63 | (gfs:dispose (aref items i))))
64 | (setf (slot-value self 'items) (make-items-array)))
65 |
66 | (defmethod delete-item :before ((self item-manager) index)
67 | (declare (ignore index))
68 | (if (gfs:disposed-p self)
69 | (error 'gfs:disposed-error)))
70 |
71 | (defmethod delete-item ((self item-manager) index)
72 | (if (or (< index 0) (>= index (length (slot-value self 'items))))
73 | (error 'gfs:toolkit-error :detail "invalid item index"))
74 | (multiple-value-bind (new-items victim)
75 | (gfs::remove-element (slot-value self 'items) index #'make-items-array)
76 | (setf (slot-value self 'items) new-items)
77 | (gfs:dispose victim)))
78 |
79 | (defmethod delete-selection :before ((self item-manager))
80 | (if (gfs:disposed-p self)
81 | (error 'gfs:disposed-error)))
82 |
83 | (defmethod delete-span :before ((self item-manager) (sp gfs:span))
84 | (declare (ignore sp))
85 | (if (gfs:disposed-p self)
86 | (error 'gfs:disposed-error)))
87 |
88 | (defmethod gfs:dispose ((self item-manager))
89 | (let ((items (slot-value self 'items))
90 | (tc (thread-context)))
91 | (dotimes (i (length items))
92 | (delete-tc-item tc (elt items i)))))
93 |
94 | (defmethod item-count :before ((self item-manager))
95 | (if (gfs:disposed-p self)
96 | (error 'gfs:disposed-error)))
97 |
98 | (defmethod item-count ((self item-manager))
99 | (length (slot-value self 'items)))
100 |
101 | (defmethod item-index :before ((self item-manager) (it item))
102 | (declare (ignore it))
103 | (if (gfs:disposed-p self)
104 | (error 'gfs:disposed-error)))
105 |
106 | (defmethod item-index ((self item-manager) (it item))
107 | (let ((pos (position it (slot-value self 'items) :test #'items-equal)))
108 | (if (null pos)
109 | (return-from item-index 0))
110 | pos))
111 |
112 | (defmethod items-of ((self item-manager))
113 | (coerce (slot-value self 'items) 'list))
114 |
115 | (defmethod selected-items :before ((self item-manager))
116 | (if (gfs:disposed-p self)
117 | (error 'gfs:disposed-error)))
118 |
119 | (defmethod (setf selected-items) :before (items (self item-manager))
120 | (declare (ignore items))
121 | (if (gfs:disposed-p self)
122 | (error 'gfs:disposed-error)))
123 |
124 | (defmethod update-from-items :before ((self item-manager))
125 | (if (gfs:disposed-p self)
126 | (error 'gfs:disposed-error)))
127 |
--------------------------------------------------------------------------------
/src/demos/unblocked/unblocked-window.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (defconstant +spacing+ 4)
4 | (defconstant +margin+ 4)
5 |
6 | (defvar *scoreboard-panel* nil)
7 | (defvar *tiles-panel* nil)
8 | (defvar *unblocked-win* nil)
9 |
10 | (defun get-unblocked-win ()
11 | *unblocked-win*)
12 |
13 | (defun get-tiles-panel ()
14 | *tiles-panel*)
15 |
16 | (defun get-scoreboard-panel ()
17 | *scoreboard-panel*)
18 |
19 | (defun new-unblocked (disp item)
20 | (declare (ignore disp item))
21 | (ctrl-start-game))
22 |
23 | (defun restart-unblocked (disp item)
24 | (declare (ignore disp item))
25 | (ctrl-restart-game))
26 |
27 | (defun update-panel (panel)
28 | (update-buffer (gfw:dispatcher panel))
29 | (gfw:redraw panel))
30 |
31 | (defun update-status-bar (msg)
32 | (if *unblocked-win*
33 | (setf (gfw:text (gfw:status-bar-of *unblocked-win*)) msg)))
34 |
35 | (defun reveal-unblocked (disp item)
36 | (declare (ignore disp item))
37 | (ctrl-reveal-move))
38 |
39 | (defun quit-unblocked (disp item)
40 | (declare (ignore disp item))
41 | (setf *scoreboard-panel* nil)
42 | (setf *tiles-panel* nil)
43 | (gfs:dispose *unblocked-win*)
44 | (setf *unblocked-win* nil)
45 | (gfw:shutdown 0))
46 |
47 | (defclass unblocked-win-events (gfw:event-dispatcher) ())
48 |
49 | (defmethod gfw:event-close ((disp unblocked-win-events) window)
50 | (declare (ignore window))
51 | (quit-unblocked disp nil))
52 |
53 | (defmethod gfw:event-timer ((disp unblocked-win-events) timer)
54 | (declare (ignore timer))
55 | (update-panel *tiles-panel*))
56 |
57 | (defun about-unblocked (disp item)
58 | (declare (ignore disp item))
59 | (let* ((*default-pathname-defaults* (parse-namestring *unblocked-dir*))
60 | (image-path (merge-pathnames "about.bmp")))
61 | (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.9")))
62 |
63 | (defun unblocked-startup ()
64 | (let ((menubar (gfw:defmenu ((:item "&File"
65 | :submenu ((:item "&New" :callback #'new-unblocked)
66 | (:item "&Restart" :callback #'restart-unblocked)
67 | (:item "Reveal &Move" :callback #'reveal-unblocked)
68 | (:item "" :separator)
69 | (:item "E&xit" :callback #'quit-unblocked)))
70 | (:item "&Help"
71 | :submenu ((:item "&About UnBlocked" :callback #'about-unblocked))))))
72 | (scoreboard-buffer-size (compute-scoreboard-size))
73 | (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+)
74 | 2)
75 | :height (+ (* +vert-tile-count+ +tile-bmp-height+)
76 | 2))))
77 | (setf *unblocked-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'unblocked-win-events)
78 | :layout (make-instance 'gfw:flow-layout
79 | :style :vertical
80 | :spacing +spacing+
81 | :margins +margin+)
82 | :style '(:fixed-size :workspace :status-bar)))
83 | (setf (gfw:menu-bar *unblocked-win*) menubar)
84 | (setf *scoreboard-panel* (make-instance 'scoreboard-panel
85 | :parent *unblocked-win*
86 | :style '(:border)
87 | :dispatcher (make-instance 'scoreboard-panel-events
88 | :buffer-size scoreboard-buffer-size)))
89 | (setf *tiles-panel* (make-instance 'tiles-panel
90 | :parent *unblocked-win*
91 | :style '(:border)
92 | :dispatcher (make-instance 'tiles-panel-events
93 | :buffer-size tile-buffer-size)))
94 | (setf (gfw:text *unblocked-win*) "UnBlocked")
95 |
96 | (gfw:pack *unblocked-win*)
97 |
98 | (new-unblocked nil nil)
99 | (let ((*default-pathname-defaults* (parse-namestring *unblocked-dir*)))
100 | (setf (gfw:image *unblocked-win*)
101 | (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico"))))
102 | (gfw:show *unblocked-win* t)))
103 |
104 | (defun unblocked ()
105 | (gfw:startup "UnBlocked" #'unblocked-startup))
106 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/status-bar.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (declaim (inline stb-is-simple))
8 | (defun stb-is-simple (status-bar)
9 | (/= (gfs::send-message (gfs:handle status-bar) gfs::+sb-issimple+ 0 0) 0))
10 |
11 | (defun stb-get-border-widths (status-bar)
12 | "Returns a list of integer widths (0: horz border, 1: vert border, 2: internal)"
13 | (cffi:with-foreign-pointer (array (* (cffi:foreign-type-size :int) 3))
14 | (when (zerop (gfs::send-message (gfs:handle status-bar)
15 | gfs::+sb-getborders+
16 | 0
17 | (cffi:pointer-address array)))
18 | (warn 'gfs:win32-warning :detail "SB_GETBORDERS message failed")
19 | (return-from stb-get-border-widths (list 0 0 0)))
20 | (loop for index from 0 to 2
21 | collect (cffi:mem-aref array :int index))))
22 |
23 | (defun stb-set-min-height (status-bar height)
24 | (let ((widths (stb-get-border-widths status-bar))
25 | (hstatus (gfs:handle status-bar)))
26 | (when (zerop (gfs::send-message hstatus
27 | gfs::+sb-setminheight+
28 | (+ height (* (second widths) 2))
29 | 0))
30 | (warn 'gfs:win32-warning :detail "SB_SETMINHEIGHT message failed")
31 | (return-from stb-set-min-height nil))
32 | (gfs::send-message hstatus gfs::+wm-size+ 0 0))
33 | height)
34 |
35 | (defun stb-set-text (status-bar str &optional item-index)
36 | (let ((part-id (if (stb-is-simple status-bar) gfs::+sb-simpleid+ item-index)))
37 | (cffi:with-foreign-string (str-ptr str)
38 | (if (zerop (gfs::send-message (gfs:handle status-bar)
39 | gfs::+sb-settext+
40 | part-id
41 | (cffi:pointer-address str-ptr)))
42 | (warn 'gfs:win32-warning :detail "SB_SETTEXT message failed"))))
43 | str)
44 |
45 | (defun stb-get-text-properties (status-bar item-index)
46 | "Returns the text length and operation type of the status bar part at item-index."
47 | (let ((hresult (gfs::send-message (gfs:handle status-bar)
48 | gfs::+sb-gettextlength+
49 | item-index
50 | 0)))
51 | (values (gfs::lparam-low-word hresult) (gfs::lparam-high-word hresult))))
52 |
53 | (defun stb-get-text (status-bar item-index)
54 | (multiple-value-bind (length op-type)
55 | (stb-get-text-properties status-bar item-index)
56 | (declare (ignore op-type))
57 | (if (zerop length)
58 | ""
59 | (cffi:with-foreign-pointer-as-string (str-ptr (1+ length))
60 | (gfs::send-message (gfs:handle status-bar)
61 | gfs::+sb-gettext+
62 | item-index
63 | (cffi:pointer-address str-ptr))))))
64 |
65 | ;;;
66 | ;;; methods
67 | ;;;
68 |
69 | (defmethod border-width ((self status-bar))
70 | (let ((widths (stb-get-border-widths self)))
71 | (max (first widths) (second widths))))
72 |
73 | (defmethod compute-style-flags ((self status-bar) &rest extra-data)
74 | (let ((extra-bits (if (first extra-data) 0 gfs::+sbars-sizegrip+)))
75 | (values (logior gfs::+ws-child+ gfs::+ws-visible+ extra-bits) 0)))
76 |
77 | (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys)
78 | (let ((hctl (create-control self
79 | parent
80 | ""
81 | gfs::+icc-win95-classes+
82 | nil
83 | (find :fixed-size (style-of parent)))))
84 | (gfs::send-message hctl gfs::+sb-simple+ 1 0))
85 | (let ((widths (stb-get-border-widths self)))
86 | (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths)))))
87 |
88 | (defmethod preferred-size ((self status-bar) width-hint height-hint)
89 | (declare (ignore height-hint))
90 | (if (gfs:disposed-p self)
91 | (error 'gfs:disposed-error))
92 | (let ((tmp-size (if (data-of (layout-of self))
93 | (compute-size (layout-of self) self width-hint -1)
94 | (widget-text-size self
95 | (lambda (widget)
96 | (declare (ignore widget))
97 | "X")
98 | gfs::+dt-singleline+)))
99 | (widths (stb-get-border-widths self)))
100 | (gfs:make-size :width 0
101 | :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1))))
102 |
103 | (defmethod text ((sbar status-bar))
104 | (stb-get-text sbar 0))
105 |
106 | (defmethod (setf text) (str (sbar status-bar))
107 | (stb-set-text sbar str))
108 |
--------------------------------------------------------------------------------
/src/uitoolkit/graphics/font-data.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.graphics)
2 |
3 | (defun pntsize->lfheight (hdc pntsize)
4 | (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+)))
5 | (- (floor (+ (/ (* pntsize log-height) 72) 0.5)))))
6 |
7 | (defun lfheight->pntsize (hdc lfheight)
8 | (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+)))
9 | (floor (* (+ (- lfheight) 0.5) 72) log-height)))
10 |
11 | (defun style->logfont (style lf-ptr)
12 | (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline
13 | gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily)
14 | lf-ptr (:struct gfs::logfont))
15 | (setf gfs::lfweight (if (find :bold style) gfs::+fw-bold+ gfs::+fw-normal+))
16 | (setf gfs::lfitalic (if (find :italic style) 1 0))
17 | (setf gfs::lfunderline (if (find :underline style) 1 0))
18 | (setf gfs::lfstrikeout (if (find :strikeout style) 1 0))
19 | (setf gfs::lfoutprec (cond
20 | ((find :truetype-only style) gfs::+out-tt-only-precis+)
21 | ((find :outline style) gfs::+out-outline-precis+)
22 | (t gfs::+out-default-precis+)))
23 | (setf gfs::lfpitchandfamily (cond
24 | ((find :fixed style) gfs::+fixed-pitch+)
25 | ((find :variable style) gfs::+variable-pitch+)
26 | (t gfs::+default-pitch+)))))
27 |
28 | (defun logfont->style (lf-ptr)
29 | (let ((style nil))
30 | (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline
31 | gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily)
32 | lf-ptr (:struct gfs::logfont))
33 | (if (= gfs::lfweight gfs::+fw-bold+)
34 | (push :bold style))
35 | (unless (zerop gfs::lfitalic)
36 | (push :italic style))
37 | (unless (zerop gfs::lfunderline)
38 | (push :underline style))
39 | (unless (zerop gfs::lfstrikeout)
40 | (push :strikeout style))
41 | (case gfs::lfoutprec
42 | (#.gfs::+out-tt-only-precis+ (push :truetype-only style))
43 | (#.gfs::+out-outline-precis+ (push :outline style)))
44 | (case gfs::lfpitchandfamily
45 | (#.gfs::+fixed-pitch+ (push :fixed style))
46 | (#.gfs::+variable-pitch+ (push :variable style))))
47 | style))
48 |
49 | (defun data->logfont (hdc data)
50 | (let ((lf-ptr (cffi:foreign-alloc '(:struct gfs::logfont)))
51 | (style (font-data-style data)))
52 | (gfs:zero-mem lf-ptr (:struct gfs::logfont))
53 | (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr (:struct gfs::logfont))
54 | (setf gfs::lfheight (pntsize->lfheight hdc (font-data-point-size data)))
55 | (setf gfs::lfcharset (font-data-char-set data))
56 | (style->logfont style lf-ptr)
57 | (cffi:with-foreign-string (str (font-data-face-name data))
58 | (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr '(:struct gfs::logfont) 'gfs::lffacename)))
59 | (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+))
60 | (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0))))
61 | lf-ptr))
62 |
63 | (defun logfont->data (hdc lf-ptr)
64 | (let ((char-set 0)
65 | (face-name "")
66 | (point-size 0)
67 | (style nil))
68 | (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr (:struct gfs::logfont))
69 | (setf point-size (lfheight->pntsize hdc gfs::lfheight))
70 | (setf char-set gfs::lfcharset)
71 | (setf style (logfont->style lf-ptr))
72 | (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr '(:struct gfs::logfont) 'gfs::lffacename)))
73 | (setf face-name (cffi:foreign-string-to-lisp lffacename-ptr))))
74 | (gfg:make-font-data :char-set char-set
75 | :face-name face-name
76 | :point-size point-size
77 | :style style)))
78 |
79 | (defun data->font (hdc data)
80 | (let ((hfont (cffi:null-pointer)))
81 | (setf hfont (gfs::create-font-indirect (data->logfont hdc data)))
82 | (if (gfs:null-handle-p hfont)
83 | (error 'gfs:win32-error :detail "create-font-indirect failed"))
84 | hfont))
85 |
86 | (defun font->data (hdc hfont)
87 | (cffi:with-foreign-object (lf-ptr '(:struct gfs::logfont))
88 | (gfs:zero-mem lf-ptr (:struct gfs::logfont))
89 | (if (zerop (gfs::get-object hfont (cffi:foreign-type-size '(:struct gfs::logfont)) lf-ptr))
90 | (error 'gfs:win32-error :detail "get-object failed"))
91 | (logfont->data hdc lf-ptr)))
92 |
93 | (defmethod print-object ((self font-data) stream)
94 | (print-unreadable-object (self stream :type t)
95 | (format stream "face name: ~a " (font-data-face-name self))
96 | (format stream "point size: ~d " (font-data-point-size self))
97 | (format stream "style: ~a " (font-data-style self))
98 | (format stream "char-set: ~d" (font-data-char-set self))))
99 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/font-dialog.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | (defconstant +font-dialog-flags+ (logior gfs::+cf-effects+ gfs::+cf-inittologfontstruct+))
4 |
5 | ;;;
6 | ;;; helper functions
7 | ;;;
8 |
9 | (defun obtain-chosen-font (dlg gc)
10 | (if (or (gfs:disposed-p dlg) (gfs:disposed-p gc))
11 | (error 'gfs:disposed-error))
12 | (cffi:with-foreign-slots ((gfs::logfont gfs::color) (gfs:handle dlg) (:struct gfs::choosefont))
13 | (values (make-instance 'gfg:font :handle (gfs::create-font-indirect gfs::logfont))
14 | (gfg::rgb->color gfs::color))))
15 |
16 | (defun lookup-default-font ()
17 | (let ((lf-ptr (cffi:foreign-alloc '(:struct gfs::logfont))))
18 | (gfs:zero-mem lf-ptr (:struct gfs::logfont))
19 | (gfs::get-object (gfs::get-stock-object gfs::+system-font+)
20 | (cffi:foreign-type-size '(:struct gfs::logfont))
21 | lf-ptr)
22 | lf-ptr))
23 |
24 | (defmacro with-font-dialog ((owner style font color &key gc initial-color initial-font) &body body)
25 | (let ((dlg (gensym)))
26 | `(let ((,font nil)
27 | (,color nil)
28 | (,dlg (make-instance 'font-dialog
29 | :gc ,gc
30 | :initial-color ,initial-color
31 | :initial-font ,initial-font
32 | :owner ,owner
33 | :style ,style)))
34 | (unwind-protect
35 | (unless (zerop (show ,dlg t))
36 | (multiple-value-bind (f c) (obtain-chosen-font ,dlg ,gc)
37 | (setf ,font f)
38 | (setf ,color c))
39 | ,@body)
40 | (gfs:dispose ,dlg)))))
41 |
42 | ;;;
43 | ;;; methods
44 | ;;;
45 |
46 | (defmethod compute-style-flags ((self font-dialog) &rest extra-data)
47 | (declare (ignore extra-data))
48 | (let ((std-flags (logior gfs::+cf-both+ +font-dialog-flags+)))
49 | (loop for sym in (style-of self)
50 | do (ecase sym
51 | ;; primary styles
52 | ;;
53 | (:all-fonts
54 | (setf std-flags (logior gfs::+cf-both+ +font-dialog-flags+)))
55 | (:fixed-pitch-fonts
56 | (setf std-flags (logior gfs::+cf-fixedpitchonly+ +font-dialog-flags+)))
57 | (:printer-fonts
58 | (setf std-flags (logior gfs::+cf-printerfonts+ +font-dialog-flags+)))
59 | (:screen-fonts
60 | (setf std-flags (logior gfs::+cf-screenfonts+ +font-dialog-flags+)))
61 | (:truetype-fonts
62 | (setf std-flags (logior gfs::+cf-ttonly+ +font-dialog-flags+)))
63 | (:wsyiwyg-fonts
64 | (setf std-flags (logior gfs::+cf-both+
65 | gfs::+cf-scalableonly+
66 | gfs::+cf-wysiwyg+
67 | +font-dialog-flags+)))
68 |
69 | ;; styles that can be combined
70 | ;;
71 | (:no-effects
72 | (setf std-flags (logand std-flags (lognot gfs::+cf-effects+))))))
73 | (values std-flags 0)))
74 |
75 | (defmethod gfs:dispose ((self font-dialog))
76 | (let ((cf-ptr (gfs:handle self)))
77 | (unless (cffi:null-pointer-p cf-ptr)
78 | (cffi:with-foreign-slots ((gfs::logfont) cf-ptr (:struct gfs::choosefont))
79 | (unless (cffi:null-pointer-p gfs::logfont)
80 | (cffi:foreign-free gfs::logfont)))
81 | (cffi:foreign-free cf-ptr)))
82 | (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
83 |
84 | (defmethod initialize-instance :after ((self font-dialog) &key gc initial-color initial-font owner &allow-other-keys)
85 | (if (null gc)
86 | (error 'gfs:toolkit-error :detail ":gc initarg is required"))
87 | (if (null owner)
88 | (error 'gfs:toolkit-error :detail ":owner initarg is required"))
89 | (if (gfs:disposed-p owner)
90 | (error 'gfs:disposed-error))
91 | (let ((cf-ptr (cffi:foreign-alloc '(:struct gfs::choosefont)))
92 | (lf-ptr (if initial-font
93 | (gfg::data->logfont (gfs:handle gc) (gfg:data-object initial-font gc))
94 | (lookup-default-font))))
95 | (multiple-value-bind (std-style ex-style) (compute-style-flags self)
96 | (declare (ignore ex-style))
97 | (cffi:with-foreign-slots ((gfs::structsize gfs::howner gfs::hdc gfs::logfont
98 | gfs::flags gfs::color)
99 | cf-ptr (:struct gfs::choosefont))
100 | (setf gfs::structsize (cffi:foreign-type-size '(:struct gfs::choosefont))
101 | gfs::howner (gfs:handle owner)
102 | gfs::hdc (gfs:handle gc)
103 | gfs::logfont lf-ptr
104 | gfs::flags std-style
105 | gfs::color (if initial-color (gfg:color->rgb initial-color) 0))))
106 | (setf (slot-value self 'gfs:handle) cf-ptr)))
107 |
108 | (defmethod show ((self font-dialog) flag)
109 | (declare (ignore flag))
110 | (show-common-dialog self #'gfs::choose-font))
111 |
--------------------------------------------------------------------------------
/src/tests/uitoolkit/icon-bundle-unit-tests.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.tests)
2 |
3 | (define-test bmp-file-icon-bundle-test
4 | (let ((bundle (make-instance 'gfg:icon-bundle :file (merge-pathnames "uitoolkit/happy.bmp" *gf-tests-dir*)))
5 | (size (gfs:make-size :width 32 :height 32)))
6 | (unwind-protect
7 | (progn
8 | (assert-equal 1 (gfg:icon-bundle-length bundle))
9 | (validate-image (gfg:icon-image-ref bundle 0) size 8)
10 | (validate-image (gfg:icon-image-ref bundle :large) size 8)
11 | (validate-image (gfg:icon-image-ref bundle :small) size 8))
12 | (gfs:dispose bundle))
13 | (assert-true (gfs:disposed-p bundle))))
14 |
15 | (define-test images-icon-bundle-test
16 | (let ((bundle (make-instance 'gfg:icon-bundle
17 | :images (list (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/happy.bmp" *gf-tests-dir*))
18 | (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/blackwhite20x16.bmp" *gf-tests-dir*))
19 | (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/truecolor16x16.bmp" *gf-tests-dir*)))))
20 | (happy-size (gfs:make-size :width 32 :height 32))
21 | (bw-size (gfs:make-size :width 20 :height 16))
22 | (tc-size (gfs:make-size :width 16 :height 16)))
23 | (unwind-protect
24 | (progn
25 | (assert-equal 3 (gfg:icon-bundle-length bundle))
26 | (validate-image (gfg:icon-image-ref bundle 0) happy-size 8)
27 | (validate-image (gfg:icon-image-ref bundle 1) bw-size 8)
28 | (validate-image (gfg:icon-image-ref bundle 2) tc-size 16000000)
29 | (validate-image (gfg:icon-image-ref bundle :small) tc-size 8)
30 | (validate-image (gfg:icon-image-ref bundle :large) happy-size 8))
31 | (gfs:dispose bundle))
32 | (assert-true (gfs:disposed-p bundle))))
33 |
34 | (define-test push-images-icon-bundle-test
35 | (let ((bundle (make-instance 'gfg:icon-bundle))
36 | (happy-image (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/happy.bmp" *gf-tests-dir*)))
37 | (bw-image (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/blackwhite20x16.bmp" *gf-tests-dir*)))
38 | (tc-image (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/truecolor16x16.bmp" *gf-tests-dir*)))
39 | (happy-size (gfs:make-size :width 32 :height 32))
40 | (bw-size (gfs:make-size :width 20 :height 16))
41 | (tc-size (gfs:make-size :width 16 :height 16))
42 | (bw-point (gfs:make-point :x 0 :y 15)))
43 | (unwind-protect
44 | (progn
45 | (gfg:push-icon-image bw-image bundle bw-point)
46 | (gfg:push-icon-image tc-image bundle)
47 | (gfg:push-icon-image happy-image bundle)
48 | (assert-equal 3 (gfg:icon-bundle-length bundle))
49 | (validate-image (gfg:icon-image-ref bundle 0) happy-size 8)
50 | (validate-image (gfg:icon-image-ref bundle 1) tc-size 16000000)
51 | (validate-image (gfg:icon-image-ref bundle 2) bw-size 8)
52 | (validate-image (gfg:icon-image-ref bundle :small) tc-size 8)
53 | (validate-image (gfg:icon-image-ref bundle :large) happy-size 8))
54 | (gfs:dispose bundle))
55 | (assert-true (gfs:disposed-p bundle))))
56 |
57 | (define-test system-icon-bundle-test
58 | (let ((size (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxicon+)
59 | :height (gfs::get-system-metrics gfs::+sm-cyicon+)))
60 | (bundle (make-instance 'gfg:icon-bundle :system gfg:+warning-icon+)))
61 | (unwind-protect
62 | (progn
63 | (assert-equal 1 (gfg:icon-bundle-length bundle))
64 | (validate-image (gfg:icon-image-ref bundle 0) size 8)
65 | (validate-image (gfg:icon-image-ref bundle :small) size 8)
66 | (validate-image (gfg:icon-image-ref bundle :large) size 8))
67 | (gfs:dispose bundle))
68 | (assert-true (gfs:disposed-p bundle))))
69 |
70 | (define-test setf-images-icon-bundle-test
71 | (let ((bundle (make-instance 'gfg:icon-bundle
72 | :images (list (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/happy.bmp" *gf-tests-dir*))
73 | (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/truecolor16x16.bmp" *gf-tests-dir*)))))
74 | (happy-image (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/happy.bmp" *gf-tests-dir*)))
75 | (bw-image (make-instance 'gfg:image :file (merge-pathnames "uitoolkit/blackwhite20x16.bmp" *gf-tests-dir*)))
76 | (happy-size (gfs:make-size :width 32 :height 32))
77 | (bw-size (gfs:make-size :width 20 :height 16)))
78 | (unwind-protect
79 | (progn
80 | (assert-equal 2 (gfg:icon-bundle-length bundle))
81 | (setf (gfg:icon-image-ref bundle 0) bw-image)
82 | (setf (gfg:icon-image-ref bundle 1) happy-image)
83 | (assert-equal 2 (gfg:icon-bundle-length bundle))
84 | (validate-image (gfg:icon-image-ref bundle 0) bw-size 16000000)
85 | (validate-image (gfg:icon-image-ref bundle 1) happy-size 8))
86 | (gfs:dispose bundle))
87 | (assert-true (gfs:disposed-p bundle))))
88 |
--------------------------------------------------------------------------------
/src/uitoolkit/widgets/display.lisp:
--------------------------------------------------------------------------------
1 | (in-package :graphic-forms.uitoolkit.widgets)
2 |
3 | ;;;
4 | ;;; helper functions
5 | ;;;
6 |
7 | (cffi:defcallback (display-visitor :convention :stdcall) gfs::BOOL
8 | ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM))
9 | (declare (ignore hdc monitorrect))
10 | (call-display-visitor-func (thread-context) hmonitor data)
11 | 1)
12 |
13 | (defun query-display-info (hmonitor)
14 | (let ((info nil))
15 | (cffi:with-foreign-object (mi-ptr '(:struct gfs::monitorinfoex))
16 | (cffi:with-foreign-slots ((gfs::cbsize gfs::flags) mi-ptr (:struct gfs::monitorinfoex))
17 | (setf gfs::cbsize (cffi:foreign-type-size '(:struct gfs::monitorinfoex)))
18 | (if (zerop (gfs::get-monitor-info hmonitor mi-ptr))
19 | (error 'gfs:win32-warning :detail "get-monitor-info failed"))
20 | (push (= (logand gfs::flags gfs::+monitorinfoof-primary+) gfs::+monitorinfoof-primary+) info)
21 | (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr '(:struct gfs::monitorinfoex) 'gfs::device)))
22 | (push (cffi:foreign-string-to-lisp str-ptr :max-chars (1- gfs::+cchdevicename+)) info))
23 | (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr '(:struct gfs::monitorinfoex) 'gfs::monitor)))
24 | (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom)
25 | rect-ptr (:struct gfs::rect))
26 | (push (gfs:make-size :width (- gfs::right gfs::left) :height (- gfs::bottom gfs::top))
27 | info)))
28 | (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr '(:struct gfs::monitorinfoex) 'gfs::work)))
29 | (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom)
30 | rect-ptr (:struct gfs::rect))
31 | (push (gfs:make-size :width (- gfs::right gfs::left) :height (- gfs::bottom gfs::top))
32 | info)))))
33 | (reverse info)))
34 |
35 | (defun mapdisplays (func)
36 | ;;
37 | ;; func should expect two parameters:
38 | ;; display handle
39 | ;; flag data
40 | ;;
41 | (let ((tc (thread-context)))
42 | (setf (display-visitor-func tc) func)
43 | (unwind-protect
44 | (gfs::enum-display-monitors (cffi:null-pointer)
45 | (cffi:null-pointer)
46 | (cffi:callback display-visitor) 0)
47 | (setf (display-visitor-func tc) nil))
48 | (let ((tmp (reverse (display-visitor-results tc))))
49 | (setf (display-visitor-results tc) nil)
50 | tmp)))
51 |
52 | (defun obtain-displays ()
53 | (mapdisplays (lambda (hmonitor data)
54 | (declare (ignore data))
55 | (push (make-instance 'display :handle hmonitor)
56 | (display-visitor-results (thread-context))))))
57 |
58 | (declaim (inline obtain-primary-display))
59 | (defun obtain-primary-display ()
60 | ;; In http://blogs.msdn.com/oldnewthing/archive/2007/08/09/4300545.aspx
61 | ;; Raymond Chen recommends the following technique for obtaining the
62 | ;; primary display.
63 | ;;
64 | (make-instance 'display
65 | :handle (gfs::monitor-from-point 0 0 gfs::+monitor-defaulttoprimary+)))
66 |
67 | (cffi:defcallback (top-level-window-visitor :convention :stdcall) gfs::BOOL
68 | ((hwnd :pointer) (lparam gfs::LPARAM))
69 | (declare (ignore lparam))
70 | (let* ((tc (thread-context))
71 | (win (get-widget tc hwnd)))
72 | (unless (null win)
73 | (call-top-level-visitor-func tc win)))
74 | 1)
75 |
76 | (defun maptoplevels (func)
77 | ;;
78 | ;; func should expect one parameter:
79 | ;; top-level window
80 | ;;
81 | (let ((tc (thread-context)))
82 | (setf (top-level-visitor-func tc) func)
83 | (unwind-protect
84 | (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
85 | (cffi:callback top-level-window-visitor)
86 | 0)
87 | (setf (top-level-visitor-func tc) nil))
88 | (let ((tmp (reverse (top-level-visitor-results tc))))
89 | (setf (top-level-visitor-results tc) nil)
90 | tmp)))
91 |
92 | ;;;
93 | ;;; methods
94 | ;;;
95 |
96 | (defmethod client-size ((self display))
97 | (if (gfs:disposed-p self)
98 | (error 'gfs:disposed-error))
99 | (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self))
100 | (declare (ignore primary name size))
101 | client-size))
102 |
103 | (defmethod gfs:dispose ((self display))
104 | (setf (slot-value self 'gfs:handle) nil))
105 |
106 | (defun primary-p (self)
107 | (if (gfs:disposed-p self)
108 | (error 'gfs:disposed-error))
109 | (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self))
110 | (declare (ignore name size client-size))
111 | primary))
112 |
113 | (defmethod size ((self display))
114 | (if (gfs:disposed-p self)
115 | (error 'gfs:disposed-error))
116 | (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self))
117 | (declare (ignore primary name client-size))
118 | size))
119 |
120 | (defmethod text ((self display))
121 | (if (gfs:disposed-p self)
122 | (error 'gfs:disposed-error))
123 | (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self))
124 | (declare (ignore primary size client-size))
125 | name))
126 |
--------------------------------------------------------------------------------