clean up unused
This commit is contained in:
Matthew Flatt
parent
7e8a08cdd8
commit
23f0296cb9
|
|
@ -42,10 +42,6 @@
|
|||
"private/dynamic.ss"
|
||||
"private/check.ss")
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; These functions are re-implemented in scheme/gui/base
|
||||
;; and racket/gui/base to attach those names, instead of
|
||||
|
|
|
|||
|
|
@ -7,11 +7,15 @@
|
|||
"wx/common/cursor.rkt"
|
||||
"wx/common/gl-config.rkt"
|
||||
"wx/common/procs.rkt"
|
||||
"wx/common/handlers.rkt"
|
||||
racket/class
|
||||
racket/draw)
|
||||
|
||||
(define gl-context<%> (class->interface gl-context%))
|
||||
|
||||
(define (key-symbol-to-integer k)
|
||||
(error 'key-symbol-to-integer "not yet implemented"))
|
||||
|
||||
(provide (all-from-out "wx/platform.rkt")
|
||||
clipboard<%>
|
||||
gl-context<%>
|
||||
|
|
@ -37,4 +41,9 @@
|
|||
get-top-level-windows
|
||||
begin-busy-cursor
|
||||
is-busy?
|
||||
end-busy-cursor)
|
||||
end-busy-cursor
|
||||
key-symbol-to-integer
|
||||
application-file-handler
|
||||
application-quit-handler
|
||||
application-about-handler
|
||||
application-pref-handler)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
play-sound
|
||||
timer%)
|
||||
|
||||
;; Currently only used for PS print and preview
|
||||
;; Formerly used for PS print and preview:
|
||||
#;
|
||||
(wx:set-executer
|
||||
(let ([orig-err (current-error-port)])
|
||||
(lambda (prog . args)
|
||||
|
|
|
|||
|
|
@ -466,6 +466,4 @@
|
|||
|
||||
(define (menu-or-bar-parent who p)
|
||||
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
|
||||
(raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))
|
||||
|
||||
(wx:set-menu-tester (lambda (m) (is-a? m popup-menu%))))
|
||||
(raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p))))
|
||||
|
|
|
|||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"item.rkt")
|
||||
|
||||
(provide group-box%)
|
||||
|
||||
(defclass group-box% item%
|
||||
(super-new))
|
||||
|
|
@ -10,7 +10,6 @@
|
|||
"frame.rkt"
|
||||
"gauge.rkt"
|
||||
"gl-context.rkt"
|
||||
"group-box.rkt"
|
||||
"group-panel.rkt"
|
||||
"item.rkt"
|
||||
"list-box.rkt"
|
||||
|
|
@ -22,7 +21,6 @@
|
|||
"printer-dc.rkt"
|
||||
"radio-box.rkt"
|
||||
"slider.rkt"
|
||||
"tab-group.rkt"
|
||||
"tab-panel.rkt"
|
||||
"window.rkt"
|
||||
"procs.rkt")
|
||||
|
|
@ -40,7 +38,6 @@
|
|||
frame%
|
||||
gauge%
|
||||
gl-context%
|
||||
group-box%
|
||||
group-panel%
|
||||
item%
|
||||
list-box%
|
||||
|
|
@ -52,7 +49,6 @@
|
|||
printer-dc%
|
||||
radio-box%
|
||||
slider%
|
||||
tab-group%
|
||||
tab-panel%
|
||||
window%
|
||||
can-show-print-setup?
|
||||
|
|
@ -72,34 +68,22 @@
|
|||
fill-private-color
|
||||
cancel-quit
|
||||
get-control-font-size
|
||||
key-symbol-to-integer
|
||||
draw-tab-base
|
||||
draw-tab
|
||||
set-combo-box-font
|
||||
get-double-click-time
|
||||
run-printout
|
||||
file-creator-and-type
|
||||
send-event
|
||||
set-executer
|
||||
set-dialogs
|
||||
location->window
|
||||
set-menu-tester
|
||||
in-atomic-region
|
||||
shortcut-visible-in-label?
|
||||
unregister-collecting-blit
|
||||
register-collecting-blit
|
||||
find-graphical-system-path
|
||||
check-for-break
|
||||
play-sound
|
||||
get-panel-background
|
||||
get-font-from-user
|
||||
get-color-from-user
|
||||
application-pref-handler
|
||||
application-about-handler
|
||||
application-quit-handler
|
||||
application-file-handler
|
||||
special-option-key
|
||||
special-control-key
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap))
|
||||
make-screen-bitmap
|
||||
check-for-break))
|
||||
|
|
|
|||
|
|
@ -24,23 +24,14 @@
|
|||
get-font-from-user
|
||||
get-panel-background
|
||||
play-sound
|
||||
check-for-break
|
||||
find-graphical-system-path
|
||||
register-collecting-blit
|
||||
unregister-collecting-blit
|
||||
shortcut-visible-in-label?
|
||||
in-atomic-region
|
||||
set-menu-tester
|
||||
set-dialogs
|
||||
set-executer
|
||||
send-event
|
||||
file-creator-and-type
|
||||
run-printout
|
||||
get-double-click-time
|
||||
set-combo-box-font
|
||||
draw-tab
|
||||
draw-tab-base
|
||||
key-symbol-to-integer
|
||||
get-control-font-size
|
||||
cancel-quit
|
||||
fill-private-color
|
||||
|
|
@ -61,7 +52,8 @@
|
|||
can-show-print-setup?
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap)
|
||||
make-screen-bitmap
|
||||
check-for-break)
|
||||
|
||||
(import-class NSScreen NSCursor)
|
||||
|
||||
|
|
@ -70,36 +62,26 @@
|
|||
(define-unimplemented get-font-from-user)
|
||||
(define (get-panel-background) (make-object color% "gray"))
|
||||
(define-unimplemented play-sound)
|
||||
(define-unimplemented check-for-break)
|
||||
(define-unimplemented find-graphical-system-path)
|
||||
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
|
||||
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
|
||||
(define (unregister-collecting-blit canvas)
|
||||
(send canvas unregister-collecting-blits))
|
||||
(define (shortcut-visible-in-label? [x #f]) #f)
|
||||
(define-unimplemented in-atomic-region)
|
||||
(define (set-menu-tester proc)
|
||||
(void))
|
||||
(define (set-dialogs . args)
|
||||
(void))
|
||||
(define (set-executer proc)
|
||||
(void))
|
||||
(define-unimplemented send-event)
|
||||
(define (begin-refresh-sequence) (void))
|
||||
(define (end-refresh-sequence) (void))
|
||||
(define-unimplemented run-printout)
|
||||
(define (get-double-click-time)
|
||||
500)
|
||||
(define (set-combo-box-font f) (void))
|
||||
(define-unimplemented draw-tab)
|
||||
(define-unimplemented draw-tab-base)
|
||||
(define-unimplemented key-symbol-to-integer)
|
||||
(define (get-control-font-size) 13)
|
||||
(define (cancel-quit) (void))
|
||||
(define-unimplemented fill-private-color)
|
||||
(define-unimplemented write-resource)
|
||||
(define-unimplemented get-resource)
|
||||
|
||||
(define (check-for-break) #f)
|
||||
|
||||
(define (display-origin xb yb all?)
|
||||
(set-box! xb 0)
|
||||
(if all?
|
||||
|
|
|
|||
|
|
@ -1,16 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"item.rkt")
|
||||
|
||||
(provide tab-group%)
|
||||
|
||||
(defclass tab-group% item%
|
||||
(def/public-unimplemented button-focus)
|
||||
(def/public-unimplemented set)
|
||||
(def/public-unimplemented delete)
|
||||
(def/public-unimplemented append)
|
||||
(def/public-unimplemented set-selection)
|
||||
(def/public-unimplemented number)
|
||||
(def/public-unimplemented get-selection)
|
||||
(super-new))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"item.rkt")
|
||||
|
||||
(provide group-box%)
|
||||
|
||||
(defclass group-box% item%
|
||||
(super-new))
|
||||
|
|
@ -10,7 +10,6 @@
|
|||
"frame.rkt"
|
||||
"gauge.rkt"
|
||||
"gl-context.rkt"
|
||||
"group-box.rkt"
|
||||
"group-panel.rkt"
|
||||
"item.rkt"
|
||||
"list-box.rkt"
|
||||
|
|
@ -22,7 +21,6 @@
|
|||
"printer-dc.rkt"
|
||||
"radio-box.rkt"
|
||||
"slider.rkt"
|
||||
"tab-group.rkt"
|
||||
"tab-panel.rkt"
|
||||
"window.rkt"
|
||||
"procs.rkt")
|
||||
|
|
@ -40,7 +38,6 @@
|
|||
frame%
|
||||
gauge%
|
||||
gl-context%
|
||||
group-box%
|
||||
group-panel%
|
||||
item%
|
||||
list-box%
|
||||
|
|
@ -52,7 +49,6 @@
|
|||
printer-dc%
|
||||
radio-box%
|
||||
slider%
|
||||
tab-group%
|
||||
tab-panel%
|
||||
window%
|
||||
can-show-print-setup?
|
||||
|
|
@ -72,34 +68,22 @@
|
|||
fill-private-color
|
||||
cancel-quit
|
||||
get-control-font-size
|
||||
key-symbol-to-integer
|
||||
draw-tab-base
|
||||
draw-tab
|
||||
set-combo-box-font
|
||||
get-double-click-time
|
||||
run-printout
|
||||
file-creator-and-type
|
||||
send-event
|
||||
set-executer
|
||||
set-dialogs
|
||||
location->window
|
||||
set-menu-tester
|
||||
in-atomic-region
|
||||
shortcut-visible-in-label?
|
||||
unregister-collecting-blit
|
||||
register-collecting-blit
|
||||
find-graphical-system-path
|
||||
check-for-break
|
||||
play-sound
|
||||
get-panel-background
|
||||
get-font-from-user
|
||||
get-color-from-user
|
||||
application-pref-handler
|
||||
application-about-handler
|
||||
application-quit-handler
|
||||
application-file-handler
|
||||
special-option-key
|
||||
special-control-key
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap))
|
||||
make-screen-bitmap
|
||||
check-for-break))
|
||||
|
|
|
|||
|
|
@ -16,31 +16,19 @@
|
|||
(provide
|
||||
special-control-key
|
||||
special-option-key
|
||||
application-file-handler
|
||||
application-quit-handler
|
||||
application-about-handler
|
||||
application-pref-handler
|
||||
get-color-from-user
|
||||
get-font-from-user
|
||||
get-panel-background
|
||||
play-sound
|
||||
check-for-break
|
||||
find-graphical-system-path
|
||||
register-collecting-blit
|
||||
unregister-collecting-blit
|
||||
shortcut-visible-in-label?
|
||||
in-atomic-region
|
||||
set-menu-tester
|
||||
location->window
|
||||
set-dialogs
|
||||
set-executer
|
||||
send-event
|
||||
file-creator-and-type
|
||||
run-printout
|
||||
get-double-click-time
|
||||
set-combo-box-font
|
||||
draw-tab
|
||||
draw-tab-base
|
||||
key-symbol-to-integer
|
||||
get-control-font-size
|
||||
cancel-quit
|
||||
|
|
@ -62,7 +50,8 @@
|
|||
can-show-print-setup?
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap)
|
||||
make-screen-bitmap
|
||||
check-for-break)
|
||||
|
||||
(define-unimplemented special-control-key)
|
||||
(define (special-option-key on?) (void))
|
||||
|
|
@ -70,18 +59,13 @@
|
|||
(define-unimplemented get-font-from-user)
|
||||
(define (get-panel-background) (make-object color% "gray"))
|
||||
(define-unimplemented play-sound)
|
||||
(define-unimplemented check-for-break)
|
||||
(define-unimplemented find-graphical-system-path)
|
||||
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
|
||||
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
|
||||
(define (unregister-collecting-blit canvas)
|
||||
(send canvas unregister-collecting-blits))
|
||||
(define (shortcut-visible-in-label? [mbar? #f]) #t)
|
||||
(define-unimplemented in-atomic-region)
|
||||
(define (set-menu-tester proc) (void))
|
||||
(define-unimplemented location->window)
|
||||
(define (set-dialogs . args) (void))
|
||||
(define (set-executer e) (void))
|
||||
(define-unimplemented send-event)
|
||||
(define file-creator-and-type
|
||||
(case-lambda
|
||||
|
|
@ -89,9 +73,6 @@
|
|||
[(path) (values #"????" #"????")]))
|
||||
(define-unimplemented run-printout)
|
||||
(define (get-double-click-time) 250)
|
||||
(define (set-combo-box-font f) (void))
|
||||
(define-unimplemented draw-tab)
|
||||
(define-unimplemented draw-tab-base)
|
||||
(define-unimplemented key-symbol-to-integer)
|
||||
(define (get-control-font-size) 10) ;; FIXME
|
||||
(define-unimplemented cancel-quit)
|
||||
|
|
@ -140,3 +121,5 @@
|
|||
(if (eq? 'unix (system-type))
|
||||
(make-object x11-bitmap% w h #f)
|
||||
(make-object bitmap% w h #f #t)))
|
||||
|
||||
(define (check-for-break) #f)
|
||||
|
|
|
|||
|
|
@ -1,16 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"item.rkt")
|
||||
|
||||
(provide tab-group%)
|
||||
|
||||
(defclass tab-group% item%
|
||||
(def/public-unimplemented button-focus)
|
||||
(def/public-unimplemented set)
|
||||
(def/public-unimplemented delete)
|
||||
(def/public-unimplemented append)
|
||||
(def/public-unimplemented set-selection)
|
||||
(def/public-unimplemented number)
|
||||
(def/public-unimplemented get-selection)
|
||||
(super-new))
|
||||
|
|
@ -18,7 +18,6 @@
|
|||
frame%
|
||||
gauge%
|
||||
gl-context%
|
||||
group-box%
|
||||
group-panel%
|
||||
item%
|
||||
list-box%
|
||||
|
|
@ -30,7 +29,6 @@
|
|||
printer-dc%
|
||||
radio-box%
|
||||
slider%
|
||||
tab-group%
|
||||
tab-panel%
|
||||
window%
|
||||
can-show-print-setup?
|
||||
|
|
@ -50,35 +48,23 @@
|
|||
fill-private-color
|
||||
cancel-quit
|
||||
get-control-font-size
|
||||
key-symbol-to-integer
|
||||
draw-tab-base
|
||||
draw-tab
|
||||
set-combo-box-font
|
||||
get-double-click-time
|
||||
run-printout
|
||||
file-creator-and-type
|
||||
send-event
|
||||
set-executer
|
||||
set-dialogs
|
||||
location->window
|
||||
set-menu-tester
|
||||
in-atomic-region
|
||||
shortcut-visible-in-label?
|
||||
unregister-collecting-blit
|
||||
register-collecting-blit
|
||||
find-graphical-system-path
|
||||
check-for-break
|
||||
play-sound
|
||||
get-panel-background
|
||||
get-font-from-user
|
||||
get-color-from-user
|
||||
application-pref-handler
|
||||
application-about-handler
|
||||
application-quit-handler
|
||||
application-file-handler
|
||||
special-option-key
|
||||
special-control-key
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap)
|
||||
make-screen-bitmap
|
||||
check-for-break)
|
||||
((dynamic-require platform-lib 'platform-values)))
|
||||
|
|
|
|||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"item.rkt")
|
||||
|
||||
(provide group-box%)
|
||||
|
||||
(defclass group-box% item%
|
||||
(super-new))
|
||||
|
|
@ -9,7 +9,6 @@
|
|||
"frame.rkt"
|
||||
"gauge.rkt"
|
||||
"gl-context.rkt"
|
||||
"group-box.rkt"
|
||||
"group-panel.rkt"
|
||||
"item.rkt"
|
||||
"list-box.rkt"
|
||||
|
|
@ -21,7 +20,6 @@
|
|||
"printer-dc.rkt"
|
||||
"radio-box.rkt"
|
||||
"slider.rkt"
|
||||
"tab-group.rkt"
|
||||
"tab-panel.rkt"
|
||||
"window.rkt"
|
||||
"procs.rkt")
|
||||
|
|
@ -39,7 +37,6 @@
|
|||
frame%
|
||||
gauge%
|
||||
gl-context%
|
||||
group-box%
|
||||
group-panel%
|
||||
item%
|
||||
list-box%
|
||||
|
|
@ -51,7 +48,6 @@
|
|||
printer-dc%
|
||||
radio-box%
|
||||
slider%
|
||||
tab-group%
|
||||
tab-panel%
|
||||
window%
|
||||
can-show-print-setup?
|
||||
|
|
@ -71,34 +67,22 @@
|
|||
fill-private-color
|
||||
cancel-quit
|
||||
get-control-font-size
|
||||
key-symbol-to-integer
|
||||
draw-tab-base
|
||||
draw-tab
|
||||
set-combo-box-font
|
||||
get-double-click-time
|
||||
run-printout
|
||||
file-creator-and-type
|
||||
send-event
|
||||
set-executer
|
||||
set-dialogs
|
||||
location->window
|
||||
set-menu-tester
|
||||
in-atomic-region
|
||||
shortcut-visible-in-label?
|
||||
unregister-collecting-blit
|
||||
register-collecting-blit
|
||||
find-graphical-system-path
|
||||
check-for-break
|
||||
play-sound
|
||||
get-panel-background
|
||||
get-font-from-user
|
||||
get-color-from-user
|
||||
application-pref-handler
|
||||
application-about-handler
|
||||
application-quit-handler
|
||||
application-file-handler
|
||||
special-option-key
|
||||
special-control-key
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap))
|
||||
make-screen-bitmap
|
||||
check-for-break))
|
||||
|
|
|
|||
|
|
@ -4,32 +4,19 @@
|
|||
(provide
|
||||
special-control-key
|
||||
special-option-key
|
||||
application-file-handler
|
||||
application-quit-handler
|
||||
application-about-handler
|
||||
application-pref-handler
|
||||
get-color-from-user
|
||||
get-font-from-user
|
||||
get-panel-background
|
||||
play-sound
|
||||
check-for-break
|
||||
find-graphical-system-path
|
||||
register-collecting-blit
|
||||
unregister-collecting-blit
|
||||
shortcut-visible-in-label?
|
||||
in-atomic-region
|
||||
set-menu-tester
|
||||
location->window
|
||||
set-dialogs
|
||||
set-executer
|
||||
send-event
|
||||
file-creator-and-type
|
||||
run-printout
|
||||
get-double-click-time
|
||||
set-combo-box-font
|
||||
draw-tab
|
||||
draw-tab-base
|
||||
key-symbol-to-integer
|
||||
get-control-font-size
|
||||
cancel-quit
|
||||
fill-private-color
|
||||
|
|
@ -50,36 +37,24 @@
|
|||
can-show-print-setup?
|
||||
get-highlight-background-color
|
||||
get-highlight-text-color
|
||||
make-screen-bitmap)
|
||||
make-screen-bitmap
|
||||
check-for-break)
|
||||
|
||||
(define-unimplemented special-control-key)
|
||||
(define-unimplemented special-option-key)
|
||||
(define-unimplemented application-file-handler)
|
||||
(define-unimplemented application-quit-handler)
|
||||
(define-unimplemented application-about-handler)
|
||||
(define-unimplemented application-pref-handler)
|
||||
(define-unimplemented get-color-from-user)
|
||||
(define-unimplemented get-font-from-user)
|
||||
(define-unimplemented get-panel-background)
|
||||
(define-unimplemented play-sound)
|
||||
(define-unimplemented check-for-break)
|
||||
(define-unimplemented find-graphical-system-path)
|
||||
(define-unimplemented register-collecting-blit)
|
||||
(define-unimplemented unregister-collecting-blit)
|
||||
(define-unimplemented shortcut-visible-in-label?)
|
||||
(define-unimplemented in-atomic-region)
|
||||
(define-unimplemented set-menu-tester)
|
||||
(define-unimplemented location->window)
|
||||
(define-unimplemented set-dialogs)
|
||||
(define-unimplemented set-executer)
|
||||
(define-unimplemented send-event)
|
||||
(define-unimplemented file-creator-and-type)
|
||||
(define-unimplemented run-printout)
|
||||
(define-unimplemented get-double-click-time)
|
||||
(define-unimplemented set-combo-box-font)
|
||||
(define-unimplemented draw-tab)
|
||||
(define-unimplemented draw-tab-base)
|
||||
(define-unimplemented key-symbol-to-integer)
|
||||
(define-unimplemented get-control-font-size)
|
||||
(define-unimplemented cancel-quit)
|
||||
(define-unimplemented fill-private-color)
|
||||
|
|
@ -104,3 +79,5 @@
|
|||
(define-unimplemented get-highlight-background-color)
|
||||
(define-unimplemented get-highlight-text-color)
|
||||
(define-unimplemented make-screen-bitmap)
|
||||
|
||||
(define (check-for-break) #f)
|
||||
|
|
|
|||
|
|
@ -1,16 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"../../syntax.rkt"
|
||||
"item.rkt")
|
||||
|
||||
(provide tab-group%)
|
||||
|
||||
(defclass tab-group% item%
|
||||
(def/public-unimplemented button-focus)
|
||||
(def/public-unimplemented set)
|
||||
(def/public-unimplemented delete)
|
||||
(def/public-unimplemented append)
|
||||
(def/public-unimplemented set-selection)
|
||||
(def/public-unimplemented number)
|
||||
(def/public-unimplemented get-selection)
|
||||
(super-new))
|
||||
|
|
@ -1,101 +0,0 @@
|
|||
(module wxgroupbox mzscheme
|
||||
(require mzlib/class
|
||||
(prefix wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"wx.ss"
|
||||
"const.ss"
|
||||
"gdi.ss"
|
||||
"helper.ss"
|
||||
"wxwindow.ss"
|
||||
"wxitem.ss"
|
||||
"wxcanvas.ss")
|
||||
|
||||
(provide (protect wx-group-box%))
|
||||
|
||||
(define group-right-inset 4)
|
||||
|
||||
(define canvas-based-group-box%
|
||||
(class* wx-canvas% (wx-group-box<%>)
|
||||
(init mred proxy style parent label style-again _font)
|
||||
|
||||
(define font (or _font small-control-font))
|
||||
|
||||
(inherit get-dc get-client-size get-mred
|
||||
set-min-width set-min-height
|
||||
set-tab-focus
|
||||
set-background-to-gray
|
||||
is-enabled-to-root?)
|
||||
|
||||
(define lbl label)
|
||||
|
||||
(define lbl-w 0)
|
||||
(define lbl-h 0)
|
||||
|
||||
(define/private (compute-sizes)
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(w h d a) (send dc get-text-extent lbl font)])
|
||||
(set! lbl-w w)
|
||||
(set! lbl-h h))))
|
||||
|
||||
(define/override (on-char e) (void))
|
||||
(define/override (on-event e) (void))
|
||||
|
||||
(define/override on-paint
|
||||
(entry-point
|
||||
(lambda ()
|
||||
(let ([dc (get-dc)])
|
||||
(send dc set-background bg-color)
|
||||
(send dc set-font font)
|
||||
(send dc clear)
|
||||
(send dc set-text-foreground
|
||||
(if (is-enabled-to-root?)
|
||||
black-color
|
||||
disabled-color))
|
||||
(send dc draw-text lbl group-right-inset 0)
|
||||
(send dc set-pen light-pen)
|
||||
(let-values ([(w h) (my-get-client-size)]
|
||||
[(tw th ta td) (send dc get-text-extent lbl)])
|
||||
(send dc draw-line
|
||||
1 (/ lbl-h 2)
|
||||
(- group-right-inset 2) (/ lbl-h 2))
|
||||
(send dc draw-line
|
||||
1 (/ lbl-h 2)
|
||||
1 (- h 2))
|
||||
(send dc draw-line
|
||||
1 (- h 2)
|
||||
(- w 2) (- h 2))
|
||||
(send dc draw-line
|
||||
(- w 2) (- h 2)
|
||||
(- w 2) (/ lbl-h 2))
|
||||
(send dc draw-line
|
||||
(- w 2) (/ lbl-h 2)
|
||||
(min (- w 2)
|
||||
(+ group-right-inset 4 tw))
|
||||
(/ lbl-h 2)))))))
|
||||
|
||||
(define/private (my-get-client-size)
|
||||
(get-two-int-values (lambda (a b) (get-client-size a b))))
|
||||
|
||||
(define/override (handles-key-code code alpha? meta?)
|
||||
#f)
|
||||
|
||||
(define/public (set-label l)
|
||||
(set! lbl l)
|
||||
(on-paint))
|
||||
|
||||
(super-instantiate (mred proxy parent -1 -1 -1 -1 '(transparent) #f))
|
||||
|
||||
(set-background-to-gray)
|
||||
|
||||
(compute-sizes)
|
||||
(set-min-width (inexact->exact (ceiling (+ lbl-w group-right-inset 4))))
|
||||
(set-min-height (inexact->exact (ceiling (+ lbl-h 6))))
|
||||
(set-tab-focus #f)))
|
||||
|
||||
(define wx-group-box%
|
||||
(if (eq? 'unix (system-type))
|
||||
canvas-based-group-box%
|
||||
(class* (make-window-glue%
|
||||
(make-control% wx:group-box% 0 0 #t #t)) (wx-group-box<%>)
|
||||
(define/override (gets-focus?) #f)
|
||||
(super-instantiate ())))))
|
||||
|
|
@ -1,427 +0,0 @@
|
|||
(module wxtabgroup mzscheme
|
||||
(require mzlib/class
|
||||
(prefix wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"wx.ss"
|
||||
"const.ss"
|
||||
"gdi.ss"
|
||||
"helper.ss"
|
||||
"wxwindow.ss"
|
||||
"wxitem.ss"
|
||||
"wxcanvas.ss")
|
||||
|
||||
(provide (protect wx-tab-group%
|
||||
canvas-based-tab-group%))
|
||||
|
||||
(define mac-tab? (eq? 'macosx (system-type)))
|
||||
|
||||
(define tab-v-space 2)
|
||||
(define raise-h (if mac-tab? 0 2))
|
||||
|
||||
(define canvas-based-tab-group%
|
||||
(class* wx-canvas% (wx-tab-group<%>)
|
||||
(init mred proxy style parent call-back label tab-labels style-again _font)
|
||||
|
||||
(define callback call-back)
|
||||
|
||||
(define tabs (map wx:label->plain-label tab-labels))
|
||||
(define tab-widths #f)
|
||||
(define tab-height #f)
|
||||
|
||||
(define current-focus-tab 0)
|
||||
|
||||
(define font (or _font normal-control-font))
|
||||
|
||||
(inherit get-dc get-client-size get-mred
|
||||
set-min-width set-min-height
|
||||
set-tab-focus set-focus has-focus?
|
||||
set-background-to-gray refresh
|
||||
get-top-level is-enabled-to-root?)
|
||||
|
||||
(define selected 0)
|
||||
(define tracking-pos #f)
|
||||
(define tracking-hit? #f)
|
||||
|
||||
(define regions #f)
|
||||
(define redo-regions? #f)
|
||||
|
||||
(define border? (memq 'border style))
|
||||
|
||||
(define/private (compute-sizes)
|
||||
(let ([dc (get-dc)])
|
||||
(let ([w+hs (map (lambda (lbl)
|
||||
(let-values ([(w h d a) (send dc get-text-extent lbl font)])
|
||||
(cons w h)))
|
||||
tabs)])
|
||||
(set! tab-widths (map car w+hs))
|
||||
(if mac-tab?
|
||||
(set! tab-height (+ 27 (send font get-point-size) -13))
|
||||
(let-values ([(sw sh sd sa) (send dc get-text-extent " " font)])
|
||||
(let ([th (ceiling (+ (* 2 tab-v-space) (apply max 0 sh (map cdr w+hs))))])
|
||||
(set! tab-height (if (even? th) th (add1 th)))))))))
|
||||
|
||||
(define/private (get-total-width)
|
||||
(compute-sizes)
|
||||
(apply +
|
||||
(if mac-tab? 0 tab-height)
|
||||
(* (length tabs) (+ raise-h raise-h tab-height))
|
||||
tab-widths))
|
||||
|
||||
(define/private (get-init-x)
|
||||
(if border?
|
||||
(let-values ([(w h) (my-get-client-size)]
|
||||
[(tw) (get-total-width)])
|
||||
(/ (- w tw) 2))
|
||||
(if mac-tab?
|
||||
2
|
||||
0)))
|
||||
|
||||
(define/override (on-char e) (void))
|
||||
|
||||
(define/override on-event
|
||||
(entry-point
|
||||
(lambda (e)
|
||||
(cond
|
||||
[(and (send e button-down?) tab-widths)
|
||||
(set! tracking-pos (find-click (send e get-x) (send e get-y)))
|
||||
(when tracking-pos
|
||||
(set! current-focus-tab tracking-pos)
|
||||
(set! tracking-hit? #t)
|
||||
(update-tracking))]
|
||||
[(and (send e dragging?) tracking-pos)
|
||||
(let ([hit? (equal? tracking-pos (find-click (send e get-x) (send e get-y)))])
|
||||
(unless (eq? tracking-hit? hit?)
|
||||
(set! tracking-hit? hit?)
|
||||
(update-tracking)))]
|
||||
[(and (send e button-up?) tracking-pos
|
||||
(equal? tracking-pos (find-click (send e get-x) (send e get-y)))
|
||||
(not (= tracking-pos selected)))
|
||||
;; Button released for final selection
|
||||
(let ([new tracking-pos])
|
||||
(set! tracking-pos #f)
|
||||
(set! tracking-hit? #f)
|
||||
(set-selection new)
|
||||
(as-exit
|
||||
(lambda ()
|
||||
(callback this (make-object wx:control-event% 'tab-panel)))))]
|
||||
;; otherwise, turn off tracking...
|
||||
[else
|
||||
(when tracking-hit?
|
||||
(set! tracking-hit? #f)
|
||||
(update-tracking))
|
||||
(set! tracking-pos #f)]))))
|
||||
|
||||
(define/private (update-tracking)
|
||||
(if mac-tab?
|
||||
(refresh)
|
||||
(let ([dc (get-dc)])
|
||||
(send dc set-clipping-region (list-ref regions tracking-pos))
|
||||
(on-paint)
|
||||
(send dc set-clipping-region #f))))
|
||||
|
||||
(define tmp-rgn #f)
|
||||
|
||||
(define/public (button-focus n)
|
||||
(if (< n 0)
|
||||
current-focus-tab
|
||||
(begin
|
||||
(set! current-focus-tab n)
|
||||
(refresh)
|
||||
(set-focus)
|
||||
current-focus-tab)))
|
||||
|
||||
(define/override on-set-focus
|
||||
(lambda ()
|
||||
(refresh)
|
||||
(super on-set-focus)))
|
||||
(define/override on-kill-focus
|
||||
(lambda ()
|
||||
(refresh)
|
||||
(super on-kill-focus)))
|
||||
|
||||
(define/private (find-click x y)
|
||||
(ready-regions)
|
||||
(unless tmp-rgn
|
||||
(set! tmp-rgn (make-object wx:region% (get-dc))))
|
||||
(let loop ([rl regions][pos 0])
|
||||
(if (null? rl)
|
||||
#f
|
||||
(begin
|
||||
(send tmp-rgn set-rectangle x y 1 1)
|
||||
(send tmp-rgn intersect (car rl))
|
||||
(if (send tmp-rgn is-empty?)
|
||||
(loop (cdr rl) (add1 pos))
|
||||
pos)))))
|
||||
|
||||
(define/private (setup-regions)
|
||||
(let ([dc (get-dc)])
|
||||
(set! regions
|
||||
(map (lambda (tpl r)
|
||||
(let ([points (map (lambda (p) (make-object wx:point% (car p) (+ 2 raise-h (cadr p))))
|
||||
tpl)])
|
||||
(send r set-polygon points))
|
||||
r)
|
||||
(draw-once #f 0 #f #f 0 #f)
|
||||
(if regions
|
||||
regions
|
||||
(map (lambda (x)
|
||||
(make-object wx:region% dc))
|
||||
tabs))))
|
||||
(set! redo-regions? #f)))
|
||||
|
||||
(define/private (ready-regions)
|
||||
(compute-sizes)
|
||||
(unless (and regions (not redo-regions?))
|
||||
(setup-regions)))
|
||||
|
||||
(define/override (gets-focus?) #t)
|
||||
(define/override (tabbing-position x y w h)
|
||||
(list this (+ x (get-init-x)) y (get-total-width) tab-height))
|
||||
(define/public (number) (length tabs))
|
||||
|
||||
;; Returns a list of point lists, which define polygons for hit-testing
|
||||
;; and updating
|
||||
(define/private (draw-once dc w light? dark? inset active?)
|
||||
(let ([init-x (get-init-x)])
|
||||
(let loop ([x init-x][l tabs][wl tab-widths][pos 0])
|
||||
(if (null? l)
|
||||
null
|
||||
(let ([next-x (+ x tab-height (car wl))]
|
||||
[-sel-d (if (= pos selected) (- raise-h) 0)])
|
||||
(cons
|
||||
(if mac-tab?
|
||||
;; ----- Mac drawing -----
|
||||
(let ([w (+ tab-height (car wl))]
|
||||
[h tab-height])
|
||||
(when dc
|
||||
(when (eq? dark? (= pos selected))
|
||||
(wx:draw-tab
|
||||
dc
|
||||
(car l) x 3 w (- tab-height 3)
|
||||
(+ (if (and (has-focus?)
|
||||
(= pos current-focus-tab))
|
||||
;; Adding 100 means "draw focus ring"
|
||||
100
|
||||
;; No focus
|
||||
0)
|
||||
;; Pick the style: active and front, etc.
|
||||
(if (and light?
|
||||
(eq? pos tracking-pos))
|
||||
1
|
||||
(if active?
|
||||
(if dark? 3 0)
|
||||
(if dark? 4 2)))))))
|
||||
(list (list x 3) (list (+ x w) 3)
|
||||
(list (+ x w) (- tab-height 6)) (list x (- tab-height 6))))
|
||||
;; ----- X-style drawing -----
|
||||
(append
|
||||
;; start point
|
||||
(list (list (+ x tab-height -sel-d inset) (+ 2 tab-height (- inset))))
|
||||
;; left line
|
||||
(begin
|
||||
(when (= pos selected)
|
||||
(when light?
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line 0 tab-height (sub1 x) tab-height)
|
||||
(send dc set-pen light-pen)
|
||||
(send dc draw-line 0 (add1 tab-height) (sub1 x) (add1 tab-height))))
|
||||
(let ([short (if (or (= pos 0) (= pos selected))
|
||||
0
|
||||
(+ (/ tab-height 2)
|
||||
(if (= selected (sub1 pos))
|
||||
raise-h
|
||||
0)))])
|
||||
(when light?
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line (+ x short -sel-d) (- tab-height short) (+ x tab-height) -sel-d)
|
||||
(send dc set-pen light-pen)
|
||||
(send dc draw-line (+ x short -sel-d 1) (- tab-height short) (+ x tab-height 1) -sel-d))
|
||||
(list (list (+ x short -sel-d -2 inset) (- tab-height short -2 inset))
|
||||
(list (+ x tab-height inset) (+ -sel-d inset)))))
|
||||
;; top line
|
||||
(begin
|
||||
(when light?
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line (+ x tab-height) -sel-d next-x -sel-d)
|
||||
(send dc set-pen light-pen)
|
||||
(send dc draw-line (+ x tab-height) (+ 1 -sel-d) next-x (+ 1 -sel-d)))
|
||||
(list (list (+ 1 next-x (- inset)) (+ inset -sel-d))))
|
||||
;; right line
|
||||
(let* ([short (if (= (add1 pos) selected)
|
||||
(+ (/ tab-height 2) (sub1 raise-h))
|
||||
0)]
|
||||
[short-d (if (zero? short) 0 -1)])
|
||||
(when dark?
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line next-x (+ -sel-d 1)
|
||||
(- (+ next-x tab-height) short 2 -sel-d short-d) (- tab-height short 1 short-d))
|
||||
(send dc set-pen dark-pen)
|
||||
(send dc draw-line (+ 1 next-x) (+ -sel-d 1) (- (+ next-x tab-height) short 1 -sel-d) (- tab-height short 1)))
|
||||
(list (list (- (+ next-x tab-height) -sel-d short (- short-d) -2 inset) (- tab-height short -2 inset))))
|
||||
;; end point
|
||||
(begin
|
||||
(when light?
|
||||
(when (= pos selected)
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line (+ next-x tab-height) tab-height w tab-height)
|
||||
(send dc set-pen light-pen)
|
||||
(send dc draw-line (+ next-x tab-height) (add1 tab-height) w (add1 tab-height)))
|
||||
(let ([x (+ x tab-height)]
|
||||
[y (- tab-v-space (if (= pos selected) raise-h 0))])
|
||||
(send dc set-text-foreground
|
||||
(if (is-enabled-to-root?)
|
||||
black-color
|
||||
disabled-color))
|
||||
(send dc draw-text (car l) x y)
|
||||
(when (and (has-focus?)
|
||||
(= pos current-focus-tab))
|
||||
(let ([p (send dc get-pen)])
|
||||
(send dc set-pen "black" 1 'hilite)
|
||||
(let ([x (- x 1)]
|
||||
[y (+ y 2)]
|
||||
[w (+ (car wl) 2)]
|
||||
[h (- tab-height (* 2 tab-v-space) 2)])
|
||||
(send dc draw-line (+ x 0) (+ y -1) (+ x w -1) (+ y -1))
|
||||
(send dc draw-line (+ x 0) (+ y h) (+ x w -1) (+ y h))
|
||||
(send dc draw-line (+ x -1) (+ y 0) (+ x -1) (+ y h -1))
|
||||
(send dc draw-line (+ x w) (+ y 0) (+ x w) (+ y h -1)))
|
||||
(send dc set-pen p)))))
|
||||
(list (list (+ next-x inset (if (= selected (add1 pos)) -2 0)) (+ 2 tab-height (- inset)))))))
|
||||
(loop next-x (cdr l) (cdr wl) (add1 pos))))))))
|
||||
|
||||
|
||||
(define/override on-paint
|
||||
(entry-point
|
||||
(lambda ()
|
||||
(compute-sizes)
|
||||
(let ([dc (get-dc)]
|
||||
[active? (and (is-enabled-to-root?)
|
||||
(send (get-top-level) is-act-on?))])
|
||||
(send dc set-background bg-color)
|
||||
(send dc set-font font)
|
||||
(unless mac-tab?
|
||||
(send dc clear)
|
||||
(send dc set-origin 0 (+ 2 raise-h))
|
||||
(when (and tracking-pos tracking-hit?)
|
||||
(let ([b (send dc get-brush)])
|
||||
(send dc set-brush dark-brush)
|
||||
(send dc set-pen trans-pen)
|
||||
(send dc draw-polygon (map (lambda (x) (make-object wx:point% (car x) (cadr x)))
|
||||
(list-ref (draw-once #f 0 #f #f 1 #f) tracking-pos)))
|
||||
(send dc set-brush b))))
|
||||
(let-values ([(w h) (my-get-client-size)])
|
||||
(unless mac-tab?
|
||||
(send dc set-pen light-pen))
|
||||
(draw-once dc w #t #f 0 active?)
|
||||
(when mac-tab?
|
||||
(wx:draw-tab-base dc 0 (- tab-height 3) w 6 (if active? 1 0)))
|
||||
(when border?
|
||||
(when (> h tab-height)
|
||||
(send dc draw-line 1 (add1 tab-height) 1 h)
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line 0 tab-height 0 h)))
|
||||
(unless mac-tab?
|
||||
(send dc set-pen dark-pen))
|
||||
(draw-once dc w #f #t 0 active?)
|
||||
(when border?
|
||||
(when (> h tab-height)
|
||||
(send dc draw-line (- w 2) (+ 1 tab-height) (- w 2) (- h raise-h))
|
||||
(send dc draw-line 1 (- h 4 raise-h) w (- h 4 raise-h))
|
||||
(send dc set-pen border-pen)
|
||||
(send dc draw-line (- w 1) tab-height (- w 1) (- h raise-h))
|
||||
(send dc draw-line 0 (- h 3 raise-h) w (- h 3 raise-h)))))
|
||||
(send dc set-origin 0 0)))))
|
||||
|
||||
(define/override (on-size w h)
|
||||
(set! redo-regions? #t)
|
||||
(super on-size w h))
|
||||
|
||||
(define/private (my-get-client-size)
|
||||
(get-two-int-values (lambda (a b) (get-client-size a b))))
|
||||
|
||||
(define/public (get-selection)
|
||||
selected)
|
||||
|
||||
(define/public (set-selection i)
|
||||
(ready-regions)
|
||||
(when (< -1 i (length regions))
|
||||
(let* ([dc (get-dc)]
|
||||
[r (make-object wx:region% dc)]
|
||||
[old-rgn (list-ref regions selected)])
|
||||
(set! selected i)
|
||||
(send r union old-rgn)
|
||||
(setup-regions)
|
||||
(if mac-tab?
|
||||
(refresh) ;; but we need an immediate refresh!
|
||||
(let ([new-rgn (list-ref regions selected)])
|
||||
;; Union the new and old regions and repaint:
|
||||
(send r union new-rgn)
|
||||
(send dc set-clipping-region r)
|
||||
(on-paint)
|
||||
(send dc set-clipping-region #f))))))
|
||||
|
||||
(define/public (set-label i s)
|
||||
(set! tabs (let loop ([tabs tabs][i i])
|
||||
(if (zero? i)
|
||||
(cons (wx:label->plain-label s) (cdr tabs))
|
||||
(cons (car tabs) (loop (cdr tabs) (sub1 i))))))
|
||||
(set! tab-widths #f)
|
||||
(set! regions #f)
|
||||
(refresh))
|
||||
|
||||
(define/public (set tab-labels)
|
||||
(set! tabs (map wx:label->plain-label tab-labels))
|
||||
(set! tab-widths #f)
|
||||
(set! regions #f)
|
||||
(set! selected (max 0 (min selected (sub1 (length tabs)))))
|
||||
(refresh))
|
||||
|
||||
(define (-append s)
|
||||
(set! tabs (append tabs (list (wx:label->plain-label s))))
|
||||
(set! tab-widths #f)
|
||||
(set! regions #f)
|
||||
(refresh))
|
||||
(public (-append append))
|
||||
|
||||
(define/public (delete i)
|
||||
(set! tabs (let loop ([pos 0][tabs tabs])
|
||||
(if (= i pos)
|
||||
(cdr tabs)
|
||||
(cons (car tabs) (loop (add1 pos) (cdr tabs))))))
|
||||
(set! selected (min (if (selected . <= . i)
|
||||
selected
|
||||
(sub1 selected))
|
||||
(max 0 (sub1 (length tabs)))))
|
||||
(set! regions #f)
|
||||
(set! tab-widths #f)
|
||||
(refresh))
|
||||
|
||||
(define/override (handles-key-code code alpha? meta?)
|
||||
#f)
|
||||
|
||||
(super-instantiate (mred proxy parent -1 -1 -1 -1 '(transparent) #f))
|
||||
|
||||
(let ([focus-ok?
|
||||
;; For Mac OS X, this method indicates that the
|
||||
;; canvas should not necessarily get the focus
|
||||
;; on a click, and the result indicates whether
|
||||
;; it should accept tab focus in general
|
||||
(set-background-to-gray)])
|
||||
|
||||
(compute-sizes)
|
||||
(set-min-width (inexact->exact (ceiling (get-total-width))))
|
||||
(set-min-height (inexact->exact (ceiling (+ tab-height (if mac-tab? 6 9) raise-h))))
|
||||
(when mac-tab?
|
||||
(send (get-top-level) add-activate-update this))
|
||||
(set-tab-focus focus-ok?))))
|
||||
|
||||
(define wx-tab-group%
|
||||
(if (eq? 'unix (system-type))
|
||||
canvas-based-tab-group%
|
||||
(class* (make-window-glue%
|
||||
(make-control% wx:tab-group% 0 0 #t #t)) (wx-tab-group<%>)
|
||||
(inherit min-height)
|
||||
(define/override (tabbing-position x y w h)
|
||||
(list this x y w (min-height)))
|
||||
(define/override (handles-key-code code alpha? meta?) #f)
|
||||
(super-instantiate ())))))
|
||||
|
|
@ -160,7 +160,7 @@
|
|||
(unless horiz? (send p alignment 'left 'top))
|
||||
(unless multi? (stretchable-in-y #f))
|
||||
;; For Windows:
|
||||
(wx:set-combo-box-font font)
|
||||
; (wx:set-combo-box-font font)
|
||||
(spacing 3))
|
||||
(private-field
|
||||
[l (and label
|
||||
|
|
|
|||
|
|
@ -141,7 +141,6 @@
|
|||
(define-pangocairo pango_cairo_update_layout (_fun _cairo_t PangoLayout -> _void))
|
||||
(define-pango pango_layout_set_text (_fun PangoLayout [s : _string] [_int = -1] -> _void))
|
||||
(define-pangocairo pango_cairo_show_layout (_fun _cairo_t PangoLayout -> _void))
|
||||
(define-pangocairo pango_cairo_show_glyph_item (_fun _cairo_t _string _PangoGlyphItem-pointer -> _void))
|
||||
(define-pangocairo pango_cairo_show_glyph_string (_fun _cairo_t PangoFont _PangoGlyphString-pointer -> _void))
|
||||
|
||||
(define-pango pango_layout_iter_free (_fun PangoLayoutIter -> _void)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user