diff --git a/collects/drscheme/private/bitmap-message.ss b/collects/drscheme/private/bitmap-message.ss new file mode 100644 index 0000000000..10ca5a9339 --- /dev/null +++ b/collects/drscheme/private/bitmap-message.ss @@ -0,0 +1,19 @@ +#lang scheme + +(require mred/mred) +(provide bitmap-message%) + +(define bitmap-message% + (class canvas% + (inherit min-width min-height get-dc) + (define bm #f) + (define/override (on-paint) + (when bm + (let ([dc (get-dc)]) + (send dc draw-bitmap bm 0 0)))) + (define/public (set-bm b) + (set! bm b) + (min-width (send bm get-width)) + (min-height (send bm get-height))) + (super-new (stretchable-width #f) + (stretchable-height #f)))) \ No newline at end of file diff --git a/collects/drscheme/private/insert-large-letters-typed.ss b/collects/drscheme/private/insert-large-letters-typed.ss new file mode 100644 index 0000000000..ace549029d --- /dev/null +++ b/collects/drscheme/private/insert-large-letters-typed.ss @@ -0,0 +1,188 @@ +#lang typed-scheme + +(require "mred-typed.ss" + scheme/class + string-constants/string-constant) + +(provide insert-large-letters) + +(: insert-large-letters (String Char (Instance Scheme:Text%) Any -> Void)) +(define (insert-large-letters comment-prefix comment-character edit parent) + (let ([str (make-large-letters-dialog comment-prefix comment-character #f)]) + (when (and str + (not (equal? str ""))) + (render-large-letters comment-prefix comment-character (get-chosen-font) str edit) + (void)))) + +(preferences:set-default 'drscheme:large-letters-font #f (λ: ([x : Any]) + (or (and (pair? x) + (string? (car x)) + (let ([i (cdr x)]) + (and (integer? i) + (<= 1 i 255)))) + (not x)))) + +(: get-default-font (-> (Instance Font%))) +(define (get-default-font) + (send (send (editor:get-standard-style-list) + find-named-style + "Standard") + get-font)) + +(: get-chosen-font (-> (Instance Font%))) +(define (get-chosen-font) + (let ([pref-val (preferences:get 'drscheme:large-letters-font)]) + (cond + [pref-val + (let ([candidate (send the-font-list find-or-create-font (cdr pref-val) (car pref-val) 'default 'normal 'normal)]) + (if (equal? (send candidate get-face) (car pref-val)) + candidate + (get-default-font)))] + [else + (get-default-font)]))) + +(define columns-string "~a columns") + +;; make-large-letters-dialog : string char top-level-window<%> -> void +(: make-large-letters-dialog (String Char Any -> (Option String))) +(define (make-large-letters-dialog comment-prefix comment-character parent) + (define dlg (new dialog% + [parent parent] + [width 700] + [label (string-constant large-semicolon-letters)])) + (define: text-field : (Instance Text-Field%) + (new text-field% + [parent dlg] + [label (string-constant text-to-insert)] + [callback (λ: ([x : Any] [y : Any]) (update-txt (send text-field get-value)))])) + (: info-bar (Instance Horizontal-Panel%)) + (define info-bar (new horizontal-panel% + [parent dlg] + [stretchable-height #f])) + (define: font-choice : (Instance Choice%) + (new choice% + [label (string-constant fonts)] + [parent info-bar] + [choices (get-face-list)] + [callback + (λ: ([x : Any] [y : Any]) + (let ([old (preferences:get 'drscheme:large-letters-font)]) + (preferences:set 'drscheme:large-letters-font + (cons (send font-choice get-string-selection) + (if old + (cdr old) + (send (get-default-font) get-point-size)))) + (update-txt (send text-field get-value))))])) + + (: count (Instance Message%)) + (define count (new message% [label (format columns-string 1000)] [parent info-bar])) + (: pane1 (Instance Horizontal-Pane%)) + (define pane1 (new horizontal-pane% (parent info-bar))) + (: dark-msg (Instance Bitmap-Message%)) + (define dark-msg (new bitmap-message% [parent info-bar])) + (: pane2 (Instance Horizontal-Pane%)) + (define pane2 (new horizontal-pane% (parent info-bar))) + + (: txt (Instance Scheme:Text%)) + (define txt (new scheme:text%)) + (: ec (Instance Editor-Canvas%)) + (define ec (new editor-canvas% [parent dlg] [editor txt])) + (: button-panel (Instance Horizontal-Panel%)) + (define button-panel (new horizontal-panel% + [parent dlg] + [stretchable-height #f] + [alignment '(right center)])) + (define: ok? : Boolean #f) + (: ok Any) + (: cancel Any) + (define-values (ok cancel) + (gui-utils:ok/cancel-buttons button-panel + (λ: ([x : Any] [y : Any]) (set! ok? #t) (send dlg show #f)) + (λ: ([x : Any] [y : Any]) (send dlg show #f)))) + (: update-txt (String -> Any)) + (define (update-txt str) + (send txt begin-edit-sequence) + (send txt lock #f) + (send txt delete 0 (send txt last-position)) + (let ([bm (render-large-letters comment-prefix comment-character (get-chosen-font) str txt)]) + (send ec set-line-count (+ 1 (send txt last-paragraph))) + (send txt lock #t) + (send txt end-edit-sequence) + (send count set-label (format columns-string (get-max-line-width txt))) + (send dark-msg set-bm bm))) + + + + + ;; CHANGE - get-face can return #f + (let ([face (send (get-chosen-font) get-face)]) + (when face + (send font-choice set-string-selection face))) + + (send txt auto-wrap #f) + (update-txt " ") + (send text-field focus) + (send dlg show #t) + (and ok? (send text-field get-value))) + +(: get-max-line-width ((Instance Scheme:Text%) -> Number)) +(define (get-max-line-width txt) + (let loop ([i (+ (send txt last-paragraph) 1)] + [m #{0 :: Number}]) + (cond + [(zero? i) m] + [else (loop (- i 1) + (max m (- (send txt paragraph-end-position (- i 1)) + (send txt paragraph-start-position (- i 1)))))]))) + + +(: render-large-letters (String Char (Instance Font%) String (Instance Scheme:Text%) -> (Instance Bitmap%))) +(define (render-large-letters comment-prefix comment-character the-font str edit) + (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t))) + (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font)) + (define th (let-values ([(_1 h _2 _3) (send bdc get-text-extent "X" the-font)]) + (max raw-th h))) + (define tmp-color (make-object color%)) + + (: get-char (Number Number -> Char)) + (define (get-char x y) + (send bdc get-pixel x y tmp-color) + (let ([red (send tmp-color red)]) + (if (= red 0) + comment-character + #\space))) + (define bitmap + (make-object bitmap% + (max 1 (inexact->exact tw)) + (inexact->exact th) + #t)) + + (: fetch-line (Number -> String)) + (define (fetch-line y) + (let: loop : String ([x : Number (send bitmap get-width)] + [chars : (Listof Char) null]) + (cond + [(zero? x) (apply string chars)] + [else (loop (- x 1) (cons (get-char (- x 1) y) chars))]))) + + (send bdc set-bitmap bitmap) + (send bdc clear) + (send bdc set-font the-font) + (send bdc draw-text str 0 0) + + (send edit begin-edit-sequence) + (let ([start (send edit get-start-position)] + [end (send edit get-end-position)]) + (send edit delete start end) + (send edit insert "\n" start start) + (let loop ([y (send bitmap get-height)]) + (unless (zero? y) + (send edit insert (fetch-line (- y 1)) start start) + (send edit insert comment-prefix start start) + (send edit insert "\n" start start) + (loop (- y 1))))) + (send edit end-edit-sequence) + (send bdc set-bitmap #f) + bitmap) + +;(make-large-letters-dialog ";" #\; #f) \ No newline at end of file diff --git a/collects/drscheme/private/mred-typed.ss b/collects/drscheme/private/mred-typed.ss new file mode 100644 index 0000000000..5252df47ac --- /dev/null +++ b/collects/drscheme/private/mred-typed.ss @@ -0,0 +1,103 @@ +#lang typed-scheme + +;(require mred/mred) +(provide (all-defined-out)) + +(define-type-alias Bitmap% (Class (Number Number Boolean) + () + ([get-width (-> Number)] + [get-height (-> Number)]))) +(define-type-alias Font-List% (Class () () ([find-or-create-font (Any * -> (Instance Font%))]))) +(define-type-alias Font% (Class () () ([get-face (-> (Option String))] + [get-point-size (-> Number)]))) +(define-type-alias Dialog% (Class () + ([parent Any] [width Number] [label String]) + ([show (Any -> Void)]))) +(define-type-alias Text-Field% (Class () + ([parent Any] [callback Any] [label String]) + ([get-value (-> String)] + [focus (-> String)]))) +(define-type-alias Horizontal-Panel% (Class () + ([parent Any] + [stretchable-height Any #t] + [alignment (List Symbol Symbol) #t]) + ())) +(define-type-alias Choice% (Class () + ([parent Any] [label String] [choices List] [callback Any]) + ([get-string-selection (-> (Option String))] + [set-string-selection (String -> Void)]))) +(define-type-alias Message% (Class () + ([parent Any] [label String]) + ([set-label ((U String (Instance Bitmap%)) -> Void)]))) +(define-type-alias Horizontal-Pane% (Class () + ([parent Any]) + ())) +(define-type-alias Editor-Canvas% (Class () + ([parent Any] [editor Any]) + ([set-line-count (Number -> Void)]))) +(define-type-alias Bitmap-DC% (Class ((Instance Bitmap%)) + () + ([get-text-extent (String (Instance Font%) -> (values Number Number Number Number))] + [get-pixel (Number Number (Instance Color%) -> Boolean)] + [set-bitmap ((Option (Instance Bitmap%)) -> Void)] + [clear (-> Void)] + [set-font ((Instance Font%) -> Void)] + [draw-text (String Number Number -> Void)]))) +(define-type-alias Color% (Class () () ([red (-> Number)]))) +(define-type-alias Style-List% (Class () + () + ([find-named-style + (String -> (Instance (Class () + () + ([get-font (-> (Instance Font%))]))))]))) + +(define-type-alias Scheme:Text% (Class () + () + ([begin-edit-sequence (-> Void)] + [end-edit-sequence (-> Void)] + [lock (Boolean -> Void)] + [last-position (-> Number)] + [last-paragraph (-> Number)] + [delete (Number Number -> Void)] + [auto-wrap (Any -> Void)] + [paragraph-end-position (Number -> Number)] + [paragraph-start-position (Number -> Number)] + [get-start-position (-> Number)] + [get-end-position (-> Number)] + [insert (String Number Number -> Void)]))) + +(require/typed mred/mred + [the-font-list (Instance Font-List%)] + [dialog% Dialog%] + [text-field% Text-Field%] + [horizontal-panel% Horizontal-Panel%] + [choice% Choice%] + [get-face-list (-> (Listof String))] + [message% Message%] + [horizontal-pane% Horizontal-Pane%] + [editor-canvas% Editor-Canvas%] + [bitmap-dc% Bitmap-DC%] + [bitmap% Bitmap%] + [color% Color%]) + +(require/typed framework/framework + [preferences:set-default (Symbol Any Any -> Void)] + [preferences:set (Symbol Any -> Void)] + [editor:get-standard-style-list + (-> (Instance Style-List%))] + [scheme:text% Scheme:Text%] + [gui-utils:ok/cancel-buttons (Any (Any Any -> Any) (Any Any -> Any) -> (values Any Any))]) + +(require/typed "prefs-contract.ss" + [preferences:get-drscheme:large-letters-font (-> (U #f (Pair String Number)))]) + +(require (only-in "prefs-contract.ss" preferences:get)) +(provide preferences:get preferences:get-drscheme:large-letters-font) + +(define-type-alias Bitmap-Message% (Class () + ([parent Any]) + ([set-bm ((Instance Bitmap%) -> Void)]))) + + +(require/typed "bitmap-message.ss" + [bitmap-message% Bitmap-Message%]) \ No newline at end of file diff --git a/collects/drscheme/private/prefs-contract.ss b/collects/drscheme/private/prefs-contract.ss new file mode 100644 index 0000000000..cb648dd533 --- /dev/null +++ b/collects/drscheme/private/prefs-contract.ss @@ -0,0 +1,16 @@ +#lang scheme/base + +(require (for-syntax scheme/base) + framework/framework) + +(provide (rename-out [-preferences:get preferences:get]) + preferences:get-drscheme:large-letters-font) + +(define (preferences:get-drscheme:large-letters-font) + (preferences:get 'drscheme:large-letters-font)) + +(define-syntax (-preferences:get stx) + (syntax-case stx (quote) + [(_ (quote sym)) + (with-syntax ([nm (datum->syntax stx (string->symbol (string-append "preferences:get" "-" (symbol->string (syntax-e #'sym)))))]) + (syntax/loc stx (nm)))])) \ No newline at end of file diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 7faef49b55..e99c9ccd95 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -25,7 +25,7 @@ module browser threading seems wrong. mrlib/include-bitmap "drsig.ss" "auto-language.ss" - "insert-large-letters.ss" + "insert-large-letters-typed.ss" "first-line-text.ss" mrlib/switchable-button mrlib/cache-image-snip @@ -3956,4 +3956,4 @@ module browser threading seems wrong. (send frame update-toolbar-visibility) (send frame show #t) (set! first-frame? #f) - frame))) \ No newline at end of file + frame)))