source: project/release/4/qt/qt-base.scm @ 15639

Last change on this file since 15639 was 15639, checked in by felix winkelmann, 10 years ago

ported to CHICKEN 4

File size: 6.4 KB
Line 
1;;;; qt-base.scm
2
3
4(module qt (qt:init 
5            qt:widget qt:show qt:hide qt:run
6            qt:delete qt:message qt:connect qt:find
7            qt:widget qt:receiver qt:pixmap qt:timer
8            qt:property qt:gl qt:update qt:start qt:stop
9            qt:clear qt:add qt:item <qt> qt:classname
10            <qt-object> <qt-widget> <qt-pixmap> <qt-application>
11            <qt-receiver> <qt-timer> <qt-sound>
12            qt:get-open-filename qt:get-save-filename qt:get-directory
13            qt:sound qt:play qt:set-headers)
14
15  (import scheme chicken foreign easyffi)
16  (use srfi-4 srfi-1 protobj matchable data-structures extras)
17
18(define <qt>
19  (% (current-root-object) 
20     (class '<qt>)
21     (pointer #f)
22     (print (lambda (self #!optional (port (current-output-port)))
23              (fprintf port "#<~a>" (? self class))))))
24
25(define <qt-object> (% <qt> (class 'qt-object)))
26(define <qt-sound> (% <qt-object> (class 'qt-sound)))
27(define <qt-widget> (% <qt-object> (class 'qt-widget)))
28(define <qt-application> (% <qt-object> (class 'qt-application)))
29(define <qt-pixmap> (% <qt> (class 'qt-pixmap)))
30(define <qt-receiver> (% <qt-object> (class 'qt-receiver)))
31(define <qt-timer> (% <qt-object> (class 'qt-timer)))
32
33(define (qt:->pointer i) (and i (? i pointer)))
34(define (qt:pointer->widget p) (and p (% <qt-widget> (pointer p))))
35(define (qt:pointer->object p) (and p (% <qt-object> (pointer p))))
36(define (qt:pointer->timer p) (and p (% <qt-timer> (pointer p))))
37(define (qt:pointer->application p) (and p (% <qt-application> (pointer p))))
38(define (qt:pointer->pixmap p) (and p (% <qt-pixmap> (pointer p))))
39(define (qt:pointer->receiver p) (and p (% <qt-receiver> (pointer p))))
40(define (qt:pointer->sound p) (and p (% <qt-sound> (pointer p))))
41
42#>?
43___declare(substitute, "qt_;qt:")
44___declare(type, "qtwidget;c-pointer;qt:->pointer;qt:pointer->widget")
45___declare(type, "qtapplication;c-pointer;qt:->pointer;qt:pointer->application")
46___declare(type, "qtpixmap;c-pointer;qt:->pointer;qt:pointer->pixmap")
47___declare(type, "qtobject;c-pointer;qt:->pointer;qt:pointer->object")
48___declare(type, "qttimer;c-pointer;qt:->pointer;qt:pointer->timer")
49___declare(type, "qtreceiver;c-pointer;qt:->pointer;qt:pointer->receiver")
50___declare(type, "qtsound;c-pointer;qt:->pointer;qt:pointer->sound")
51<#
52
53#>?
54#include "prototypes.h"
55<#
56
57(define qt:connect
58  (let ((qt:connect qt:connect))
59    (lambda (from sig to #!optional (slot "slot()"))
60      (qt:connect 
61       from (string-append "2" sig)
62       (if (procedure? to) (qt:receiver to) to)
63       (string-append "1" slot)) ) ) )
64
65(define qt:receiver
66  (let ((qt:receiver qt:receiver))
67    (lambda (thunk #!optional (name (gensym "qt:receiver")))
68      (qt:receiver (->string name) thunk) ) ) )
69
70(! <qt-object> 'delete
71   (lambda (self) (qt:deleteobject self)))
72
73(! <qt-pixmap> 'delete
74   (lambda (self) (qt:deletepixmap self)))
75
76(define (qt:delete o) (@ delete o))
77
78(define qt:message
79  (let ((qt:message qt:message))
80    (lambda (text #!key (caption "") parent (button1 "OK") (button2 "Cancel") button3)
81      (qt:message caption text parent button1 button2 button3) ) ) )
82
83(define (qt:widget fname #!optional parent)
84  (qt:create fname parent) )
85
86(define qt:property
87  (getter-with-setter
88   (lambda (w p) 
89     (let ((p (->string p)))
90       (case (qt:propertytype w p)
91         ((5) (qt:getstringproperty w p))
92         ((4) (qt:getintproperty w p))
93         ((3) (qt:getfloatproperty w p))
94         ((1) (qt:getboolproperty w p))
95         ((2) (qt:getcharproperty w p))
96         ((6) (qt:getpixmapproperty w p))
97         ((7) (qt:getpointfproperty w p (make-f64vector 2)))
98         ((8) (qt:getrectfproperty w p (make-f64vector 4)))
99         ((9) (qt:getsizefproperty w p (make-f64vector 2)))
100         ((10) (qt:getpointproperty w p (make-s32vector 2)))
101         ((11) (qt:getsizeproperty w p (make-s32vector 2)))
102         ((12) (qt:getrectproperty w p (make-s32vector 4)))
103         (else (error "unknown property" w p)) ) ) )
104   (lambda (w p x)
105     (let* ((p (->string p))
106            (ok (cond ((string? x) (qt:setstringproperty w p x))
107                      ((fixnum? x) (qt:setintproperty w p x))
108                      ((flonum? x) (qt:setfloatproperty w p x))
109                      ((char? x) (qt:setcharproperty w p x))
110                      ((boolean? x) (qt:setboolproperty w p x))
111                      ((s32vector? x)
112                       (if (fx= (s32vector-length x) 2)
113                           (qt:setpointproperty w p x)
114                           (qt:setrectproperty w p x) ) )
115                      ((f64vector? x)
116                       (if (fx= (f64vector-length x) 2)
117                           (qt:setpointfproperty w p x)
118                           (qt:setrectfproperty w p x) ) )
119                      ((eq? (? x class) 'qt-pixmap) (qt:setpixmapproperty w p x))
120                      (else (error "unknown property" w p)) ) ) )
121       (unless ok (error 'qt:property/setter "unable to set widget property" w p x) ) ) ) ) )
122
123(define qt:gl
124  (let ((qt:gl qt:gl))
125    (lambda (name parent init resize paint)
126      (qt:gl
127       name parent
128       (match-lambda*
129         ((0) (init))
130         ((1 w h) (resize w h))
131         (_ (paint)) ) ) ) ) )
132
133(define qt:run
134  (let ((qt:run qt:run))
135    (lambda (#!optional once)
136      (qt:run once) ) ) )
137
138(define (qt:add w x)
139  (cond ((string=? "QComboBox" (qt:classname w)) (qt:addcomboboxitem w x))
140        ((string=? "QListWidget" (qt:classname w)) (qt:addlistwidgetitem w x))
141        ((string=? "QTreeWidget" (qt:classname w)) (qt:addtreewidgetitem w x))
142        (else (error 'qt:add "invalid widget" w x)) ) )
143
144(define (qt:item w i) (and (positive? i) (qt:listwidgetitem w i)))
145(define qt:clear qt:clearlistwidget)
146
147(define (qt:set-headers w x)
148  (cond ((string=? "QTreeWidget" (qt:classname w)) (qt:setheaders w x))
149        (else (error 'qt:add "invalid widget" w x)) ) )
150
151(define (file-dialog-options loc os)
152  (let loop ((os os))
153    (cond ((null? os) 0)
154          ((assq (car os)
155                 '((show-dirs-only: . 1) (dont-resolve-symlinks: . 2) (dont-confirm-overwrite: . 4)
156                   (dont-use-sheet: . 8) (dont-use-native-dialog: . 16) ) )
157           => (lambda (a) (loop (bitwise-ior (cdr a) (loop (cdr os))))) )
158          (else (error loc "invalid file-dialog option" (car os))) ) ) )
159
160(define (qt:get-open-filename cap dir #!key parent (options '()) filter)
161  (qt:getopenfilename parent cap dir filter (file-dialog-options 'qt:get-open-filename options)) )
162
163(define (qt:get-save-filename cap dir #!key parent (options '()) filter)
164  (qt:getsavefilename parent cap dir filter (file-dialog-options 'qt:get-save-filename options)) )
165
166(define (qt:get-directory cap dir #!key parent (options '()))
167  (qt:getexistingdirectory parent cap dir (file-dialog-options 'qt:get-directory options)) )
168
169(! <qt-timer> 'stop
170   (lambda (self) (qt:stoptimer self)))
171
172(! <qt-sound> 'stop
173   (lambda (self) (qt:stopsound self)))
174
175(define (qt:stop x) (@ x stop))
176
177)
Note: See TracBrowser for help on using the repository browser.