merged 1227:1237 -- another draft of initial language. hope this one is better
svn: r1238
This commit is contained in:
Robby Findler
parent
355824e217
commit
3535a75479
|
|
@ -174,6 +174,7 @@
|
|||
current-language-settings
|
||||
current-value-port
|
||||
get-drs-bindings-keymap
|
||||
error-delta
|
||||
text%
|
||||
text<%>
|
||||
context<%>))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
(lib "hierlist.ss" "hierlist")
|
||||
(lib "class.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "kw.ss")
|
||||
"drsig.ss"
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "mred.ss" "mred")
|
||||
|
|
@ -12,6 +13,7 @@
|
|||
(lib "etc.ss")
|
||||
(lib "file.ss")
|
||||
(lib "pconvert.ss")
|
||||
(lib "bitmap-label.ss" "mrlib")
|
||||
(lib "getinfo.ss" "setup")
|
||||
(lib "toplevel.ss" "syntax"))
|
||||
|
||||
|
|
@ -43,7 +45,7 @@
|
|||
;; considered the default language
|
||||
(define default-language-position
|
||||
(list (string-constant initial-language-category)
|
||||
(string-constant choose-a-language-language)))
|
||||
(string-constant no-language-chosen)))
|
||||
|
||||
;; languages : (listof (instanceof language<%>))
|
||||
;; all of the languages supported in DrScheme
|
||||
|
|
@ -135,16 +137,16 @@
|
|||
(string-constant language-dialog-title)))
|
||||
(parent parent)
|
||||
(style '(resize-border))))
|
||||
(define welcome-before-panel (instantiate horizontal-panel% ()
|
||||
(define welcome-before-panel (instantiate horizontal-pane% ()
|
||||
(parent dialog)
|
||||
(stretchable-height #f)))
|
||||
(define language-dialog-meat-panel (make-object vertical-panel% dialog))
|
||||
(define language-dialog-meat-panel (make-object vertical-pane% dialog))
|
||||
|
||||
(define welcome-after-panel (instantiate vertical-panel% ()
|
||||
(define welcome-after-panel (instantiate vertical-pane% ()
|
||||
(parent dialog)
|
||||
(stretchable-height #f)))
|
||||
|
||||
(define button-panel (instantiate horizontal-panel% ()
|
||||
(define button-panel (instantiate horizontal-pane% ()
|
||||
(parent dialog)
|
||||
(stretchable-height #f)))
|
||||
|
||||
|
|
@ -176,7 +178,7 @@
|
|||
(define show-details-label (string-constant show-details-button-label))
|
||||
(define hide-details-label (string-constant hide-details-button-label))
|
||||
|
||||
(define button-gap (make-object horizontal-panel% button-panel))
|
||||
(define button-gap (make-object horizontal-pane% button-panel))
|
||||
(define-values (ok-button cancel-button)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
button-panel
|
||||
|
|
@ -316,9 +318,9 @@
|
|||
(send i toggle-open/closed)))
|
||||
(super-instantiate (parent))))
|
||||
|
||||
(define outermost-panel (make-object horizontal-panel% parent))
|
||||
(define outermost-panel (make-object horizontal-pane% parent))
|
||||
(define languages-hier-list (make-object selectable-hierlist% outermost-panel))
|
||||
(define details-outer-panel (make-object vertical-panel% outermost-panel))
|
||||
(define details-outer-panel (make-object vertical-pane% outermost-panel))
|
||||
(define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
|
||||
(define details-panel (make-object panel:single% details/manual-parent-panel))
|
||||
(define manual-ordering-panel (new vertical-panel% (parent details/manual-parent-panel)))
|
||||
|
|
@ -731,7 +733,7 @@
|
|||
(λ (x y)
|
||||
(details-callback))))
|
||||
|
||||
(define revert-to-defaults-outer-panel (make-object horizontal-panel% show-details-parent))
|
||||
(define revert-to-defaults-outer-panel (make-object horizontal-pane% show-details-parent))
|
||||
(define revert-to-defaults-button (make-object button%
|
||||
(string-constant revert-to-language-defaults)
|
||||
revert-to-defaults-outer-panel
|
||||
|
|
@ -1371,7 +1373,7 @@
|
|||
(add-language
|
||||
(make-simple 'mzscheme
|
||||
(list (string-constant initial-language-category)
|
||||
(string-constant choose-a-language-language))
|
||||
(string-constant no-language-chosen))
|
||||
(list 10000 1000)
|
||||
#f
|
||||
"Helps the user choose an initial language"
|
||||
|
|
@ -1379,39 +1381,130 @@
|
|||
|
||||
(define (not-a-language-extra-mixin %)
|
||||
(class %
|
||||
(define/override (get-style-delta) drscheme:rep:error-delta)
|
||||
|
||||
(define/override (front-end/interaction input settings teachpack-cache)
|
||||
(not-a-language-message)
|
||||
(λ () eof))
|
||||
(define/override (front-end/complete-program input settings teachpack-cache)
|
||||
(not-a-language-message)
|
||||
(λ () eof))
|
||||
(super-new)))
|
||||
(super-new)))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; @@
|
||||
; @ @
|
||||
; @@:@@: $@$ @@@@@ $@$: @ $@$: @@:@@: $@-@@@@ @@ $@$: $@-@@ -@@$
|
||||
; @+ :@ $- -$ @ -@ @ -@ @+ :@ $* :@ @ @ -@ $* :@ $ -$
|
||||
; @ @ @ @ @ @@@@@ -$@$@ @@@@@ @ -$@$@ @ @ @ @ @ @ -$@$@ @ @ @@@@@
|
||||
; @ @ @ @ @ $* @ @ $* @ @ @ @ @ @ @ $* @ @ @ $
|
||||
; @ @ $- -$ @: :$ @- *@ @ @- *@ @ @ $* :@ @: +@ @- *@ $* :@ +:
|
||||
; @@@ @@@ $@$ :@@$- -$$-@@ @@@@@ -$$-@@@@@ @@@ $@:@ :@$-@@ -$$-@@ $@:@ $@@+
|
||||
; -$ -$
|
||||
; -@@$ -@@$
|
||||
;
|
||||
;
|
||||
|
||||
|
||||
(define (not-a-language-message)
|
||||
(define (main)
|
||||
(o (string-constant must-choose-language))
|
||||
(o "\n")
|
||||
(let ([rep (drscheme:rep:current-rep)])
|
||||
(when rep
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(not-a-language-dialog rep)))))))
|
||||
|
||||
(define o
|
||||
(case-lambda
|
||||
[(arg)
|
||||
(cond
|
||||
[(string? arg)
|
||||
(fprintf (current-error-port) arg)]
|
||||
[(is-a? arg snip%)
|
||||
(write-special arg (current-error-port))])]
|
||||
[args (apply fprintf (current-error-port) args)]))
|
||||
|
||||
(main))
|
||||
|
||||
(define (not-a-language-dialog rep)
|
||||
(define drs-frame (send (send rep get-canvas) get-top-level-window))
|
||||
(define dialog (new dialog%
|
||||
(parent drs-frame)
|
||||
(label (string-constant drscheme))))
|
||||
(define qa-panel (new vertical-pane% (parent dialog)))
|
||||
(define button-panel (new horizontal-pane%
|
||||
(parent dialog)
|
||||
(stretchable-height #f)
|
||||
(alignment '(right center))))
|
||||
|
||||
(define close (new button%
|
||||
(parent button-panel)
|
||||
(callback (lambda (x y) (send dialog show #f)))
|
||||
(label (string-constant close))))
|
||||
|
||||
(define run (new button%
|
||||
(parent button-panel)
|
||||
(style '(border))
|
||||
(callback (λ (x y) (run-callback)))
|
||||
(label (make-bitmap-label
|
||||
(string-constant execute-button-label)
|
||||
(build-path (collection-path "icons") "run.png")))))
|
||||
|
||||
(define language-chosen? #f)
|
||||
|
||||
(define (main)
|
||||
(insert-red-message)
|
||||
(insert-text-pls)
|
||||
(display-plt-schemer)
|
||||
(display-standard-schemer)
|
||||
(display-future-choice))
|
||||
(display-future-choice)
|
||||
(space-em-out)
|
||||
(send dialog show #t))
|
||||
|
||||
(define (run-callback)
|
||||
(cond
|
||||
[language-chosen?
|
||||
(send dialog show #f)
|
||||
(send drs-frame execute-callback)]
|
||||
[else
|
||||
(message-box (string-constant drscheme)
|
||||
(string-constant choose-new-language-before-running))]))
|
||||
|
||||
(define (insert-red-message)
|
||||
(new canvas-message%
|
||||
(parent qa-panel)
|
||||
(font (get-font #:style 'italic))
|
||||
(label (string-constant must-choose-language))
|
||||
(color (send the-color-database find-color "red"))))
|
||||
|
||||
(define (space-em-out)
|
||||
(send qa-panel change-children
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[else
|
||||
(let loop ([x (car l)]
|
||||
[r (cdr l)])
|
||||
(cond
|
||||
[(null? r) (list x)]
|
||||
[else (list* x
|
||||
(new vertical-pane%
|
||||
(parent qa-panel)
|
||||
(min-height 5)
|
||||
(stretchable-height #f))
|
||||
(loop (car r)
|
||||
(cdr r)))]))]))))
|
||||
|
||||
|
||||
(define (display-future-choice)
|
||||
(let* ([txt (new text:standard-style-list%)]
|
||||
[es (new editor-snip%
|
||||
[with-border? #f]
|
||||
[left-margin 0]
|
||||
[top-margin 0]
|
||||
[bottom-margin 0]
|
||||
[right-margin 0]
|
||||
[editor txt])])
|
||||
(send txt insert (string-constant use-language-menu-item-in-future))
|
||||
(send txt change-style
|
||||
default-sd
|
||||
0
|
||||
(send txt last-position))
|
||||
(o es)
|
||||
(o "\n")))
|
||||
(new message%
|
||||
(label (string-constant use-language-menu-item-in-future))
|
||||
(parent qa-panel)))
|
||||
|
||||
(define (insert-text-pls)
|
||||
(for-each
|
||||
|
|
@ -1428,19 +1521,24 @@
|
|||
(string<=? (cadr x) (cadr y))])))))
|
||||
|
||||
(define (display-plt-schemer)
|
||||
(question/answer (string-constant seasoned-plt-schemer?)
|
||||
(question/answer (lambda (parent)
|
||||
(new canvas-message%
|
||||
(parent parent)
|
||||
(label (string-constant seasoned-plt-schemer?))))
|
||||
(list (string-constant professional-languages)
|
||||
"(module ...)")
|
||||
(list "PLT-206-small.png" "icons")
|
||||
void))
|
||||
(list "PLT-206-small.png"
|
||||
"icons")))
|
||||
|
||||
(define (display-standard-schemer)
|
||||
(question/answer (string-constant looking-for-standard-scheme?)
|
||||
(question/answer (lambda (parent)
|
||||
(new canvas-message%
|
||||
(parent parent)
|
||||
(label (string-constant looking-for-standard-scheme?))))
|
||||
(list (string-constant professional-languages)
|
||||
(string-constant plt)
|
||||
(string-constant pretty-big-scheme))
|
||||
(list "r5rs.png" "icons")
|
||||
void))
|
||||
(list "r5rs.png" "icons")))
|
||||
|
||||
(define (display-text-pl lst)
|
||||
(let ([icon-lst (car lst)]
|
||||
|
|
@ -1448,30 +1546,87 @@
|
|||
[lang (cddr lst)]
|
||||
[using-before (string-constant using-a-textbook-before)]
|
||||
[using-after (string-constant using-a-textbook-after)])
|
||||
(question/answer (string-append using-before text-name using-after)
|
||||
(question/answer (lambda (parent)
|
||||
(new canvas-message%
|
||||
(parent parent)
|
||||
(label using-before))
|
||||
(new canvas-message%
|
||||
(parent parent)
|
||||
(font (get-font #:style 'italic))
|
||||
(label text-name))
|
||||
(new canvas-message%
|
||||
(parent parent)
|
||||
(label using-after)))
|
||||
lang
|
||||
icon-lst
|
||||
(λ (txt)
|
||||
(send txt change-style
|
||||
italic-sd
|
||||
(string-length using-before)
|
||||
(+ (string-length using-before)
|
||||
(string-length text-name)))))))
|
||||
icon-lst)))
|
||||
|
||||
(define (question/answer question lang icon-lst proc)
|
||||
(define default-font (send the-font-list find-or-create-font
|
||||
12
|
||||
'default
|
||||
'normal
|
||||
'normal))
|
||||
|
||||
(define/kw (get-font #:key
|
||||
(point-size (send default-font get-point-size))
|
||||
(family (send default-font get-family))
|
||||
(style (send default-font get-style))
|
||||
(weight (send default-font get-weight))
|
||||
(underlined (send default-font get-underlined))
|
||||
(smoothing (send default-font get-smoothing)))
|
||||
(send the-font-list find-or-create-font
|
||||
point-size
|
||||
family
|
||||
style
|
||||
weight
|
||||
underlined
|
||||
smoothing))
|
||||
|
||||
(define canvas-message%
|
||||
(class canvas%
|
||||
(init-field label
|
||||
[font (get-font)]
|
||||
[callback void]
|
||||
[color (send the-color-database find-color "black")])
|
||||
|
||||
(define/override (on-event evt)
|
||||
(cond
|
||||
[(send evt button-up?)
|
||||
(callback)]
|
||||
[else
|
||||
(super on-event evt)]))
|
||||
|
||||
(define/override (on-paint)
|
||||
(let* ([dc (get-dc)]
|
||||
[old-font (send dc get-font)]
|
||||
[old-tf (send dc get-text-foreground)])
|
||||
(send dc set-text-foreground color)
|
||||
(send dc set-font font)
|
||||
(send dc draw-text label 0 0 #t)
|
||||
(send dc set-font old-font)
|
||||
(send dc set-text-foreground old-tf)))
|
||||
|
||||
(super-new [stretchable-width #f]
|
||||
[stretchable-height #f]
|
||||
[style '(transparent)])
|
||||
|
||||
(inherit min-width min-height get-dc)
|
||||
(let-values ([(w h _1 _2) (send (get-dc) get-text-extent label font #t)])
|
||||
(min-width (inexact->exact (floor w)))
|
||||
(min-height (inexact->exact (floor h))))))
|
||||
|
||||
(define (question/answer line1 lang icon-lst)
|
||||
(display-two-line-choice
|
||||
icon-lst
|
||||
(λ (inner-txt)
|
||||
(send inner-txt insert (format "~a\n~a" question (string-constant start-with-before)))
|
||||
(send inner-txt change-style default-sd 0 (send inner-txt last-position))
|
||||
(lang-link-snip lang inner-txt)
|
||||
(let ([before-pos (send inner-txt last-position)])
|
||||
(send inner-txt insert (string-constant start-with-after))
|
||||
(send inner-txt change-style
|
||||
default-sd
|
||||
before-pos
|
||||
(send inner-txt last-position)))
|
||||
(proc inner-txt))))
|
||||
(λ (panel1 panel2)
|
||||
(line1 panel1)
|
||||
(new canvas-message% (parent panel2) (label (string-constant start-with-before)))
|
||||
(new canvas-message%
|
||||
(parent panel2)
|
||||
(label (car (last-pair lang)))
|
||||
(color (send the-color-database find-color "blue"))
|
||||
(callback
|
||||
(λ () (change-current-lang-to lang)))
|
||||
(font (get-font #:underlined #t))))))
|
||||
|
||||
;; get-text-pls : path -> (listof (list* string string (listof string))
|
||||
;; gets the questions from an info.ss file.
|
||||
|
|
@ -1500,128 +1655,27 @@
|
|||
qs)
|
||||
'())))
|
||||
|
||||
(define (lang-link-snip lang txt)
|
||||
#;
|
||||
(let ([before (send txt last-position)])
|
||||
(send txt insert (car (last-pair lang)))
|
||||
(let ([after (send txt last-position)])
|
||||
(send txt change-style link-sd before after)
|
||||
(send txt set-clickback before after
|
||||
(λ (txt start end)
|
||||
(change-current-lang-to lang txt)))))
|
||||
|
||||
(send txt insert
|
||||
(new link-snip%
|
||||
[words (car (last-pair lang))]
|
||||
[callback
|
||||
(λ (snip)
|
||||
(change-current-lang-to lang snip))])))
|
||||
|
||||
(define o
|
||||
(case-lambda
|
||||
[(arg)
|
||||
(cond
|
||||
[(string? arg)
|
||||
(fprintf (current-error-port) arg)]
|
||||
[(is-a? arg snip%)
|
||||
(write-special arg (current-error-port))])]
|
||||
[args (apply fprintf (current-error-port) args)]))
|
||||
|
||||
(define arrow-cursor (make-object cursor% 'arrow))
|
||||
|
||||
(define link-snip%
|
||||
(class editor-snip%
|
||||
(init-field words callback)
|
||||
|
||||
(define/override (adjust-cursor dc x y editorx editory event) arrow-cursor)
|
||||
|
||||
(define/override (on-event dc x y editorx editory event)
|
||||
(when (send event button-up?)
|
||||
(callback this)))
|
||||
|
||||
(define/override (copy)
|
||||
(new link-snip% [words words] [callback callback]))
|
||||
|
||||
(define txt (new text:standard-style-list%))
|
||||
|
||||
(super-new [editor txt] [with-border? #f]
|
||||
[left-margin 0]
|
||||
[right-margin 0]
|
||||
[top-margin 0]
|
||||
[bottom-margin 0])
|
||||
(inherit get-flags set-flags set-style)
|
||||
(set-flags (cons 'handles-events (get-flags)))
|
||||
|
||||
(send txt insert words)
|
||||
(send txt change-style link-sd 0 (send txt last-position))))
|
||||
|
||||
#;
|
||||
(define link-snip%
|
||||
(class string-snip%
|
||||
(init-field words callback)
|
||||
|
||||
(define/override (adjust-cursor dc x y editorx editory event) arrow-cursor)
|
||||
|
||||
(define/override (on-event dc x y editorx editory event)
|
||||
(when (send event button-up?)
|
||||
(callback this)))
|
||||
|
||||
(define/override (copy)
|
||||
(new link-snip% [words words] [callback callback]))
|
||||
|
||||
(super-make-object words)
|
||||
(inherit get-flags set-flags set-style)
|
||||
(set-style link-style)
|
||||
(set-flags (cons 'handles-events (remq 'is-text (get-flags))))))
|
||||
|
||||
(define italic-sd (make-object style-delta% 'change-style 'slant))
|
||||
|
||||
(define link-sd (make-object style-delta% 'change-underline #t))
|
||||
(define stupid-internal-define-syntax1
|
||||
(begin (send link-sd set-delta-foreground "blue")
|
||||
(send link-sd set-family 'default)))
|
||||
|
||||
(define default-sd (make-object style-delta% 'change-family 'default))
|
||||
|
||||
(define link-style
|
||||
(send (editor:get-standard-style-list)
|
||||
find-or-create-style
|
||||
(send (editor:get-standard-style-list) find-named-style "Standard")
|
||||
link-sd))
|
||||
|
||||
(define (display-two-line-choice icon-lst proc)
|
||||
(let* ([outer-txt (new text:standard-style-list%)]
|
||||
[outer-es (new editor-snip% (editor outer-txt) (with-border? #f)
|
||||
[left-margin 0]
|
||||
[right-margin 0]
|
||||
[top-margin 0]
|
||||
[bottom-margin 0])]
|
||||
[inner-txt (new text:standard-style-list%)]
|
||||
[inner-es (new editor-snip% (editor inner-txt) (with-border? #f)
|
||||
[top-margin 0] [bottom-margin 0])]
|
||||
[icon-path
|
||||
(build-path (apply collection-path (cdr icon-lst)) (car icon-lst))])
|
||||
(send outer-txt insert (make-object image-snip% icon-path))
|
||||
(send outer-txt insert inner-es)
|
||||
(proc inner-txt)
|
||||
(send outer-txt change-style
|
||||
(make-object style-delta% 'change-alignment 'top)
|
||||
0
|
||||
(send outer-txt last-position))
|
||||
(send inner-txt lock #t)
|
||||
(send outer-txt lock #t)
|
||||
(o outer-es)
|
||||
(o "\n")))
|
||||
|
||||
(define err-style-delta
|
||||
(let ([err-sd (make-object style-delta% 'change-italic)])
|
||||
(send err-sd set-delta-foreground (make-object color% 255 0 0))
|
||||
err-sd))
|
||||
|
||||
(let* ([hp (new horizontal-pane%
|
||||
(parent qa-panel)
|
||||
(alignment '(center top))
|
||||
(stretchable-height #f))]
|
||||
[icon (new message%
|
||||
(label (make-object bitmap%
|
||||
(build-path (apply collection-path (cdr icon-lst))
|
||||
(car icon-lst))
|
||||
'unknown/mask))
|
||||
(parent hp))]
|
||||
[vp (new vertical-pane%
|
||||
(parent hp)
|
||||
(alignment '(left top))
|
||||
(stretchable-height #f))])
|
||||
(proc (new horizontal-pane% (parent vp))
|
||||
(new horizontal-pane% (parent vp)))))
|
||||
|
||||
;; change-current-lang-to : (listof string) -> void
|
||||
(define (change-current-lang-to lang-strings snip)
|
||||
(let ([parent (find-parent-from-snip snip)]
|
||||
[lang (ormap
|
||||
(define (change-current-lang-to lang-strings)
|
||||
(let ([lang (ormap
|
||||
(λ (x)
|
||||
(and (equal? lang-strings (send x get-language-position))
|
||||
x))
|
||||
|
|
@ -1633,11 +1687,11 @@
|
|||
(language-dialog #f
|
||||
(make-language-settings lang
|
||||
(send lang default-settings))
|
||||
parent)])
|
||||
drs-frame)])
|
||||
(when new-lang
|
||||
(set! language-chosen? #t)
|
||||
(preferences:set settings-preferences-symbol new-lang)
|
||||
(when (is-a? parent drscheme:unit:frame<%>)
|
||||
(send (send parent get-definitions-text) set-next-settings new-lang))))))
|
||||
(send (send drs-frame get-definitions-text) set-next-settings new-lang)))))
|
||||
|
||||
(main))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require (lib "unitsig.ss")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"drsig.ss")
|
||||
|
||||
|
|
@ -24,6 +25,11 @@
|
|||
(set! modes (cons new-mode modes))
|
||||
new-mode))
|
||||
|
||||
(define (not-a-language-language? l)
|
||||
(and (not (null? l))
|
||||
(equal? (car (last-pair l))
|
||||
(string-constant no-language-chosen))))
|
||||
|
||||
(define (add-initial-modes)
|
||||
|
||||
;; must be added first, to make it last in mode list,
|
||||
|
|
@ -39,4 +45,6 @@
|
|||
#f
|
||||
(λ (text prompt-position) #t)
|
||||
(λ (l)
|
||||
(and l (ormap (λ (x) (regexp-match #rx"Algol" x)) l))))))))
|
||||
(and l
|
||||
(or (not-a-language-language? l)
|
||||
(ormap (λ (x) (regexp-match #rx"Algol" x)) l)))))))))
|
||||
|
|
|
|||
Binary file not shown.
|
Before Width: | Height: | Size: 1.9 KiB After Width: | Height: | Size: 999 B |
|
|
@ -1,94 +1,103 @@
|
|||
(module bitmap-label mzscheme
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "contract.ss"))
|
||||
(lib "etc.ss")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
[make-bitmap-label (opt->
|
||||
(string?
|
||||
(union path-string?
|
||||
(is-a?/c bitmap%)))
|
||||
((is-a?/c font%))
|
||||
(is-a?/c bitmap%))]
|
||||
[bitmap-label-maker (string?
|
||||
(union path-string?
|
||||
(is-a?/c bitmap%))
|
||||
. -> .
|
||||
(any/c . -> . (is-a?/c bitmap%)))])
|
||||
|
||||
(define bitmap-label-maker
|
||||
(case-lambda
|
||||
[(text filename-or-bitmap)
|
||||
(define make-bitmap-label
|
||||
(opt-lambda (text filename-or-bitmap [font normal-control-font])
|
||||
(let*-values ([(outside-margin) 2]
|
||||
[(img-bitmap-dc img-bitmap img-width img-height)
|
||||
(let ([mdc (make-object bitmap-dc%)]
|
||||
[q (if (filename-or-bitmap . is-a? . bitmap%)
|
||||
filename-or-bitmap
|
||||
(make-object bitmap% filename-or-bitmap 'unknown/mask))])
|
||||
(if (send q ok?)
|
||||
(begin (send mdc set-bitmap q)
|
||||
(values mdc
|
||||
q
|
||||
(send q get-width)
|
||||
(send q get-height)))
|
||||
(let ([b (make-object bitmap% 1 1)])
|
||||
(send mdc set-bitmap b)
|
||||
(send mdc clear)
|
||||
(values mdc q 0 0))))]
|
||||
[(width height descent leading)
|
||||
(send img-bitmap-dc get-text-extent text font)]
|
||||
[(middle-margin) (if (and (zero? img-width)
|
||||
(zero? img-height))
|
||||
0
|
||||
3)]
|
||||
[(new-width) (inexact->exact
|
||||
(floor
|
||||
(+ outside-margin
|
||||
img-width
|
||||
middle-margin
|
||||
width
|
||||
outside-margin)))]
|
||||
[(new-height) (inexact->exact
|
||||
(floor (+ outside-margin
|
||||
(max img-height height)
|
||||
outside-margin)))]
|
||||
[(bitmap-dc) (make-object bitmap-dc%)]
|
||||
[(new-bitmap) (make-object bitmap% new-width new-height)]
|
||||
[(new-bitmap-mask) (make-object bitmap% new-width new-height)])
|
||||
(send new-bitmap set-loaded-mask new-bitmap-mask)
|
||||
(send img-bitmap-dc set-bitmap #f)
|
||||
(send bitmap-dc set-bitmap new-bitmap-mask)
|
||||
|
||||
(send bitmap-dc set-font font)
|
||||
(send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
(send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
||||
|
||||
|
||||
(send bitmap-dc clear)
|
||||
(send bitmap-dc draw-text text
|
||||
(+ outside-margin img-width middle-margin)
|
||||
(- (/ new-height 2) (/ height 2)))
|
||||
|
||||
(cond
|
||||
[(send img-bitmap get-loaded-mask)
|
||||
(send bitmap-dc draw-bitmap
|
||||
(send img-bitmap get-loaded-mask)
|
||||
outside-margin
|
||||
(- (/ new-height 2) (/ img-height 2)))]
|
||||
[else
|
||||
(send bitmap-dc draw-rectangle
|
||||
outside-margin
|
||||
(- (/ new-height 2) (/ img-height 2))
|
||||
img-width
|
||||
img-height)])
|
||||
|
||||
(send bitmap-dc set-bitmap new-bitmap)
|
||||
(send bitmap-dc clear)
|
||||
(send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
(send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
||||
(send bitmap-dc draw-rectangle
|
||||
(+ outside-margin img-width middle-margin)
|
||||
(- (/ new-height 2) (/ height 2))
|
||||
width height)
|
||||
(send bitmap-dc draw-bitmap
|
||||
img-bitmap
|
||||
outside-margin
|
||||
(- (/ new-height 2) (/ img-height 2)))
|
||||
(send bitmap-dc set-bitmap #f)
|
||||
new-bitmap)))
|
||||
|
||||
(define (bitmap-label-maker text filename-or-bitmap)
|
||||
(let ([bm (make-bitmap-label text filename-or-bitmap)])
|
||||
(lambda (area-container-window)
|
||||
(let*-values ([(outside-margin) 2]
|
||||
[(font) normal-control-font]
|
||||
[(img-bitmap-dc img-bitmap img-width img-height)
|
||||
(let ([mdc (make-object bitmap-dc%)]
|
||||
[q (if (filename-or-bitmap . is-a? . bitmap%)
|
||||
filename-or-bitmap
|
||||
(make-object bitmap% filename-or-bitmap 'unknown/mask))])
|
||||
(if (send q ok?)
|
||||
(begin (send mdc set-bitmap q)
|
||||
(values mdc
|
||||
q
|
||||
(send q get-width)
|
||||
(send q get-height)))
|
||||
(let ([b (make-object bitmap% 1 1)])
|
||||
(send mdc set-bitmap b)
|
||||
(send mdc clear)
|
||||
(values mdc q 0 0))))]
|
||||
[(width height descent leading)
|
||||
(send img-bitmap-dc get-text-extent text font)]
|
||||
[(middle-margin) (if (and (zero? img-width)
|
||||
(zero? img-height))
|
||||
0
|
||||
3)]
|
||||
[(new-width) (inexact->exact
|
||||
(floor
|
||||
(+ outside-margin
|
||||
img-width
|
||||
middle-margin
|
||||
width
|
||||
outside-margin)))]
|
||||
[(new-height) (inexact->exact
|
||||
(floor (+ outside-margin
|
||||
(max img-height height)
|
||||
outside-margin)))]
|
||||
[(bitmap-dc) (make-object bitmap-dc%)]
|
||||
[(new-bitmap) (make-object bitmap% new-width new-height)]
|
||||
[(new-bitmap-mask) (make-object bitmap% new-width new-height)])
|
||||
(send new-bitmap set-loaded-mask new-bitmap-mask)
|
||||
(send img-bitmap-dc set-bitmap #f)
|
||||
(send bitmap-dc set-bitmap new-bitmap-mask)
|
||||
|
||||
(send bitmap-dc set-font font)
|
||||
(send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
(send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
||||
|
||||
|
||||
(send bitmap-dc clear)
|
||||
(send bitmap-dc draw-text text
|
||||
(+ outside-margin img-width middle-margin)
|
||||
(- (/ new-height 2) (/ height 2)))
|
||||
|
||||
(cond
|
||||
[(send img-bitmap get-loaded-mask)
|
||||
(send bitmap-dc draw-bitmap
|
||||
(send img-bitmap get-loaded-mask)
|
||||
outside-margin
|
||||
(- (/ new-height 2) (/ img-height 2)))]
|
||||
[else
|
||||
(send bitmap-dc draw-rectangle
|
||||
outside-margin
|
||||
(- (/ new-height 2) (/ img-height 2))
|
||||
img-width
|
||||
img-height)])
|
||||
|
||||
(send bitmap-dc set-bitmap new-bitmap)
|
||||
(send bitmap-dc clear)
|
||||
(send bitmap-dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
(send bitmap-dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
|
||||
(send bitmap-dc draw-rectangle
|
||||
(+ outside-margin img-width middle-margin)
|
||||
(- (/ new-height 2) (/ height 2))
|
||||
width height)
|
||||
(send bitmap-dc draw-bitmap
|
||||
img-bitmap
|
||||
outside-margin
|
||||
(- (/ new-height 2) (/ img-height 2)))
|
||||
(send bitmap-dc set-bitmap #f)
|
||||
new-bitmap))])))
|
||||
bm))))
|
||||
|
|
|
|||
Binary file not shown.
|
Before Width: | Height: | Size: 1018 B After Width: | Height: | Size: 336 B |
BIN
collects/profj/htdch-icon.png
Normal file
BIN
collects/profj/htdch-icon.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1000 B |
|
|
@ -1,4 +1,6 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(require (lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(define name "ProfessorJ")
|
||||
(define doc.txt "doc.txt")
|
||||
(define tools (list (list "tool.ss")))
|
||||
|
|
@ -7,4 +9,10 @@
|
|||
(define compile-subcollections (list (list "profj" "parsers")
|
||||
(list "profj" "libs" "java" "lang")
|
||||
(list "profj" "libs" "java" "io")
|
||||
(list "profj" "libs" "java" "util"))))
|
||||
(list "profj" "libs" "java" "util")))
|
||||
(define textbook-pls
|
||||
(list (list '("htdch-icon.png" "profj")
|
||||
"How to Design Class Hierarchies"
|
||||
(string-constant experimental-languages)
|
||||
"ProfessorJ"
|
||||
"Beginner"))))
|
||||
|
|
|
|||
|
|
@ -962,6 +962,7 @@ please adhere to these guidelines:
|
|||
(use-other "... using DrScheme for some other reason?")
|
||||
(use-eopl "... using DrScheme with Essentials of Programming Languages?")
|
||||
(pl-lang-choice-format "Initial language: ~a")
|
||||
(choose-new-language-before-running "Please choose a new language before running.")
|
||||
|
||||
|
||||
;;; languages
|
||||
|
|
@ -988,7 +989,7 @@ please adhere to these guidelines:
|
|||
(teaching-languages "Teaching Languages")
|
||||
(experimental-languages "Experimental Languages")
|
||||
(initial-language-category "Initial language")
|
||||
(choose-a-language-language "Choose-a-language language")
|
||||
(no-language-chosen "No language chosen")
|
||||
|
||||
(module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user